module Symantic.Parser.Grammar.Dump where

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

-- * Type 'GramDump'
newtype GramDump a = GramDump { unGramDump :: Tree.Tree String }

gramDump :: GramDump a -> GramDump a
gramDump = id

instance Show (GramDump a) where
  show = drawTree . unGramDump
    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 (GramDump a) where
  fromString s = GramDump $ Tree.Node (fromString s) []

instance Letable GramDump where
  let_ letRec letName = GramDump $
    Tree.Node
      ( "let_ "
      <> (if letRec then "rec " else "")
      <> show letName )
      []
instance Applicable GramDump where
  _f <$> x = GramDump $ Tree.Node "<$>" [unGramDump x]
  pure a = GramDump $ Tree.Node ("pure "<>show a) []
  x <*> y = GramDump $ Tree.Node "<*>" [unGramDump x, unGramDump y]
instance Alternable GramDump where
  empty = GramDump $ Tree.Node "empty" []
  x <|> y = GramDump $ Tree.Node "<|>" [unGramDump x, unGramDump y]
  try x = GramDump $ Tree.Node "try" [unGramDump x]
instance Charable GramDump where
  satisfy _p = GramDump $ Tree.Node "satisfy" []
instance Selectable GramDump where
  branch lr l r = GramDump $ Tree.Node "branch"
    [ unGramDump lr, unGramDump l, unGramDump r ]
instance Matchable GramDump where
  conditional _cs bs a b = GramDump $ Tree.Node "conditional"
    [ Tree.Node "bs" (unGramDump Fct.<$> bs)
    , unGramDump a
    , unGramDump b
    ]
instance Lookable GramDump where
  look x = GramDump $ Tree.Node "look" [unGramDump x]
  negLook x = GramDump $ Tree.Node "negLook" [unGramDump x]
instance Foldable GramDump where
  chainPre f x = GramDump $ Tree.Node "chainPre" [unGramDump f, unGramDump x]
  chainPost x f = GramDump $ Tree.Node "chainPost" [unGramDump x, unGramDump f]