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