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