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.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.ObserveSharing

-- * Type 'DumpGrammar'
newtype DumpGrammar a = DumpGrammar { unDumpGrammar :: Tree.Tree String }

dumpGrammar :: DumpGrammar a -> DumpGrammar a
dumpGrammar = id

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

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