{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Plaintext.Writer 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.Plaintext.Classes hiding (char)
import Symantic.Plaintext.Output

-- * Type 'Writer'
-- | Church encoded for performance concerns.
-- Kind like 'ParsecT' in @megaparsec@ but a little bit different
-- due to the use of 'WriterFit' for implementing 'breakingSpace' correctly
-- when in the left hand side of ('<.>').
-- Prepending is done using continuation, like in a difference list.
newtype Writer (o::Type) a = Writer
  { unWriter :: a ->
     {-curr-}WriterInh o ->
     {-curr-}WriterState o ->
     {-ok-}( ({-prepend-}(o->o), {-new-}WriterState o) -> WriterFit o) ->
     WriterFit o
     -- NOTE: equivalent to:
     -- ReaderT WriterInh (StateT (WriterState o) (Cont (WriterFit o))) (o->o)
  }

runWriter :: Monoid o => Writer o a -> a -> o
runWriter x a =
  unWriter x a
   defWriterInh
   defWriterState
   {-k-}(\(px,_sx) fits _overflow ->
    -- NOTE: if px fits, then appending mempty fits
    fits (px mempty) )
   {-fits-}id
   {-overflow-}id

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

-- String
instance (Convertible String o, Outputable o) => IsString (Writer o ()) where
  fromString = convert
instance (Convertible String o, Outputable o) => Convertible String (Writer o ()) where
  convert =
    concat .
    List.intersperse newline .
    (
      concat .
      List.intersperse breakspace .
      (wordWriter <$>) .
      words <$>
    ) . lines
instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Writer o ()) where
  convert =
    concat .
    List.intersperse newline .
    (
      concat .
      List.intersperse breakspace .
      (wordWriter <$>) .
      words <$>
    ) . lines
instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Writer o ()) where
  convert =
    concat .
    List.intersperse newline .
    (
      concat .
      List.intersperse breakspace .
      (wordWriter <$>) .
      words <$>
    ) . lines

instance (Convertible String o, Outputable o) => Inferable Int (Writer o) where
  infer = showWordWriter
instance (Convertible String o, Outputable o) => Inferable Natural (Writer o) where
  infer = showWordWriter
instance (Convertible String o, Outputable o) => Inferable (Word String) (Writer o) where
  infer = Writer $ ($ ()) . unWriter . wordWriter
instance (Convertible String o, Outputable o) => Inferable String (Writer o) where
  infer = Writer $ ($ ()) . unWriter . fromString
instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Writer o) where
  infer = Writer $ ($ ()) . unWriter . convert
instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Writer o) where
  infer = Writer $ ($ ()) . unWriter . convert
instance Outputable o => Inferable Char (Writer o) where
  infer = Writer $ \case
    '\n' -> unWriter newline ()
    ' ' -> unWriter breakspace ()
    c -> unWriter (wordWriter (Word c)) ()
instance Outputable o => Inferable (Word Char) (Writer o) where
  infer = Writer $ \c -> unWriter (wordWriter c) ()
showWordWriter ::
  Show a =>
  Convertible String o =>
  Outputable o =>
  Inferable a (Writer o) => Writer o a
showWordWriter = Writer $
  ($ ()) . unWriter . wordWriter .
  Word . show

-- ** Type 'WriterState'
data WriterState o = WriterState
  { plainState_buffer :: ![WriterChunk 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 'newlineJustifyingWriter'.
  } deriving (Show)

defWriterState :: WriterState o
defWriterState = WriterState
  { plainState_buffer = mempty
  , plainState_bufferStart = 0
  , plainState_bufferWidth = 0
  , plainState_breakIndent = 0
  }

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

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

-- ** Type 'WriterFit'
-- | 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 WriterFit o =
  {-fits-}(o -> o) ->
  {-overflow-}(o -> o) ->
  o

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

runWriterChunk :: Outputable o => WriterChunk o -> o
runWriterChunk = \case
  WriterChunk_Ignored o -> o
  WriterChunk_Word (Word o) -> o
  WriterChunk_Spaces s -> repeatedChar s ' '

instance Voidable (Writer o) where
  void a p = Writer $ \() -> unWriter p a
instance (Convertible Char o, Outputable o) => Spaceable (Writer o) where
  space = spaces 1
  spaces n = Writer $ \() inh st@WriterState{..} 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
                 WriterChunk_Spaces s:buf -> WriterChunk_Spaces (s+n):buf
                 buf -> WriterChunk_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 (Writer o) where
  -- | The default 'newline' does not justify 'plainState_buffer',
  -- for that use 'newlineJustifyingWriter'.
  newline = Writer $ \() inh st ->
    unWriter
     (  newlineWriter
     <. indentWriter
     <. propagateWriter (plainState_breakIndent st)
     <. flushlineWriter
     ) () inh st
    where
    indentWriter = Writer $ \() inh ->
      unWriter
       (plainInh_indenting inh)
       () inh{plainInh_justify=False}
    newlineWriter = Writer $ \() inh st k ->
      k (\next ->
        (if plainInh_justify inh
          then joinLineWriterChunk $ List.reverse $ plainState_buffer st
          else mempty
        )<>nl<>next
       , st
       { plainState_bufferStart = 0
       , plainState_bufferWidth = 0
       , plainState_buffer      = mempty
       })
    propagateWriter breakIndent = Writer $ \() 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.
flushlineWriter :: Outputable o => Writer o ()
flushlineWriter = Writer $ \() _inh st k ->
  k( (joinLineWriterChunk (collapseWriterChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
   , st
     { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
     , plainState_bufferWidth = 0
     , plainState_buffer      = mempty
     }
   )

-- | Just concat 'WriterChunk's with no justification.
joinLineWriterChunk :: Outputable o => [WriterChunk o] -> o
joinLineWriterChunk = mconcat . (runWriterChunk <$>)

collapseWriterChunkSpaces :: WriterChunk o -> WriterChunk o
collapseWriterChunkSpaces = \case
  WriterChunk_Spaces s -> WriterChunk_Spaces (if s > 0 then 1 else 0)
  x -> x

wordWriter ::
  Lengthable i => Convertible i o => Outputable o =>
  Word i -> Writer o ()
wordWriter inp = Writer $ \() inh st@WriterState{..} 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 = WriterChunk_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 (Writer o) where
  align p = (flushlineWriter .>) $ Writer $ \a inh st ->
    let col = plainState_bufferStart st + plainState_bufferWidth st in
    unWriter 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 = Writer $ \a inh ->
    unWriter p a inh
     { plainInh_indent    = i
     , plainInh_indenting = o
     }
  incrIndent o i p = Writer $ \a inh ->
    unWriter p a inh
     { plainInh_indent    = plainInh_indent inh + i
     , plainInh_indenting = plainInh_indenting inh .> o
     }
  fill m p = Writer $ \a inh0 st0 ->
    let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
    let p1 = Writer $ \() inh1 st1 ->
          let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
          unWriter
           (if col <= maxCol
            then spaces (maxCol`minusNatural`col)
            else empty)
           () inh1 st1
    in
    unWriter (p <. p1) a inh0 st0
  fillOrBreak m p = Writer $ \a inh0 st0 ->
    let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
    let p1 = Writer $ \() inh1 st1 ->
          let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
          unWriter
           (case col`compare`maxCol of
             LT -> spaces (maxCol`minusNatural`col)
             EQ -> empty
             GT -> incrIndent (spaces m) m newline
           ) () inh1 st1
    in
    unWriter (p <. p1) a inh0 st0
instance (Convertible Char o, Convertible String o, Outputable o) => Listable (Writer o) where
  ul is =
    catV $
      (<$> is) $ \i ->
        wordWriter (Word '-').>space.>flushlineWriter
        .> align i
        -- .> flushlineWriter
  ol is =
    catV $ Tuple.snd $
      Fold.foldr
       (\o (n, acc) ->
         ( pred n
         , ( wordWriter (Word (show n))
           .> wordWriter (Word '.') .> space
           .> flushlineWriter
           .> align o
           -- .> flushlineWriter
           ) : acc
         )
       ) (Fold.length is, []) is
  unorderedList li = intercalate_ newline $
    wordWriter (Word '-') .> space .> flushlineWriter .> align li
  orderedList li = Writer $ \as ->
    unWriter (intercalate_ newline item)
     (List.zip [1..] as)
    where
    item = Writer $ \(i::Natural, a) ->
      ($ a) $ unWriter $
      void i natural
      .> wordWriter (Word '.') .> space
      .> flushlineWriter
      .> align li
  intercalate_ sep li = Writer $ \as ->
    unWriter (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 (Writer o) where
  justify p = (\x -> flushlineWriter .> x <. flushlineWriter) $ Writer $ \a inh ->
    unWriter p a inh{plainInh_justify=True}
instance Outputable o => Wrappable (Writer o) where
  setWidth w p = Writer $ \a inh ->
    unWriter p a inh{plainInh_width=w}
  breakpoint = Writer $ \() inh st k fits overflow ->
    k(id, st{plainState_breakIndent = plainInh_indent inh})
     fits
     {-overflow-}(\_r -> unWriter newlineJustifyingWriter () inh st k fits overflow)
  breakspace = Writer $ \() 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
           WriterChunk_Spaces s:bs -> WriterChunk_Spaces (s+1):bs
           bs -> WriterChunk_Spaces 1:bs
        else plainState_buffer st
       , plainState_bufferWidth = plainState_bufferWidth st + 1
       , plainState_breakIndent = plainInh_indent inh
       }
     )
     fits
     {-overflow-}(\_r -> unWriter newlineJustifyingWriter () inh st k fits overflow)
  breakalt x y = Writer $ \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.
    unWriter x a inh st dummyK
     {-fits-}    (\_r -> unWriter x a inh st k fits overflow)
     {-overflow-}(\_r -> unWriter 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 = Writer $ \() 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.
newlineJustifyingWriter :: Outputable o => Writer o ()
newlineJustifyingWriter = Writer $ \() inh st ->
  unWriter
   (  newlineWriter
   .> indentWriter
   .> propagateWriter (plainState_breakIndent st)
   <. flushlineWriter
   ) () inh st
  where
  indentWriter = Writer $ \a inh ->
    unWriter
     (plainInh_indenting inh) a
     inh{plainInh_justify=False}
  newlineWriter = Writer $ \() inh st k ->
    k (\next ->
      (if plainInh_justify inh
        then justifyLineWriter inh st
        else mempty
      )<>nl<>next
     , st
     { plainState_bufferStart = 0
     , plainState_bufferWidth = 0
     , plainState_buffer      = mempty
     })
  propagateWriter breakIndent = Writer $ \() 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
justifyLineWriter ::
  Outputable o =>
  WriterInh o -> WriterState o -> o
justifyLineWriter inh WriterState{..} =
  case plainInh_width inh of
    Nothing -> joinLineWriterChunk $ List.reverse plainState_buffer
    Just maxWidth ->
      if maxWidth < plainState_bufferStart
      || maxWidth < plainInh_indent inh
      then joinLineWriterChunk $ List.reverse plainState_buffer
      else
        let superfluousSpaces = Fold.foldr
             (\c acc ->
              acc + case c of
               WriterChunk_Ignored{} -> 0
               WriterChunk_Word{} -> 0
               WriterChunk_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 = countWordsWriter plainState_buffer in
        unLine $ padLineWriterChunkInits justifyWidth $
         (minBufferWidth,wordCount,List.reverse plainState_buffer)

-- | @('countWordsWriter' ps)@ returns the number of words in @(ps)@
-- clearly separated by spaces.
countWordsWriter :: [WriterChunk o] -> Natural
countWordsWriter = go False 0
 where
  go inWord acc = \case
    [] -> acc
    WriterChunk_Word{}:xs ->
      if inWord
      then go inWord acc xs
      else go True (acc+1) xs
    WriterChunk_Spaces s:xs
      | s == 0 -> go inWord acc xs
      | otherwise -> go False acc xs
    WriterChunk_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)

padLineWriterChunkInits ::
 Outputable o =>
 Width -> (Natural, Natural, [WriterChunk o]) -> Line o
padLineWriterChunkInits 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 joinLineWriterChunk line
  else
    -- Share the missing spaces as evenly as possible
    -- between the words of the line.
    padLineWriterChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)

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


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

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

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