{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Symantic.Plaintext.Writer where

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

--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.
 Kinda 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]
  , -- | The 'Column' from which the 'plainState_buffer'
    -- must be written.
    plainState_bufferStart :: !Column
  , -- | The 'Width' of the 'plainState_buffer' so far.
    plainState_bufferWidth :: !Width
  , -- | The amount of 'Indent' added by 'breakspace'
    -- that can be reached by breaking the 'space'
    -- into a 'newlineJustifyingWriter'.
    plainState_breakIndent :: !Indent
  }
  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
  = -- | Ignored by the justification but kept in place.
    -- Used for instance to put ANSI sequences.
    WriterChunk_Ignored !o
  | WriterChunk_Word !(Word o)
  | -- | 'spaces' preserved to be interleaved
    -- correctly with 'WriterChunk_Ignored'.
    WriterChunk_Spaces !Width
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
  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 st k fits overflow ->
        k
          (id, st)
          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't 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
      then -- The case maxWidth <= lineWidth && wordCount == 1
      -- can happen if first word's length is < maxWidth
      -- but second word's len is >= maxWidth.
        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)