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.Univariant.Letable
  12 import Symantic.Parser.Grammar.Combinators
  13
  14 -- * Type 'DumpComb'
  15 newtype DumpComb a = DumpComb { unDumpComb :: Tree.Tree String }
  16
  17 dumpComb :: DumpComb a -> DumpComb a
  18 dumpComb = id
  19
  20 instance Show (DumpComb a) where
  21   show = drawTree . unDumpComb
  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 instance IsString (DumpComb a) where
  33   fromString s = DumpComb $ Tree.Node (fromString s) []
  34
  35 instance Show letName => Letable letName DumpComb where
  36   def name x = DumpComb $
  37     Tree.Node ( "def "
  38     <> show name
  39     ) [unDumpComb x]
  40   ref rec name = DumpComb $
  41     Tree.Node
  42       ( (if rec then "rec " else "ref ")
  43       <> show name
  44       )
  45       []
  46 instance Applicable DumpComb where
  47   _f <$> x = DumpComb $ Tree.Node "<$>" [unDumpComb x]
  48   pure a = DumpComb $ Tree.Node ("pure "<>show a) []
  49   x <*> y = DumpComb $ Tree.Node "<*>" [unDumpComb x, unDumpComb y]
  50 instance Alternable DumpComb where
  51   empty = DumpComb $ Tree.Node "empty" []
  52   x <|> y = DumpComb $ Tree.Node "<|>" [unDumpComb x, unDumpComb y]
  53   try x = DumpComb $ Tree.Node "try" [unDumpComb x]
  54 instance Charable DumpComb where
  55   satisfy _p = DumpComb $ Tree.Node "satisfy" []
  56 instance Selectable DumpComb where
  57   branch lr l r = DumpComb $ Tree.Node "branch"
  58     [ unDumpComb lr, unDumpComb l, unDumpComb r ]
  59 instance Matchable DumpComb where
  60   conditional _cs bs a b = DumpComb $ Tree.Node "conditional"
  61     [ Tree.Node "bs" (unDumpComb Fct.<$> bs)
  62     , unDumpComb a
  63     , unDumpComb b
  64     ]
  65 instance Lookable DumpComb where
  66   look x = DumpComb $ Tree.Node "look" [unDumpComb x]
  67   negLook x = DumpComb $ Tree.Node "negLook" [unDumpComb x]
  68 instance Foldable DumpComb where
  69   chainPre f x = DumpComb $ Tree.Node "chainPre" [unDumpComb f, unDumpComb x]
  70   chainPost x f = DumpComb $ Tree.Node "chainPost" [unDumpComb x, unDumpComb f]