module FP.Pretty.Console where

import FP.Prelude
import FP.Pretty.Color
import FP.Pretty.Pretty

sgrLeader โˆท ๐•Š
sgrLeader = "\ESC["

sgrCloser โˆท ๐•Š
sgrCloser = "m"

sgrReset โˆท ๐•Š
sgrReset = sgrLeader โงบ "0" โงบ sgrCloser

sgrFg โˆท Color โ†’ ๐•Š
sgrFg = (โงบ) "38;5;" โˆ˜ ๐•ค โˆ˜ show โˆ˜ colorCode

sgrBg โˆท Color โ†’ ๐•Š
sgrBg = (โงบ) "48;5;" โˆ˜ ๐•ค โˆ˜ show โˆ˜ colorCode

sgrUl โˆท ๐•Š
sgrUl = "4"

sgrBd โˆท ๐•Š
sgrBd = "1"

data FormatState = FormatState
  { formatFG โˆท Maybe Color
  , formatBG โˆท Maybe Color
  , formatUL โˆท Bool
  , formatBD โˆท Bool
  }

sgrFormat โˆท FormatState โ†’ ๐•Šแต‡
sgrFormat (FormatState fg bg ul bd) = concat
  [ ๐•คแต‡ sgrLeader 
  , concat $ map ๐•คแต‡ $ intersperse ";" $ mconcat
      [ mnullMaybe $ sgrFg ^$ fg
      , mnullMaybe $ sgrBg ^$ bg
      , if ul then [sgrUl] else [] 
      , if bd then [sgrBd] else [] 
      ]
  , ๐•คแต‡ sgrCloser
  ]

updateFormat โˆท Format โ†’ FormatState โ†’ FormatState
updateFormat (FG c) fmt = fmt { formatFG = Just c }
updateFormat (BG c) fmt = fmt { formatBG = Just c }
updateFormat UL fmt = fmt { formatUL = True }
updateFormat BD fmt = fmt { formatBD = True }

formatConsole โˆท [Format] โ†’ ReaderT FormatState (Writer ๐•Šแต‡) () โ†’ ReaderT FormatState (Writer ๐•Šแต‡) ()
formatConsole fmt aM = do
  local (compose $ map updateFormat fmt) $ do
    tell *$ sgrFormat ^$ ask
    aM
  tell $ ๐•คแต‡ sgrReset
  tell *$ sgrFormat ^$ ask

renderConsoleM โˆท PrettyOut โ†’ ReaderT FormatState (Writer ๐•Šแต‡) ()
renderConsoleM (ChunkOut c) = tell $ ๐•คแต‡ $ renderChunk c
renderConsoleM (FormatOut f o) = formatConsole f $ renderConsoleM o
renderConsoleM NullOut = tell $ ๐•คแต‡ ""
renderConsoleM (AppendOut oโ‚ oโ‚‚) = renderConsoleM oโ‚ โ‰ซ renderConsoleM oโ‚‚

renderConsole โˆท PrettyOut โ†’ ๐•Š
renderConsole = ๐•ค โˆ˜ execWriter โˆ˜ runReaderTWith (FormatState Nothing Nothing False False) โˆ˜ renderConsoleM

pprintWith โˆท (Pretty a) โ‡’ (PrettyM () โ†’ PrettyM ()) โ†’ a โ†’ IO ()
pprintWith f = printLn โˆ˜ renderConsole โˆ˜ renderDoc โˆ˜ ppFinal โˆ˜ Doc โˆ˜ f โˆ˜ runDoc โˆ˜ pretty

pprintWidth โˆท (Pretty a) โ‡’ โ„• โ†’ a โ†’ IO ()
pprintWidth = pprintWith โˆ˜ local โˆ˜ update maxColumnWidthL

pprintRibbon โˆท (Pretty a) โ‡’ โ„• โ†’ a โ†’ IO ()
pprintRibbon = pprintWith โˆ˜ local โˆ˜ update maxRibbonWidthL

pprint โˆท (Pretty a) โ‡’ a โ†’ IO ()
pprint = pprintWith id

ptrace โˆท (Pretty a) โ‡’ a โ†’ b โ†’ b
ptrace a b = unsafePerformIO $ do
  pprint a
  return b

ptraceM โˆท (Monad m,Pretty a) โ‡’ a โ†’ m ()
ptraceM x = ptrace x $ return ()

ioError โˆท (Pretty e) โ‡’ e โจ„ a โ†’ IO a
ioError = elimSum (\ e โ†’ pprint e โ‰ซ abortIO) return