{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Formatter.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.Int (Int)
import Data.Kind (Type)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..), String)
import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural)
import Numeric.Natural (Natural)
import Prelude (fromIntegral, Num(..), pred, error)
import System.Console.ANSI hiding (SGR)
import Text.Show (Show(..), showString, showParen)
import qualified Data.Foldable as Fold
import qualified Data.List as List
import qualified Data.Tuple as Tuple
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
--import qualified Data.Text.Lazy.Builder as TLB

import Symantic.Class
  ( Repeatable(..)
  )
import Symantic.Formatter.Class
import Symantic.Formatter.Output

-- * 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 (o::Type) a = Plain
  { unPlain :: a ->
     {-curr-}PlainInh o ->
     {-curr-}PlainState o ->
     {-ok-}( ({-prepend-}(o->o), {-new-}PlainState o) -> PlainFit o) ->
     PlainFit o
     -- NOTE: equivalent to:
     -- ReaderT PlainInh (StateT (PlainState o) (Cont (PlainFit o))) (o->o)
  }

instance Semigroup o => ProductFunctor (Plain o) where
  x <.> y = Plain $ \(a,b) inh st k ->
    unPlain x a inh st $ \(px,sx) ->
      unPlain y b inh sx $ \(py,sy) ->
        k (px.py, sy)
  x .> y = Plain $ \b inh st k ->
    unPlain x () inh st $ \(px,sx) ->
      unPlain y b inh sx $ \(py,sy) ->
        k (px.py, sy)
  x <. y = Plain $ \a inh st k ->
    unPlain x a inh st $ \(px,sx) ->
      unPlain y () inh sx $ \(py,sy) ->
        k (px.py, sy)
instance Emptyable (Plain o) where
  empty = Plain $ \_a _inh st k -> k (id,st)
instance Outputable o => Repeatable (Plain o) where
  many0 item = Plain $ \as ->
    unPlain (concat ((`void` item) <$> as)) ()
  many1 item = Plain $ \case
    [] -> error "many1"
    as -> unPlain (concat ((`void` item) <$> as)) ()

-- String
instance (Convertible String o, Outputable o) => IsString (Plain o ()) where
  fromString = convert
instance (Convertible String o, Outputable o) => Convertible String (Plain o ()) where
  convert =
    concat .
    List.intersperse newline .
    (
      concat .
      List.intersperse breakspace .
      (wordPlain <$>) .
      words <$>
    ) . lines
instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Plain o ()) where
  convert =
    concat .
    List.intersperse newline .
    (
      concat .
      List.intersperse breakspace .
      (wordPlain <$>) .
      words <$>
    ) . lines
instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Plain o ()) where
  convert =
    concat .
    List.intersperse newline .
    (
      concat .
      List.intersperse breakspace .
      (wordPlain <$>) .
      words <$>
    ) . lines
--intersperse sep = concat . List.intersperse sep
instance (Convertible String o, Outputable o) => Inferable Int (Plain o) where
  infer = showWordPlain
instance (Convertible String o, Outputable o) => Inferable Natural (Plain o) where
  infer = showWordPlain
instance (Convertible String o, Outputable o) => Inferable (Word String) (Plain o) where
  infer = Plain $ ($ ()) . unPlain . wordPlain
instance (Convertible String o, Outputable o) => Inferable String (Plain o) where
  infer = Plain $ ($ ()) . unPlain . fromString
instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Plain o) where
  infer = Plain $ ($ ()) . unPlain . convert
instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Plain o) where
  infer = Plain $ ($ ()) . unPlain . convert
instance Outputable o => Inferable Char (Plain o) where
  infer = Plain $ \case
    '\n' -> unPlain newline ()
    ' ' -> unPlain breakspace ()
    c -> unPlain (wordPlain (Word c)) ()
instance Outputable o => Inferable (Word Char) (Plain o) where
  infer = Plain $ \c -> unPlain (wordPlain c) ()
showWordPlain ::
  Show a =>
  Convertible String o =>
  Outputable o =>
  Inferable a (Plain o) => Plain o a
showWordPlain = Plain $
  ($ ()) . unPlain . wordPlain .
  Word . show

runPlain :: Monoid o => Plain o a -> a -> o
runPlain x a =
  unPlain x a
   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 o = PlainState
  { plainState_buffer :: ![PlainChunk o]
  , 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 o
defPlainState = PlainState
  { plainState_buffer = mempty
  , plainState_bufferStart = 0
  , plainState_bufferWidth = 0
  , plainState_breakIndent = 0
  }

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

defPlainInh :: Monoid o => PlainInh o
defPlainInh = PlainInh
  { plainInh_width = Nothing
  , plainInh_justify = False
  , plainInh_indent = 0
  , plainInh_indenting = empty
  , plainInh_sgr = []
  }

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

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

runPlainChunk :: Outputable o => PlainChunk o -> o
runPlainChunk = \case
  PlainChunk_Ignored o -> o
  PlainChunk_Word (Word o) -> o
  PlainChunk_Spaces s -> repeatedChar s ' '

instance Voidable (Plain o) where
  void a p = Plain $ \() -> unPlain p a
instance (Convertible Char o, Outputable o) => Spaceable (Plain o) where
  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{-(o<>)-}, newState) fits overflow
        _ -> k (id{-(o<>)-}, newState) fits overflow
    else
      let newState = st
           { plainState_bufferWidth = plainState_bufferWidth + n
           } in
      case plainInh_width inh of
        Just maxWidth | maxWidth < newWidth ->
          overflow $ k ((repeatedChar n ' ' <>), newState) fits fits
        _ -> k ((repeatedChar n ' ' <>), newState) fits overflow
instance (Outputable o) => Newlineable (Plain o) 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
        )<>nl<>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
       )

-- | Commit 'plainState_buffer' upto there, so that it won'o be justified.
flushlinePlain :: Outputable o => Plain o ()
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
     }
   )

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

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

wordPlain ::
  Lengthable i => Convertible i o => Outputable o =>
  Word i -> Plain o ()
wordPlain inp = Plain $ \() inh st@PlainState{..} k fits overflow ->
  let wordWidth = length inp in
  let out = convert inp 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 out : 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 ((unWord out <>), newState) fits fits
        _ -> k ((unWord out <>), newState) fits overflow

instance (Convertible Char o, Outputable o) => Indentable (Plain o) where
  align p = (flushlinePlain .>) $ Plain $ \a inh st ->
    let col = plainState_bufferStart st + plainState_bufferWidth st in
    unPlain p a 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 o i p = Plain $ \a inh ->
    unPlain p a inh
     { plainInh_indent    = i
     , plainInh_indenting = o
     }
  incrIndent o i p = Plain $ \a inh ->
    unPlain p a inh
     { plainInh_indent    = plainInh_indent inh + i
     , plainInh_indenting = plainInh_indenting inh .> o
     }
  fill m p = Plain $ \a 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 empty)
           () inh1 st1
    in
    unPlain (p <. p1) a inh0 st0
  fillOrBreak m p = Plain $ \a 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 -> empty
             GT -> incrIndent (spaces m) m newline
           ) () inh1 st1
    in
    unPlain (p <. p1) a inh0 st0
instance (Convertible Char o, Convertible String o, Outputable o) => Listable (Plain o) where
  ul is =
    catV $
      (<$> is) $ \i ->
        wordPlain (Word '-').>space.>flushlinePlain
        .> align i
        -- .> flushlinePlain
  ol is =
    catV $ Tuple.snd $
      Fold.foldr
       (\o (n, acc) ->
         ( pred n
         , ( wordPlain (Word (show n))
           .> wordPlain (Word '.') .> space
           .> flushlinePlain
           .> align o
           -- .> flushlinePlain
           ) : acc
         )
       ) (Fold.length is, []) is
  unorderedList li = intercalate_ newline $
    wordPlain (Word '-') .> space .> flushlinePlain .> align li
  orderedList li = Plain $ \as ->
    unPlain (intercalate_ newline item)
     (List.zip [1..] as)
    where
    item = Plain $ \(i::Natural, a) ->
      ($ a) $ unPlain $
      void i natural
      .> wordPlain (Word '.') .> space
      .> flushlinePlain
      .> align li
  intercalate_ sep li = Plain $ \as ->
    unPlain (concat (List.intersperse sep ((`void` li) <$> as))) ()
  list_ opn sep cls li =
    breakalt
     (opn .> intercalate_ (sep .> space) li <. cls)
     (align $ opn .> space
       .> intercalate_ (newline .> sep .> space) li
       <. newline <. cls)
instance Outputable o => Justifiable (Plain o) where
  justify p = (\x -> flushlinePlain .> x <. flushlinePlain) $ Plain $ \a inh ->
    unPlain p a inh{plainInh_justify=True}
instance Outputable o => Wrappable (Plain o) where
  setWidth w p = Plain $ \a inh ->
    unPlain p a 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 (char ' ' <>)
     , 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 $ \a 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 a inh st dummyK
     {-fits-}    (\_r -> unPlain x a inh st k fits overflow)
     {-overflow-}(\_r -> unPlain y a 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 :: Outputable o => Plain o ()
newlineJustifyingPlain = Plain $ \() inh st ->
  unPlain
   (  newlinePlain
   .> indentPlain
   .> propagatePlain (plainState_breakIndent st)
   <. flushlinePlain
   ) () inh st
  where
  indentPlain = Plain $ \a inh ->
    unPlain
     (plainInh_indenting inh) a
     inh{plainInh_justify=False}
  newlinePlain = Plain $ \() inh st k ->
    k (\next ->
      (if plainInh_justify inh
        then justifyLinePlain inh st
        else mempty
      )<>nl<>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
     )

-- * Justifying
justifyLinePlain ::
  Outputable o =>
  PlainInh o -> PlainState o -> o
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 length 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 o] -> 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 ::
 Outputable o =>
 Width -> (Natural, Natural, [PlainChunk o]) -> Line o
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)

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


sgrPlain :: Outputable o => [SGR] -> Plain o ()
sgrPlain sgr = Plain $ \() inh st k ->
  if plainInh_justify inh
  then k (id, st {plainState_buffer =
    PlainChunk_Ignored (fromString (setSGRCode sgr)) :
    plainState_buffer st
  })
  else k ((fromString (setSGRCode sgr) <>), st)

instance Outputable o => Colorable16 (Plain o) 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 Outputable o => Decorable (Plain o) where
  bold      = plainSGR $ SetConsoleIntensity BoldIntensity
  underline = plainSGR $ SetUnderlining SingleUnderline
  italic    = plainSGR $ SetItalicized True

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