]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/View.hs
doc: polish
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / View.hs
1 {-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
2 module Symantic.Parser.Machine.View where
3
4 import Data.Bool (Bool(..))
5 import Data.Function (($), (.), id)
6 import Data.Functor ((<$>))
7 import Data.Kind (Type)
8 import Data.Semigroup (Semigroup(..))
9 import Data.String (String, IsString(..))
10 import Text.Show (Show(..))
11 import qualified Data.Tree as Tree
12 import qualified Data.List as List
13 import qualified Language.Haskell.TH.Syntax as TH
14
15 import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))
16 import Symantic.Parser.Machine.Instructions
17
18 -- * Type 'ViewMachine'
19 newtype ViewMachine (showName::Bool) inp (vs:: [Type]) (es::Peano) a
20 = ViewMachine { unViewMachine ::
21 Tree.Forest String -> Tree.Forest String }
22
23 viewMachine ::
24 ViewMachine sN inp vs es a ->
25 ViewMachine sN inp vs es a
26 viewMachine = id
27
28 -- | Helper to view a command.
29 viewInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
30 viewInstrCmd n = Tree.Node n
31 -- | Helper to view an argument.
32 viewInstrArg :: String -> Tree.Forest String -> Tree.Tree String
33 viewInstrArg n = Tree.Node ("<"<>n<>">")
34
35 instance Show (ViewMachine sN inp vs es a) where
36 show = drawTree . Tree.Node "" . ($ []) . unViewMachine
37 where
38 drawTree :: Tree.Tree String -> String
39 drawTree = List.unlines . draw
40 draw :: Tree.Tree String -> [String]
41 draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
42 where
43 drawSubTrees [] = []
44 drawSubTrees [t] = shift "" " " (draw t)
45 drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts
46 shift first other = List.zipWith (<>) (first : List.repeat other)
47 instance IsString (ViewMachine sN inp vs es a) where
48 fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is
49
50 instance Stackable (ViewMachine sN) where
51 push a k = ViewMachine $ \is -> viewInstrCmd ("push "<>showsPrec 10 a "") [] : unViewMachine k is
52 pop k = ViewMachine $ \is -> viewInstrCmd "pop" [] : unViewMachine k is
53 liftI2 f k = ViewMachine $ \is -> viewInstrCmd ("lift "<>showsPrec 10 f "") [] : unViewMachine k is
54 swap k = ViewMachine $ \is -> viewInstrCmd "swap" [] : unViewMachine k is
55 instance Branchable (ViewMachine sN) where
56 caseI l r = ViewMachine $ \is -> viewInstrCmd "case"
57 [ viewInstrArg "left" (unViewMachine l [])
58 , viewInstrArg "right" (unViewMachine r [])
59 ] : is
60 choices ps bs d = ViewMachine $ \is ->
61 viewInstrCmd ("choices "<>show ps) (
62 (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <>
63 [ viewInstrArg "default" (unViewMachine d []) ]
64 ) : is
65 instance Failable (ViewMachine sN) where
66 fail _err = ViewMachine $ \is -> viewInstrCmd "fail" [] : is
67 popFail k = ViewMachine $ \is -> viewInstrCmd "popFail" [] : unViewMachine k is
68 catchFail t h = ViewMachine $ \is -> viewInstrCmd "catchFail"
69 [ viewInstrArg "try" (unViewMachine t [])
70 , viewInstrArg "handler" (unViewMachine h [])
71 ] : is
72 instance Inputable (ViewMachine sN) where
73 loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is
74 pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is
75 instance
76 ShowLetName sN TH.Name =>
77 Routinable (ViewMachine sN) where
78 subroutine (LetName n) sub k = ViewMachine $ \is ->
79 Tree.Node (showLetName @sN n<>":") (unViewMachine sub [])
80 : unViewMachine k is
81 jump (LetName n) = ViewMachine $ \is -> viewInstrCmd ("jump "<>showLetName @sN n) [] : is
82 call (LetName n) k = ViewMachine $ \is -> viewInstrCmd ("call "<>showLetName @sN n) [] : unViewMachine k is
83 ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is
84 instance
85 ShowLetName sN TH.Name =>
86 Joinable (ViewMachine sN) where
87 defJoin (LetName n) j k = ViewMachine $ \is ->
88 Tree.Node (showLetName @sN n<>":") (unViewMachine j [])
89 : unViewMachine k is
90 refJoin (LetName n) = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>showLetName @sN n) [] : is
91 instance Readable tok (ViewMachine sN) where
92 read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is