src/Symantic/Parser/Automaton/Dump.hs

   1 module Symantic.Parser.Automaton.Dump where
   2
   3 import Data.Function (($), (.), id)
   4 import Data.Functor ((<$>))
   5 import Data.Semigroup (Semigroup(..))
   6 import Data.String (String, IsString(..))
   7 import Text.Show (Show(..))
   8 import qualified Data.Tree as Tree
   9 import qualified Data.List as List
  10
  11 import Symantic.Parser.Automaton.Instructions
  12
  13 -- * Type 'DumpInstr'
  14 newtype DumpInstr inp (vs:: [*]) (es::Peano) a x = DumpInstr { unDumpInstr :: Tree.Tree String }
  15
  16 dumpInstr :: DumpInstr inp vs es a x -> DumpInstr inp vs es a x
  17 dumpInstr = id
  18
  19 instance Show (DumpInstr inp vs es a x) where
  20   show = drawTree . unDumpInstr
  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 instance IsString (DumpInstr inp vs es a x) where
  32   fromString s = DumpInstr $ Tree.Node (fromString s) []
  33
  34 instance Stackable DumpInstr where
  35   push a k = DumpInstr $ Tree.Node ("push "<>show a) [unDumpInstr k]
  36   pop k = DumpInstr $ Tree.Node "pop" [unDumpInstr k]
  37   liftI2 f k = DumpInstr $ Tree.Node ("liftI2 "<>show f) [unDumpInstr k]
  38   swap k = DumpInstr $ Tree.Node "swap" [unDumpInstr k]
  39 instance Branchable DumpInstr where
  40   case_ l r = DumpInstr $ Tree.Node "case" [unDumpInstr l, unDumpInstr r]
  41   choices ps bs d = DumpInstr $ Tree.Node ("choices "<>show ps) ((unDumpInstr <$> bs) <> [unDumpInstr d])
  42 instance Exceptionable DumpInstr where
  43   fail = DumpInstr $ Tree.Node "fail" []
  44   commit k = DumpInstr $ Tree.Node "commit" [unDumpInstr k]
  45   catch l r = DumpInstr $ Tree.Node "catch" [unDumpInstr l, unDumpInstr r]
  46 instance Inputable DumpInstr where
  47   seek k = DumpInstr $ Tree.Node "seek" [unDumpInstr k]
  48   tell k = DumpInstr $ Tree.Node "tell" [unDumpInstr k]
  49 instance Routinable DumpInstr where
  50   label n k = DumpInstr $ Tree.Node ("label "<>show n) [unDumpInstr k]
  51   jump n = DumpInstr $ Tree.Node ("jump "<>show n) []
  52   call n k = DumpInstr $ Tree.Node ("call "<>show n) [unDumpInstr k]
  53   ret = DumpInstr $ Tree.Node "ret" []
  54 instance Readable DumpInstr where
  55   read _p k = DumpInstr $ Tree.Node "read" [unDumpInstr k]