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
  15   =     DumpInstr { unDumpInstr ::
  16   Tree.Forest String -> Tree.Forest String }
  17
  18 dumpInstr :: DumpInstr inp vs es a x -> DumpInstr inp vs es a x
  19 dumpInstr = id
  20
  21 -- | Helper to dump a command.
  22 dumpInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
  23 dumpInstrCmd n = Tree.Node n
  24 -- | Helper to dump an argument.
  25 dumpInstrArg :: String -> Tree.Forest String -> Tree.Tree String
  26 dumpInstrArg n = Tree.Node ("<"<>n<>">")
  27
  28 instance Show (DumpInstr inp vs es a x) where
  29   show = drawTree . Tree.Node "" . ($ []) . unDumpInstr
  30     where
  31     drawTree :: Tree.Tree String -> String
  32     drawTree  = List.unlines . draw
  33     draw :: Tree.Tree String -> [String]
  34     draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
  35       where
  36       drawSubTrees [] = []
  37       drawSubTrees [t] = shift "" "  " (draw t)
  38       drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts
  39       shift first other = List.zipWith (<>) (first : List.repeat other)
  40 instance IsString (DumpInstr inp vs es a x) where
  41   fromString s = DumpInstr $ \is -> Tree.Node (fromString s) [] : is
  42
  43 instance Stackable DumpInstr where
  44   push a k = DumpInstr $ \is -> dumpInstrCmd ("push "<>showsPrec 10 a "") [] : unDumpInstr k is
  45   pop k = DumpInstr $ \is -> dumpInstrCmd "pop" [] : unDumpInstr k is
  46   liftI2 f k = DumpInstr $ \is -> dumpInstrCmd ("lift "<>show f) [] : unDumpInstr k is
  47   swap k = DumpInstr $ \is -> dumpInstrCmd "swap" [] : unDumpInstr k is
  48 instance Branchable DumpInstr where
  49   case_ l r = DumpInstr $ \is -> dumpInstrCmd "case"
  50     [ dumpInstrArg "left" (unDumpInstr l [])
  51     , dumpInstrArg "right" (unDumpInstr r [])
  52     ] : is
  53   choices ps bs d = DumpInstr $ \is ->
  54     dumpInstrCmd ("choices "<>show ps) (
  55       (dumpInstrArg "branch" . ($ []) . unDumpInstr <$> bs) <>
  56       [ dumpInstrArg "default" (unDumpInstr d []) ]
  57     ) : is
  58 instance Exceptionable DumpInstr where
  59   fail = DumpInstr $ \is -> dumpInstrCmd "fail" [] : is
  60   commit k = DumpInstr $ \is -> dumpInstrCmd "commit" [] : unDumpInstr k is
  61   catch t h = DumpInstr $ \is -> dumpInstrCmd "catch"
  62     [ dumpInstrArg "try" (unDumpInstr t [])
  63     , dumpInstrArg "handler" (unDumpInstr h [])
  64     ] : is
  65 instance Inputable DumpInstr where
  66   seek k = DumpInstr $ \is -> dumpInstrCmd "seek" [] : unDumpInstr k is
  67   tell k = DumpInstr $ \is -> dumpInstrCmd "tell" [] : unDumpInstr k is
  68 instance Routinable DumpInstr where
  69   subroutine n v k = DumpInstr $ \is ->
  70     Tree.Node (show n<>":") (unDumpInstr v [])
  71     : unDumpInstr k is
  72   jump n = DumpInstr $ \is -> dumpInstrCmd ("jump "<>show n) [] : is
  73   call n k = DumpInstr $ \is -> dumpInstrCmd ("call "<>show n) [] : unDumpInstr k is
  74   ret = DumpInstr $ \is -> dumpInstrCmd "ret" [] : is
  75 instance Readable DumpInstr where
  76   read _p k = DumpInstr $ \is -> dumpInstrCmd "read" [] : unDumpInstr k is