]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/View.hs
machine: fix view and output
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / View.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
3 module Symantic.Parser.Machine.View where
4
5 import Data.Bool (Bool(..))
6 import Data.Either (Either(..))
7 import Data.Function (($), (.), id, on)
8 import Data.Functor ((<$>))
9 import Data.Kind (Type)
10 import Data.Ord (Ord(..))
11 import Data.Semigroup (Semigroup(..))
12 import Data.String (String)
13 import Data.Tuple (fst)
14 import Text.Show (Show(..))
15 import qualified Data.HashMap.Strict as HM
16 import qualified Data.List as List
17 import qualified Data.Map.Strict as Map
18 import qualified Data.Set as Set
19 import qualified Data.Tree as Tree
20 import qualified Language.Haskell.TH.Syntax as TH
21 import Prelude (error)
22
23 import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))
24 import Symantic.Parser.Machine.Instructions
25 import Symantic.Univariant.Letable (SomeLet(..))
26 import Symantic.Parser.Machine.Generate
27
28 -- * Type 'ViewMachine'
29 data ViewMachine (showName::Bool) inp (vs:: [Type]) a
30 = ViewMachine
31 { viewGen :: Gen inp vs a
32 -- ^ Provide 'GenAnalysis', which next important for debugging
33 -- and improving golden tests, see 'viewInstrCmd'.
34 , unViewMachine ::
35 CallTrace ->
36 LetMap GenAnalysis -> -- Output of 'runGenAnalysis'.
37 Tree.Forest (String, String) ->
38 Tree.Forest (String, String)
39 }
40
41 viewMachine ::
42 ViewMachine sN inp vs a ->
43 ViewMachine sN inp vs a
44 viewMachine = id
45
46 -- | Helper to view a command.
47 viewInstrCmd ::
48 Either TH.Name (Gen inp vs a) ->
49 CallTrace ->
50 LetMap GenAnalysis ->
51 (String, String) -> Tree.Forest (String, String) -> Tree.Tree (String, String)
52 viewInstrCmd gen ct lm (n, no) = Tree.Node $ (n
53 <> "\nminReads="<>showsPrec 11 (minReads ga) ""
54 <> "\nmayRaise="<>showsPrec 11 (Map.keys (mayRaise ga)) ""
55 , no)
56 where
57 ga = case gen of
58 Right r -> (\f -> f ct) $ genAnalysis r $ (\f _ct -> f) <$> lm
59 Left l -> HM.findWithDefault (error (show (l, HM.keys lm))) l lm
60
61 -- | Helper to view an argument.
62 viewInstrArg :: String -> Tree.Forest (String, String) -> Tree.Tree (String, String)
63 viewInstrArg n = Tree.Node $ ("<"<>n<>">", "")
64
65 instance Show (ViewMachine sN inp vs a) where
66 show vm = List.unlines $ drawTrees $
67 unViewMachine vm [] (runGenAnalysis (genAnalysisByLet (viewGen vm))) []
68 where
69 draw :: Tree.Tree (String, String) -> [String]
70 draw (Tree.Node (x, n) ts0) =
71 shift "" " " (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
72 shift "| " "| " (drawTrees ts0)
73 drawTrees [] = []
74 drawTrees [t] = draw t
75 drawTrees (t:ts) = draw t <> drawTrees ts
76 shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
77
78 instance InstrValuable (ViewMachine sN) where
79 pushValue a k = ViewMachine
80 { unViewMachine = \ct lm next ->
81 viewInstrCmd (Right gen) ct lm ("pushValue "<>showsPrec 10 a "", "") [] :
82 unViewMachine k ct lm next
83 , viewGen = gen
84 } where gen = pushValue a (viewGen k)
85 popValue k = ViewMachine
86 { unViewMachine = \ct lm next ->
87 viewInstrCmd (Right gen) ct lm ("popValue", "") [] :
88 unViewMachine k ct lm next
89 , viewGen = gen
90 } where gen = popValue (viewGen k)
91 lift2Value f k = ViewMachine
92 { unViewMachine = \ct lm next ->
93 viewInstrCmd (Right gen) ct lm ("lift2Value "<>showsPrec 10 f "", "") [] :
94 unViewMachine k ct lm next
95 , viewGen = gen
96 } where gen = lift2Value f (viewGen k)
97 swapValue k = ViewMachine
98 { unViewMachine = \ct lm next ->
99 viewInstrCmd (Right gen) ct lm ("swapValue", "") [] :
100 unViewMachine k ct lm next
101 , viewGen = gen
102 } where gen = swapValue (viewGen k)
103 instance InstrExceptionable (ViewMachine sN) where
104 raise exn = ViewMachine
105 { unViewMachine = \ct lm next ->
106 viewInstrCmd (Right gen) ct lm ("raise "<>show exn, "") [] : next
107 , viewGen = gen
108 } where gen = raise exn
109 fail flr = ViewMachine
110 { unViewMachine = \ct lm next ->
111 viewInstrCmd (Right gen) ct lm ("fail "<>show (Set.toList flr), "") [] : next
112 , viewGen = gen
113 } where gen = fail flr
114 commit exn k = ViewMachine
115 { unViewMachine = \ct lm next ->
116 viewInstrCmd (Right gen) ct lm ("commit "<>show exn, "") [] :
117 unViewMachine k ct lm next
118 , viewGen = gen
119 } where gen = commit exn (viewGen k)
120 catch exn ok ko = ViewMachine
121 { unViewMachine = \ct lm next ->
122 viewInstrCmd (Right gen) ct lm ("catch "<>show exn, "")
123 [ viewInstrArg "ok" (unViewMachine ok ct lm [])
124 , viewInstrArg "ko" (unViewMachine ko ct lm [])
125 ] : next
126 , viewGen = gen
127 } where gen = catch exn (viewGen ok) (viewGen ko)
128 instance InstrBranchable (ViewMachine sN) where
129 caseBranch l r = ViewMachine
130 { unViewMachine = \ct lm next ->
131 viewInstrCmd (Right gen) ct lm ("case", "")
132 [ viewInstrArg "left" (unViewMachine l ct lm [])
133 , viewInstrArg "right" (unViewMachine r ct lm [])
134 ] : next
135 , viewGen = gen
136 } where gen = caseBranch (viewGen l) (viewGen r)
137 choicesBranch ps bs d = ViewMachine
138 { unViewMachine = \ct lm next ->
139 viewInstrCmd (Right gen) ct lm ("choicesBranch "<>show ps, "") (
140 ((\b -> viewInstrArg "branch" $ unViewMachine b ct lm []) <$> bs) <>
141 [ viewInstrArg "default" (unViewMachine d ct lm []) ]
142 ) : next
143 , viewGen = gen
144 } where gen = choicesBranch ps (viewGen <$> bs) (viewGen d)
145 instance
146 ShowLetName sN TH.Name =>
147 InstrCallable (ViewMachine sN) where
148 defLet defs k = ViewMachine
149 { unViewMachine = \ct lm next ->
150 (<> unViewMachine k ct lm next) $
151 List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
152 ((\(n, SomeLet sub) ->
153 viewInstrCmd (Left n) ct lm
154 ("let", " "<>showLetName @sN n)
155 (unViewMachine sub ct lm []))
156 <$> HM.toList defs)
157 , viewGen = gen
158 } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
159 jump ln@(LetName n) = ViewMachine
160 { unViewMachine = \ct lm next ->
161 viewInstrCmd (Right gen) ct lm ("jump", " "<>showLetName @sN n) [] : next
162 , viewGen = gen
163 } where gen = jump ln
164 call ln@(LetName n) k = ViewMachine
165 { unViewMachine = \ct lm next ->
166 viewInstrCmd (Right gen) ct lm ("call", " "<>showLetName @sN n) [] :
167 unViewMachine k (n:ct) lm next
168 , viewGen = gen
169 } where gen = call ln (viewGen k)
170 ret = ViewMachine
171 { unViewMachine = \ct lm next ->
172 viewInstrCmd (Right gen) ct lm ("ret", "") [] : next
173 , viewGen = gen
174 } where gen = ret
175 instance
176 ShowLetName sN TH.Name =>
177 InstrJoinable (ViewMachine sN) where
178 defJoin ln@(LetName n) j k = ViewMachine
179 { unViewMachine = \ct lm next ->
180 viewInstrCmd (Left n) ct lm
181 ("join", " "<>showLetName @sN n)
182 (unViewMachine j ct lm []) :
183 unViewMachine k (n:ct) lm next
184 , viewGen = gen
185 } where gen = defJoin ln (viewGen j) (viewGen k)
186 refJoin ln@(LetName n) = ViewMachine
187 { unViewMachine = \ct lm next ->
188 viewInstrCmd (Right gen) ct lm ("refJoin", " "<>showLetName @sN n) [] : next
189 , viewGen = gen
190 } where gen = refJoin ln
191 instance InstrInputable (ViewMachine sN) where
192 pushInput k = ViewMachine
193 { unViewMachine = \ct lm next ->
194 viewInstrCmd (Right gen) ct lm ("pushInput", "") [] :
195 unViewMachine k ct lm next
196 , viewGen = gen
197 } where gen = pushInput (viewGen k)
198 loadInput k = ViewMachine
199 { unViewMachine = \ct lm next ->
200 viewInstrCmd (Right gen) ct lm ("loadInput", "") [] :
201 unViewMachine k ct lm next
202 , viewGen = gen
203 } where gen = loadInput (viewGen k)
204 instance InstrReadable tok Gen => InstrReadable tok (ViewMachine sN) where
205 read es p k = ViewMachine
206 { unViewMachine = \ct lm next ->
207 viewInstrCmd (Right gen) ct lm ("read "<>showsPrec 10 p "", "") [] :
208 unViewMachine k ct lm next
209 , viewGen = gen
210 } where gen = read es p (viewGen k)