src/Symantic/Parser/Machine/Dump.hs

   1 module Symantic.Parser.Machine.Dump where
   2
   3 import Data.Function (($), (.), id)
   4 import Data.Functor ((<$>))
   5 import Data.Kind (Type)
   6 import Data.Semigroup (Semigroup(..))
   7 import Data.String (String, IsString(..))
   8 import Text.Show (Show(..))
   9 import qualified Data.Tree as Tree
  10 import qualified Data.List as List
  11
  12 import Symantic.Parser.Machine.Instructions
  13
  14 -- * Type 'DumpInstr'
  15 newtype DumpInstr inp (vs:: [Type]) (es::Peano) a
  16   =     DumpInstr { unDumpInstr ::
  17   Tree.Forest String -> Tree.Forest String }
  18
  19 dumpInstr :: DumpInstr inp vs es a -> DumpInstr inp vs es a
  20 dumpInstr = id
  21
  22 -- | Helper to dump a command.
  23 dumpInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
  24 dumpInstrCmd n = Tree.Node n
  25 -- | Helper to dump an argument.
  26 dumpInstrArg :: String -> Tree.Forest String -> Tree.Tree String
  27 dumpInstrArg n = Tree.Node ("<"<>n<>">")
  28
  29 instance Show (DumpInstr inp vs es a) where
  30   show = drawTree . Tree.Node "" . ($ []) . unDumpInstr
  31     where
  32     drawTree :: Tree.Tree String -> String
  33     drawTree  = List.unlines . draw
  34     draw :: Tree.Tree String -> [String]
  35     draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
  36       where
  37       drawSubTrees [] = []
  38       drawSubTrees [t] = shift "" "  " (draw t)
  39       drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts
  40       shift first other = List.zipWith (<>) (first : List.repeat other)
  41 instance IsString (DumpInstr inp vs es a) where
  42   fromString s = DumpInstr $ \is -> Tree.Node (fromString s) [] : is
  43
  44 instance Stackable DumpInstr where
  45   push a k = DumpInstr $ \is -> dumpInstrCmd ("push "<>showsPrec 10 a "") [] : unDumpInstr k is
  46   pop k = DumpInstr $ \is -> dumpInstrCmd "pop" [] : unDumpInstr k is
  47   liftI2 f k = DumpInstr $ \is -> dumpInstrCmd ("lift "<>show f) [] : unDumpInstr k is
  48   swap k = DumpInstr $ \is -> dumpInstrCmd "swap" [] : unDumpInstr k is
  49 instance Branchable DumpInstr where
  50   case_ l r = DumpInstr $ \is -> dumpInstrCmd "case"
  51     [ dumpInstrArg "left" (unDumpInstr l [])
  52     , dumpInstrArg "right" (unDumpInstr r [])
  53     ] : is
  54   choices ps bs d = DumpInstr $ \is ->
  55     dumpInstrCmd ("choices "<>show ps) (
  56       (dumpInstrArg "branch" . ($ []) . unDumpInstr <$> bs) <>
  57       [ dumpInstrArg "default" (unDumpInstr d []) ]
  58     ) : is
  59 instance Failable DumpInstr where
  60   fail _err = DumpInstr $ \is -> dumpInstrCmd "fail" [] : is
  61   popFail k = DumpInstr $ \is -> dumpInstrCmd "popFail" [] : unDumpInstr k is
  62   catchFail t h = DumpInstr $ \is -> dumpInstrCmd "catchFail"
  63     [ dumpInstrArg "try" (unDumpInstr t [])
  64     , dumpInstrArg "handler" (unDumpInstr h [])
  65     ] : is
  66 instance Inputable DumpInstr where
  67   loadInput k = DumpInstr $ \is -> dumpInstrCmd "loadInput" [] : unDumpInstr k is
  68   pushInput k = DumpInstr $ \is -> dumpInstrCmd "pushInput" [] : unDumpInstr k is
  69 instance Routinable DumpInstr where
  70   subroutine n sub k = DumpInstr $ \is ->
  71     Tree.Node (show n<>":") (unDumpInstr sub [])
  72     : unDumpInstr k is
  73   jump n = DumpInstr $ \is -> dumpInstrCmd ("jump "<>show n) [] : is
  74   call n k = DumpInstr $ \is -> dumpInstrCmd ("call "<>show n) [] : unDumpInstr k is
  75   ret = DumpInstr $ \is -> dumpInstrCmd "ret" [] : is
  76 instance Joinable DumpInstr where
  77   defJoin n sub k = DumpInstr $ \is ->
  78     Tree.Node (show n<>":") (unDumpInstr sub [])
  79     : unDumpInstr k is
  80   refJoin n = DumpInstr $ \is -> dumpInstrCmd ("refJoin "<>show n) [] : is
  81 instance Readable DumpInstr inp where
  82   read _es _p k = DumpInstr $ \is -> dumpInstrCmd "read" [] : unDumpInstr k is