]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Dump.hs
test: save
[haskell/symantic-parser.git] / 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