{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.Plain where

import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.Tuple (snd)
import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural)
import Numeric.Natural (Natural)
import Prelude (fromIntegral, Num(..), pred)
import System.Console.ANSI
import Text.Show (Show(..), showString, showParen)
import qualified Data.Foldable as Fold
import qualified Data.List as List
import qualified Data.Text.Lazy as TL

import Symantic.Document.API

-- * Type 'Plain'
-- | Church encoded for performance concerns.
-- Kind like 'ParsecT' in @megaparsec@ but a little bit different
-- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
-- when in the left hand side of ('<>').
-- Prepending is done using continuation, like in a difference list.
newtype Plain d = Plain
 { unPlain ::
     {-curr-}PlainInh d ->
     {-curr-}PlainState d ->
     {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
     PlainFit d
     -- NOTE: equivalent to:
     -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
 }
instance (Show d, Spaceable d) => Show (Plain d) where
        show = show . runPlain

runPlain :: Spaceable d => Plain d -> d
runPlain x =
        unPlain x
         defPlainInh
         defPlainState
         {-k-}(\(px,_sx) fits _overflow ->
                -- NOTE: if px fits, then appending mempty fits
                fits (px mempty) )
         {-fits-}id
         {-overflow-}id

-- ** Type 'PlainState'
data PlainState d = PlainState
 { plainState_buffer          :: ![PlainChunk d]
 , plainState_bufferStart     :: !Column
   -- ^ The 'Column' from which the 'plainState_buffer'
   -- must be written.
 , plainState_bufferWidth     :: !Width
   -- ^ The 'Width' of the 'plainState_buffer' so far.
 , plainState_breakIndent :: !Indent
   -- ^ The amount of 'Indent' added by 'breakspace'
   -- that can be reached by breaking the 'space'
   -- into a 'newlineJustifyingPlain'.
 } deriving (Show)

defPlainState :: PlainState d
defPlainState = PlainState
 { plainState_buffer      = mempty
 , plainState_bufferStart = 0
 , plainState_bufferWidth = 0
 , plainState_breakIndent = 0
 }

-- ** Type 'PlainInh'
data PlainInh d = PlainInh
 { plainInh_width     :: !(Maybe Column)
 , plainInh_justify   :: !Bool
 , plainInh_indent    :: !Indent
 , plainInh_indenting :: !(Plain d)
 , plainInh_sgr       :: ![SGR]
 }

defPlainInh :: Spaceable d => PlainInh d
defPlainInh = PlainInh
 { plainInh_width     = Nothing
 , plainInh_justify   = False
 , plainInh_indent    = 0
 , plainInh_indenting = mempty
 , plainInh_sgr       = []
 }

-- ** Type 'PlainFit'
-- | Double continuation to qualify the returned document
-- as fitting or overflowing the given 'plainInh_width'.
-- It's like @('Bool',d)@ in a normal style
-- (a non continuation-passing-style).
type PlainFit d = {-fits-}(d -> d) ->
                  {-overflow-}(d -> d) ->
                  d

-- ** Type 'PlainChunk'
data PlainChunk d
 =   PlainChunk_Ignored !d
     -- ^ Ignored by the justification but kept in place.
     -- Used for instance to put ANSI sequences.
 |   PlainChunk_Word !(Word d)
 |   PlainChunk_Spaces !Width
     -- ^ 'spaces' preserved to be interleaved
     -- correctly with 'PlainChunk_Ignored'.
instance Show d => Show (PlainChunk d) where
        showsPrec p x =
                showParen (p>10) $
                case x of
                 PlainChunk_Ignored d ->
                        showString "Z " .
                        showsPrec 11 d
                 PlainChunk_Word (Word d) ->
                        showString "W " .
                        showsPrec 11 d
                 PlainChunk_Spaces s ->
                        showString "S " .
                        showsPrec 11 s
instance Lengthable d => Lengthable (PlainChunk d) where
        width = \case
         PlainChunk_Ignored{} -> 0
         PlainChunk_Word d -> width d
         PlainChunk_Spaces s -> s
        nullWidth = \case
         PlainChunk_Ignored{} -> True
         PlainChunk_Word d -> nullWidth d
         PlainChunk_Spaces s -> s == 0
instance From [SGR] d => From [SGR] (PlainChunk d) where
        from sgr = PlainChunk_Ignored (from sgr)

runPlainChunk :: Spaceable d => PlainChunk d -> d
runPlainChunk = \case
 PlainChunk_Ignored d -> d
 PlainChunk_Word (Word d) -> d
 PlainChunk_Spaces s -> spaces s

instance Semigroup d => Semigroup (Plain d) where
        Plain x <> Plain y = Plain $ \inh st k ->
                x inh st $ \(px,sx) ->
                        y inh sx $ \(py,sy) ->
                                k (px.py,sy)
instance Monoid d => Monoid (Plain d) where
        mempty = Plain $ \_inh st k -> k (id,st)
        mappend = (<>)
instance Spaceable d => Spaceable (Plain d) where
        -- | The default 'newline' does not justify 'plainState_buffer',
        -- for that use 'newlineJustifyingPlain'.
        newline = Plain $ \inh st ->
                unPlain
                 (  newlinePlain
                 <> indentPlain
                 <> propagatePlain (plainState_breakIndent st)
                 <> flushlinePlain
                 ) inh st
                where
                indentPlain = Plain $ \inh ->
                        unPlain
                         (plainInh_indenting inh)
                         inh{plainInh_justify=False}
                newlinePlain = Plain $ \inh st k ->
                        k (\next ->
                                (if plainInh_justify inh
                                        then joinLinePlainChunk $ List.reverse $ plainState_buffer st
                                        else mempty
                                )<>newline<>next
                         , st
                         { plainState_bufferStart = 0
                         , plainState_bufferWidth = 0
                         , plainState_buffer      = mempty
                         })
                propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
                        k (id,st1)
                         fits
                         {-overflow-}(
                                -- NOTE: the text after this newline overflows,
                                -- so propagate the overflow before this 'newline',
                                -- if and only if there is a 'breakspace' before this 'newline'
                                -- whose replacement by a 'newline' indents to a lower indent
                                -- than this 'newline''s indent.
                                -- Otherwise there is no point in propagating the overflow.
                                if breakIndent < plainInh_indent inh
                                then overflow
                                else fits
                         )
        space = spaces 1
        spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
                let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
                if plainInh_justify inh
                then
                        let newState = st
                                 { plainState_buffer =
                                        case plainState_buffer of
                                         PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
                                         buf -> PlainChunk_Spaces n:buf
                                 , plainState_bufferWidth = plainState_bufferWidth + n
                                 } in
                        case plainInh_width inh of
                         Just maxWidth | maxWidth < newWidth ->
                                overflow $ k (id{-(d<>)-}, newState) fits overflow
                         _ -> k (id{-(d<>)-}, newState) fits overflow
                else
                        let newState = st
                                 { plainState_bufferWidth = plainState_bufferWidth + n
                                 } in
                        case plainInh_width inh of
                         Just maxWidth | maxWidth < newWidth ->
                                overflow $ k ((spaces n <>), newState) fits fits
                         _ -> k ((spaces n <>), newState) fits overflow
instance (From (Word s) d, Semigroup d, Lengthable s) =>
         From (Word s) (Plain d) where
        from s = Plain $ \inh st@PlainState{..} k fits overflow ->
                let wordWidth = width s in
                if wordWidth <= 0
                then k (id,st) fits overflow
                else
                        let newBufferWidth = plainState_bufferWidth + wordWidth in
                        let newWidth = plainState_bufferStart + newBufferWidth in
                        if plainInh_justify inh
                        then
                                let newState = st
                                         { plainState_buffer =
                                                PlainChunk_Word (Word (from s)) :
                                                plainState_buffer
                                         , plainState_bufferWidth = newBufferWidth
                                         } in
                                case plainInh_width inh of
                                 Just maxWidth | maxWidth < newWidth ->
                                        overflow $ k (id, newState) fits overflow
                                 _ -> k (id, newState) fits overflow
                        else
                                let newState = st
                                         { plainState_bufferWidth = newBufferWidth
                                         } in
                                case plainInh_width inh of
                                 Just maxWidth | maxWidth < newWidth ->
                                        overflow $ k ((from s <>), newState) fits fits
                                 _ -> k ((from s <>), newState) fits overflow
instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
         From (Line s) (Plain d) where
        from =
                mconcat .
                List.intersperse breakspace .
                (from <$>) .
                words .
                unLine
instance Spaceable d => Indentable (Plain d) where
        align p = (flushlinePlain <>) $ Plain $ \inh st ->
                let col = plainState_bufferStart st + plainState_bufferWidth st in
                unPlain p inh
                 { plainInh_indent    = col
                 , plainInh_indenting =
                        if plainInh_indent inh <= col
                        then
                                plainInh_indenting inh <>
                                spaces (col`minusNatural`plainInh_indent inh)
                        else spaces col
                 } st
        setIndent d i p = Plain $ \inh ->
                unPlain p inh
                 { plainInh_indent    = i
                 , plainInh_indenting = d
                 }
        incrIndent d i p = Plain $ \inh ->
                unPlain p inh
                 { plainInh_indent    = plainInh_indent inh + i
                 , plainInh_indenting = plainInh_indenting inh <> d
                 }

        fill m p = Plain $ \inh0 st0 ->
                let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
                let p1 = Plain $ \inh1 st1 ->
                        let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
                        unPlain
                         (if col <= maxCol
                                then spaces (maxCol`minusNatural`col)
                                else mempty)
                         inh1 st1
                in
                unPlain (p <> p1) inh0 st0
        fillOrBreak m p = Plain $ \inh0 st0 ->
                let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
                let p1 = Plain $ \inh1 st1 ->
                        let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
                        unPlain
                         (case col`compare`maxCol of
                                 LT -> spaces (maxCol`minusNatural`col)
                                 EQ -> mempty
                                 GT -> incrIndent (spaces m) m newline
                         ) inh1 st1
                in
                unPlain (p <> p1) inh0 st0
instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
        ul ds =
                catV $
                        (<$> ds) $ \d ->
                                from (Word '-')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}
        ol ds =
                catV $ snd $
                        Fold.foldr
                         (\d (i, acc) ->
                                (pred i, (from i<>from (Word '.')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}) : acc)
                         ) (Fold.length ds, []) ds
instance Spaceable d => Justifiable (Plain d) where
        justify p = (\x -> flushlinePlain <> x <> flushlinePlain) $ Plain $ \inh ->
                unPlain p inh{plainInh_justify=True}

-- | Commit 'plainState_buffer' upto there, so that it won't be justified.
flushlinePlain :: Spaceable d => Plain d
flushlinePlain = Plain $ \_inh st k ->
        k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
         , st
                 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
                 , plainState_bufferWidth = 0
                 , plainState_buffer      = mempty
                 }
         )

collapsePlainChunkSpaces :: PlainChunk d -> PlainChunk d
collapsePlainChunkSpaces = \case
 PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
 x -> x

instance Spaceable d => Wrappable (Plain d) where
        setWidth w p = Plain $ \inh ->
                unPlain p inh{plainInh_width=w}
        breakpoint = Plain $ \inh st k fits overflow ->
                k(id, st {plainState_breakIndent = plainInh_indent inh})
                 fits
                 {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
        breakspace = Plain $ \inh st k fits overflow ->
                k( if plainInh_justify inh then id else (space <>)
                 , st
                         { plainState_buffer =
                                if plainInh_justify inh
                                then case plainState_buffer st of
                                         PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
                                         bs -> PlainChunk_Spaces 1:bs
                                else plainState_buffer st
                         , plainState_bufferWidth = plainState_bufferWidth st + 1
                         , plainState_breakIndent = plainInh_indent inh
                         }
                 )
                 fits
                 {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
        breakalt x y = Plain $ \inh st k fits overflow ->
                -- NOTE: breakalt must be y if and only if x does not fit,
                -- hence the use of dummyK to limit the test
                -- to overflows raised within x, and drop those raised after x.
                unPlain x inh st dummyK
                 {-fits-}    (\_r -> unPlain x inh st k fits overflow)
                 {-overflow-}(\_r -> unPlain y inh st k fits overflow)
                where
                dummyK (px,_sx) fits _overflow =
                        -- NOTE: if px fits, then appending mempty fits
                        fits (px mempty)
        endline = Plain $ \inh st k fits _overflow ->
                let col = plainState_bufferStart st + plainState_bufferWidth st in
                case plainInh_width inh >>= (`minusNaturalMaybe` col) of
                 Nothing -> k (id, st) fits fits
                 Just w ->
                        let newState = st
                                 { plainState_bufferWidth = plainState_bufferWidth st + w
                                 } in
                        k (id,newState) fits fits

-- | Like 'newline', but justify 'plainState_buffer' before.
newlineJustifyingPlain :: Spaceable d => Plain d
newlineJustifyingPlain = Plain $ \inh st ->
        unPlain
         (  newlinePlain
         <> indentPlain
         <> propagatePlain (plainState_breakIndent st)
         <> flushlinePlain
         ) inh st
        where
        indentPlain = Plain $ \inh ->
                unPlain
                 (plainInh_indenting inh)
                 inh{plainInh_justify=False}
        newlinePlain = Plain $ \inh st k ->
                k (\next ->
                        (if plainInh_justify inh
                                then justifyLinePlain inh st
                                else mempty
                        )<>newline<>next
                 , st
                 { plainState_bufferStart = 0
                 , plainState_bufferWidth = 0
                 , plainState_buffer      = mempty
                 })
        propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
                k (id,st1)
                 fits
                 {-overflow-}(
                        -- NOTE: the text after this newline overflows,
                        -- so propagate the overflow before this 'newline',
                        -- if and only if there is a 'breakspace' before this 'newline'
                        -- whose replacement by a 'newline' indents to a lower indent
                        -- than this 'newline''s indent.
                        -- Otherwise there is no point in propagating the overflow.
                        if breakIndent < plainInh_indent inh
                        then overflow
                        else fits
                 )

-- String
instance (From (Word String) d, Spaceable d) =>
         From String (Plain d) where
        from =
                mconcat .
                List.intersperse newline .
                (from <$>) .
                lines
instance (From (Word String) d, Spaceable d) =>
         IsString (Plain d) where
        fromString = from
-- Text
instance (From (Word Text) d, Spaceable d) =>
         From Text (Plain d) where
        from =
                mconcat .
                List.intersperse newline .
                (from <$>) .
                lines
instance (From (Word TL.Text) d, Spaceable d) =>
         From TL.Text (Plain d) where
        from =
                mconcat .
                List.intersperse newline .
                (from <$>) .
                lines
-- Char
instance (From (Word Char) d, Spaceable d) =>
         From Char (Plain d) where
        from ' '  = breakspace
        from '\n' = newline
        from c    = from (Word c)

instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
        from sgr = Plain $ \inh st k ->
                if plainInh_justify inh
                then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
                else k ((from sgr <>), st)

-- * Justifying
justifyLinePlain ::
 Spaceable d =>
 PlainInh d -> PlainState d -> d
justifyLinePlain inh PlainState{..} =
        case plainInh_width inh of
         Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
         Just maxWidth ->
                if maxWidth < plainState_bufferStart
                || maxWidth < plainInh_indent inh
                then joinLinePlainChunk $ List.reverse plainState_buffer
                else
                        let superfluousSpaces = Fold.foldr
                                 (\c acc ->
                                        acc + case c of
                                         PlainChunk_Ignored{} -> 0
                                         PlainChunk_Word{} -> 0
                                         PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
                                 0 plainState_buffer in
                        let minBufferWidth =
                                -- NOTE: cap the spaces at 1,
                                -- to let justifyWidth decide where to add spaces.
                                plainState_bufferWidth`minusNatural`superfluousSpaces in
                        let justifyWidth =
                                -- NOTE: when minBufferWidth is not breakable,
                                -- the width of justification can be wider than
                                -- what remains to reach maxWidth.
                                max minBufferWidth $
                                        maxWidth`minusNatural`plainState_bufferStart
                        in
                        let wordCount = countWordsPlain plainState_buffer in
                        unLine $ padLinePlainChunkInits justifyWidth $
                         (minBufferWidth,wordCount,List.reverse plainState_buffer)

-- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
-- clearly separated by spaces.
countWordsPlain :: [PlainChunk d] -> Natural
countWordsPlain = go False 0
 where
        go inWord acc = \case
         [] -> acc
         PlainChunk_Word{}:xs ->
                if inWord
                then go inWord acc xs
                else go True (acc+1) xs
         PlainChunk_Spaces s:xs
          | s == 0    -> go inWord acc xs
          | otherwise -> go False acc xs
         PlainChunk_Ignored{}:xs -> go inWord acc xs

-- | @('justifyPadding' a b)@ returns the padding lengths
-- to reach @(a)@ in @(b)@ pads,
-- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
-- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
--
-- A simple implementation of 'justifyPadding' could be:
-- @
-- 'justifyPadding' a b =
--   'join' ('List.replicate' m [q,q'+'1])
--   <> ('List.replicate' (r'-'m) (q'+'1)
--   <> ('List.replicate' ((b'-'r)'-'m) q
--   where
--   (q,r) = a`divMod`b
--   m = 'min' (b-r) r
-- @
justifyPadding :: Natural -> Natural -> [Natural]
justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
        where
        (q,r) = a`quotRemNatural`b

        go 0  bmr = List.replicate (fromIntegral bmr) q    -- when min (b-r) r == b-r
        go rr 0   = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
        go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)

padLinePlainChunkInits ::
 Spaceable d =>
 Width -> (Natural, Natural, [PlainChunk d]) -> Line d
padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
        if maxWidth <= lineWidth
                -- The gathered line reached or overreached the maxWidth,
                -- hence no padding id needed.
        || wordCount <= 1
                -- The case maxWidth <= lineWidth && wordCount == 1
                -- can happen if first word's length is < maxWidth
                -- but second word's len is >= maxWidth.
        then joinLinePlainChunk line
        else
                -- Share the missing spaces as evenly as possible
                -- between the words of the line.
                padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)

-- | Just concat 'PlainChunk's with no justification.
joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d
joinLinePlainChunk = mconcat . (runPlainChunk <$>)

-- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d
padLinePlainChunk = go
        where
        go (w:ws) lls@(l:ls) =
                case w of
                 PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
                 _ -> runPlainChunk w <> go ws lls
        go (w:ws) [] = runPlainChunk w <> go ws []
        go [] _ls = mempty

-- * Escaping
instance (Semigroup d, From [SGR] d) => Colorable16 (Plain d) where
        reverse     = plainSGR $ SetSwapForegroundBackground True
        black       = plainSGR $ SetColor Foreground Dull  Black
        red         = plainSGR $ SetColor Foreground Dull  Red
        green       = plainSGR $ SetColor Foreground Dull  Green
        yellow      = plainSGR $ SetColor Foreground Dull  Yellow
        blue        = plainSGR $ SetColor Foreground Dull  Blue
        magenta     = plainSGR $ SetColor Foreground Dull  Magenta
        cyan        = plainSGR $ SetColor Foreground Dull  Cyan
        white       = plainSGR $ SetColor Foreground Dull  White
        blacker     = plainSGR $ SetColor Foreground Vivid Black
        redder      = plainSGR $ SetColor Foreground Vivid Red
        greener     = plainSGR $ SetColor Foreground Vivid Green
        yellower    = plainSGR $ SetColor Foreground Vivid Yellow
        bluer       = plainSGR $ SetColor Foreground Vivid Blue
        magentaer   = plainSGR $ SetColor Foreground Vivid Magenta
        cyaner      = plainSGR $ SetColor Foreground Vivid Cyan
        whiter      = plainSGR $ SetColor Foreground Vivid White
        onBlack     = plainSGR $ SetColor Background Dull  Black
        onRed       = plainSGR $ SetColor Background Dull  Red
        onGreen     = plainSGR $ SetColor Background Dull  Green
        onYellow    = plainSGR $ SetColor Background Dull  Yellow
        onBlue      = plainSGR $ SetColor Background Dull  Blue
        onMagenta   = plainSGR $ SetColor Background Dull  Magenta
        onCyan      = plainSGR $ SetColor Background Dull  Cyan
        onWhite     = plainSGR $ SetColor Background Dull  White
        onBlacker   = plainSGR $ SetColor Background Vivid Black
        onRedder    = plainSGR $ SetColor Background Vivid Red
        onGreener   = plainSGR $ SetColor Background Vivid Green
        onYellower  = plainSGR $ SetColor Background Vivid Yellow
        onBluer     = plainSGR $ SetColor Background Vivid Blue
        onMagentaer = plainSGR $ SetColor Background Vivid Magenta
        onCyaner    = plainSGR $ SetColor Background Vivid Cyan
        onWhiter    = plainSGR $ SetColor Background Vivid White
instance (Semigroup d, From [SGR] d) => Decorable (Plain d) where
        bold      = plainSGR $ SetConsoleIntensity BoldIntensity
        underline = plainSGR $ SetUnderlining SingleUnderline
        italic    = plainSGR $ SetItalicized True

plainSGR ::
 Semigroup d =>
 From [SGR] d =>
 SGR -> Plain d -> Plain d
plainSGR newSGR p = before <> middle <> after
        where
        before = Plain $ \inh st k ->
                let d = from [newSGR] in
                if plainInh_justify inh
                then k (id, st
                 { plainState_buffer =
                        PlainChunk_Ignored d :
                        plainState_buffer st
                 })
                else k ((d <>), st)
        middle = Plain $ \inh ->
                unPlain p inh{plainInh_sgr=newSGR:plainInh_sgr inh}
        after = Plain $ \inh st k ->
                let d = from $ Reset : List.reverse (plainInh_sgr inh) in
                if plainInh_justify inh
                then k (id, st
                 { plainState_buffer =
                        PlainChunk_Ignored d :
                        plainState_buffer st
                 })
                else k ((d <>), st)