1 module Symantic.Parser.Grammar.Dump where
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
14 newtype GramDump a = GramDump { unGramDump :: Tree.Tree String }
16 gramDump :: GramDump a -> GramDump a
19 instance Show (GramDump a) where
20 show = drawTree . unGramDump
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
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)
32 instance IsString (GramDump a) where
33 fromString s = GramDump $ Tree.Node (fromString s) []
35 instance Sharable GramDump where
36 def refName x = GramDump $
37 Tree.Node ( "def " <> show refName) [unGramDump x]
38 ref refRec refName = GramDump $
41 <> (if refRec then "rec " else "")
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)
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]