Dump.hs

module Symantic.Parser.Grammar.Dump where

import Data.Function (($), (.), id)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Text.Show (Show(..))
import qualified Control.Applicative as Fct
import qualified Data.Tree as Tree
import qualified Data.List as List

import Symantic.Univariant.Letable
import Symantic.Parser.Grammar.Combinators

-- * Type 'DumpComb'
newtype DumpComb a = DumpComb { unDumpComb :: Tree.Tree String }

dumpComb :: DumpComb a -> DumpComb a
dumpComb = id

instance Show (DumpComb a) where
  show = drawTree . unDumpComb
    where
    drawTree :: Tree.Tree String -> String
    drawTree  = List.unlines . draw
    draw :: Tree.Tree String -> [String]
    draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
      where
      drawSubTrees [] = []
      drawSubTrees [t] = shift "` " "  " (draw t)
      drawSubTrees (t:ts) = shift "+ " "| " (draw t) <> drawSubTrees ts
      shift first other = List.zipWith (<>) (first : List.repeat other)
instance IsString (DumpComb a) where
  fromString s = DumpComb $ Tree.Node (fromString s) []

instance Show letName => Letable letName DumpComb where
  def name x = DumpComb $
    Tree.Node ("def "<>show name) [unDumpComb x]
  ref rec name = DumpComb $
    Tree.Node
      ( (if rec then "rec " else "ref ")
      <> show name
      ) []
instance Applicable DumpComb where
  _f <$> x = DumpComb $ Tree.Node "<$>" [unDumpComb x]
  pure a = DumpComb $ Tree.Node ("pure "<>showsPrec 10 a "") []
  x <*> y = DumpComb $ Tree.Node "<*>" [unDumpComb x, unDumpComb y]
instance Alternable DumpComb where
  empty = DumpComb $ Tree.Node "empty" []
  x <|> y = DumpComb $ Tree.Node "<|>" [unDumpComb x, unDumpComb y]
  try x = DumpComb $ Tree.Node "try" [unDumpComb x]
instance Satisfiable DumpComb tok where
  satisfy _es _p = DumpComb $ Tree.Node "satisfy" []
instance Selectable DumpComb where
  branch lr l r = DumpComb $ Tree.Node "branch"
    [ unDumpComb lr, unDumpComb l, unDumpComb r ]
instance Matchable DumpComb where
  conditional _cs bs a b = DumpComb $ Tree.Node "conditional"
    [ Tree.Node "bs" (unDumpComb Fct.<$> bs)
    , unDumpComb a
    , unDumpComb b
    ]
instance Lookable DumpComb where
  look x = DumpComb $ Tree.Node "look" [unDumpComb x]
  negLook x = DumpComb $ Tree.Node "negLook" [unDumpComb x]
  eof = DumpComb $ Tree.Node "eof" []
instance Foldable DumpComb where
  chainPre f x = DumpComb $ Tree.Node "chainPre" [unDumpComb f, unDumpComb x]
  chainPost x f = DumpComb $ Tree.Node "chainPost" [unDumpComb x, unDumpComb f]