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