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}|]