]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/View.hs
machine: open the Instr data-type
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / View.hs
1 module Symantic.Parser.Machine.View 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 'ViewMachine'
15 newtype ViewMachine inp (vs:: [Type]) (es::Peano) a
16 = ViewMachine { unViewMachine ::
17 Tree.Forest String -> Tree.Forest String }
18
19 viewInstr :: ViewMachine inp vs es a -> ViewMachine inp vs es a
20 viewInstr = id
21
22 -- | Helper to view a command.
23 viewInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
24 viewInstrCmd n = Tree.Node n
25 -- | Helper to view an argument.
26 viewInstrArg :: String -> Tree.Forest String -> Tree.Tree String
27 viewInstrArg n = Tree.Node ("<"<>n<>">")
28
29 instance Show (ViewMachine inp vs es a) where
30 show = drawTree . Tree.Node "" . ($ []) . unViewMachine
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 (ViewMachine inp vs es a) where
42 fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is
43
44 instance Stackable ViewMachine where
45 push a k = ViewMachine $ \is -> viewInstrCmd ("push "<>showsPrec 10 a "") [] : unViewMachine k is
46 pop k = ViewMachine $ \is -> viewInstrCmd "pop" [] : unViewMachine k is
47 liftI2 f k = ViewMachine $ \is -> viewInstrCmd ("lift "<>showsPrec 10 f "") [] : unViewMachine k is
48 swap k = ViewMachine $ \is -> viewInstrCmd "swap" [] : unViewMachine k is
49 instance Branchable ViewMachine where
50 caseI l r = ViewMachine $ \is -> viewInstrCmd "case"
51 [ viewInstrArg "left" (unViewMachine l [])
52 , viewInstrArg "right" (unViewMachine r [])
53 ] : is
54 choices ps bs d = ViewMachine $ \is ->
55 viewInstrCmd ("choices "<>show ps) (
56 (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <>
57 [ viewInstrArg "default" (unViewMachine d []) ]
58 ) : is
59 instance Failable ViewMachine where
60 fail _err = ViewMachine $ \is -> viewInstrCmd "fail" [] : is
61 popFail k = ViewMachine $ \is -> viewInstrCmd "popFail" [] : unViewMachine k is
62 catchFail t h = ViewMachine $ \is -> viewInstrCmd "catchFail"
63 [ viewInstrArg "try" (unViewMachine t [])
64 , viewInstrArg "handler" (unViewMachine h [])
65 ] : is
66 instance Inputable ViewMachine where
67 loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is
68 pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is
69 instance Routinable ViewMachine where
70 subroutine n sub k = ViewMachine $ \is ->
71 Tree.Node (show n<>":") (unViewMachine sub [])
72 : unViewMachine k is
73 jump n = ViewMachine $ \is -> viewInstrCmd ("jump "<>show n) [] : is
74 call n k = ViewMachine $ \is -> viewInstrCmd ("call "<>show n) [] : unViewMachine k is
75 ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is
76 instance Joinable ViewMachine where
77 defJoin n sub k = ViewMachine $ \is ->
78 Tree.Node (show n<>":") (unViewMachine sub [])
79 : unViewMachine k is
80 refJoin n = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>show n) [] : is
81 instance Readable tok ViewMachine where
82 read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is