155 lines
4.3 KiB
Haskell
155 lines
4.3 KiB
Haskell
module Gyehoek.Sexp.Print
|
|
( printDatum
|
|
, printDatumW
|
|
, printDatum'
|
|
, printData
|
|
, printData'
|
|
, htmlDatum
|
|
, htmlData
|
|
) where
|
|
|
|
import Gyehoek.Sexp.Syntax
|
|
import Prettyprinter
|
|
import Data.Functor.Foldable
|
|
import qualified Control.Comonad.Trans.Cofree as F
|
|
import Prettyprinter.Util
|
|
import Gyehoek.Prelude hiding (Simple, (:<))
|
|
import Data.Foldable (traverse_, toList)
|
|
import qualified Prettyprinter.Render.Terminal as ANSI
|
|
import System.IO (stdout)
|
|
import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
|
|
import Prettyprinter.Render.Text (renderStrict)
|
|
import qualified Data.Scientific as Sci
|
|
import Data.List (intersperse)
|
|
import Lucid
|
|
import Prettyprinter.Render.Util.SimpleDocTree (treeForm)
|
|
import Prettyprinter.Lucid (renderHtml)
|
|
|
|
|
|
printDatum' :: Datum -> Text
|
|
printDatum' =
|
|
prettyDatum 0
|
|
>>> layoutSmart opts
|
|
>>> renderStrict
|
|
where
|
|
opts = LayoutOptions
|
|
{ layoutPageWidth = AvailablePerLine 80 1.0
|
|
}
|
|
|
|
htmlDatum :: Datum -> Html ()
|
|
htmlDatum =
|
|
prettyDatum 0
|
|
>>> layoutPretty opts
|
|
>>> treeForm
|
|
>>> fmap highlightHtml
|
|
>>> renderHtml
|
|
where
|
|
opts = LayoutOptions
|
|
{ layoutPageWidth = AvailablePerLine 80 1.0
|
|
}
|
|
|
|
htmlData :: Foldable f => f Datum -> Html ()
|
|
htmlData =
|
|
foldr f mempty
|
|
>>> layoutPretty opts
|
|
>>> treeForm
|
|
>>> fmap highlightHtml
|
|
>>> renderHtml
|
|
where
|
|
f x y = prettyDatum 0 x <> hardline <> hardline <> y
|
|
opts = LayoutOptions
|
|
{ layoutPageWidth = AvailablePerLine 80 1.0
|
|
}
|
|
|
|
printDatum :: Datum -> Text
|
|
printDatum = printDatumW 80
|
|
|
|
printData :: List Datum -> Text
|
|
printData = mconcat . intersperse "\n\n" . fmap printDatum
|
|
|
|
printData' :: List Datum -> Text
|
|
printData' = mconcat . intersperse "\n\n" . fmap printDatum'
|
|
|
|
printDatumW :: Int -> Datum -> Text
|
|
printDatumW w =
|
|
prettyDatum 0
|
|
>>> layoutSmart opts
|
|
>>> reAnnotateS highlightAnsi
|
|
>>> ANSI.renderStrict
|
|
where
|
|
opts = LayoutOptions
|
|
{ layoutPageWidth = AvailablePerLine w 1.0
|
|
}
|
|
|
|
prettyDatum :: Int -> Datum -> Doc Syn
|
|
prettyDatum depth datum = case datum of
|
|
Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
|
|
DotList xs x ->
|
|
pparen depth . group . align $
|
|
vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
|
|
, "."
|
|
, prettyDatum (depth+1) x
|
|
]
|
|
|
|
List' indent xs ->
|
|
case indent of
|
|
NSpecial n | keyword:args <- xs ->
|
|
let (specialArgs,body) = splitAt n args
|
|
in pparen depth . nest 2 . vsep $
|
|
[ group . nest 2 . hcat $
|
|
[ prettyDatum (depth+1) keyword
|
|
, if null specialArgs then mempty else softline
|
|
, hsep $ prettyDatum (depth+1) <$> specialArgs
|
|
]
|
|
, vsep $ prettyDatum (depth+1) <$> body
|
|
]
|
|
Ordinary; NSpecial _ -> pparen depth $
|
|
group . align . vsep $
|
|
prettyDatum (depth+1) <$> xs
|
|
_ -> error [i|unimplemented: #{datum}|]
|
|
|
|
pparen depth = enclose (delim depth "(") (delim depth ")")
|
|
delim depth = annotate (SynParen depth)
|
|
|
|
delimited :: Int -> Doc Syn -> Doc Syn -> List (Doc Syn) -> Doc Syn
|
|
delimited depth open close =
|
|
encloseSep (delim depth open) (delim depth close) softline
|
|
|
|
prettySimple :: Int -> Simple -> Doc Syn
|
|
prettySimple depth = \case
|
|
SimpleBoolean b -> annotate SynConstant $ if b then "#t" else "#f"
|
|
SimpleNumber n ->
|
|
Sci.floatingOrInteger n
|
|
& either viaShow viaShow
|
|
& annotate SynConstant
|
|
SimpleString s -> annotate SynString $ viaShow s
|
|
SimpleSymbol s -> pretty s
|
|
SimpleUnreadable s -> pretty s
|
|
|
|
putDoc :: Doc Syn -> IO ()
|
|
putDoc = ANSI.renderIO stdout
|
|
. reAnnotateS highlightAnsi . layoutSmart defaultLayoutOptions . (<>"\n")
|
|
|
|
highlightAnsi :: Syn -> AnsiStyle
|
|
highlightAnsi = \case
|
|
(SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
|
|
SynProcedure -> color Blue
|
|
SynConstant -> color Yellow
|
|
SynParen n -> colorDull $ rainbow ^?! ix n
|
|
_ -> mempty
|
|
where
|
|
rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]
|
|
|
|
highlightHtml :: Syn -> Html () -> Html ()
|
|
highlightHtml syn = span_ [class_ synClass]
|
|
where
|
|
synClass = case syn of
|
|
SynBuiltin -> "syn-builtin"
|
|
SynMacro -> "syn-macro"
|
|
SynConstant -> "syn-constant"
|
|
SynString -> "syn-string"
|
|
SynProcedure -> "syn-procedure"
|
|
SynVariable -> "syn-variable"
|
|
SynNone -> "syn-none"
|
|
SynParen n -> [i|syn-paren-#{mod n 5}|]
|