src/Symantic/Parser/Grammar/Dump.hs

   1 module Symantic.Parser.Grammar.Dump where
   2
   3 import Data.Function (($), (.), id)
   4 import Data.Semigroup (Semigroup(..))
   5 import Data.String (String, IsString(..))
   6 import Symantic.Parser.Grammar.Combinators
   7 import Symantic.Parser.Grammar.Observations
   8 import Text.Show (Show(..))
   9 import qualified Control.Applicative as Fct
  10 import qualified Data.Tree as Tree
  11 import qualified Data.List as List
  12
  13 -- * Type 'GramDump'
  14 newtype GramDump a = GramDump { unGramDump :: Tree.Tree String }
  15
  16 gramDump :: GramDump a -> GramDump a
  17 gramDump = id
  18
  19 instance Show (GramDump a) where
  20   show = drawTree . unGramDump
  21     where
  22     drawTree :: Tree.Tree String -> String
  23     drawTree  = List.unlines . draw
  24     draw :: Tree.Tree String -> [String]
  25     draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
  26       where
  27       drawSubTrees [] = []
  28       drawSubTrees [t] = shift "`- " "   " (draw t)
  29       drawSubTrees (t:ts) = shift "+- " "|  " (draw t) <> drawSubTrees ts
  30       shift first other = List.zipWith (<>) (first : List.repeat other)
  31
  32 instance IsString (GramDump a) where
  33   fromString s = GramDump $ Tree.Node (fromString s) []
  34
  35 instance Sharable GramDump where
  36   def refName x = GramDump $
  37     Tree.Node ( "def " <> show refName) [unGramDump x]
  38   ref refRec refName = GramDump $
  39     Tree.Node
  40       ( "ref "
  41       <> (if refRec then "rec " else "")
  42       <> show refName
  43       )
  44       []
  45 instance Applicable GramDump where
  46   _f <$> x = GramDump $ Tree.Node "<$>" [unGramDump x]
  47   pure a = GramDump $ Tree.Node ("pure "<>show a) []
  48   x <*> y = GramDump $ Tree.Node "<*>" [unGramDump x, unGramDump y]
  49 instance Alternable GramDump where
  50   empty = GramDump $ Tree.Node "empty" []
  51   x <|> y = GramDump $ Tree.Node "<|>" [unGramDump x, unGramDump y]
  52   try x = GramDump $ Tree.Node "try" [unGramDump x]
  53 instance Charable GramDump where
  54   satisfy _p = GramDump $ Tree.Node "satisfy" []
  55 instance Selectable GramDump where
  56   branch lr l r = GramDump $ Tree.Node "branch"
  57     [ unGramDump lr, unGramDump l, unGramDump r ]
  58 instance Matchable GramDump where
  59   conditional _cs bs a b = GramDump $ Tree.Node "conditional"
  60     [ Tree.Node "bs" (unGramDump Fct.<$> bs)
  61     , unGramDump a
  62     , unGramDump b
  63     ]
  64 instance Lookable GramDump where
  65   look x = GramDump $ Tree.Node "look" [unGramDump x]
  66   negLook x = GramDump $ Tree.Node "negLook" [unGramDump x]
  67 instance Foldable GramDump where
  68   chainPre f x = GramDump $ Tree.Node "chainPre" [unGramDump f, unGramDump x]
  69   chainPost x f = GramDump $ Tree.Node "chainPost" [unGramDump x, unGramDump f]