]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Instructions.hs
machine: remove horizonStack and experiment with alwaysRaise
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Instructions.hs
1 {-# LANGUAGE ConstraintKinds #-} -- For Machine
2 {-# LANGUAGE DeriveLift #-} -- For TH.Lift (Failure tok)
3 {-# LANGUAGE DerivingStrategies #-} -- For Show (LetName a)
4 -- | Semantic of the parsing instructions used
5 -- to make the parsing control-flow explicit,
6 -- in the convenient tagless-final encoding.
7 module Symantic.Parser.Machine.Instructions where
8
9 import Data.Bool (Bool(..))
10 import Data.Either (Either)
11 import Data.Eq (Eq(..))
12 import Data.Function ((.))
13 import Data.Kind (Type)
14 import Data.Set (Set)
15 import Text.Show (Show(..))
16 import Data.String (String)
17 import qualified Language.Haskell.TH as TH
18
19 import Symantic.Parser.Grammar
20 import Symantic.Parser.Machine.Input
21 import qualified Symantic.Lang as Prod
22 import qualified Symantic.Data as Sym
23
24 -- * Type 'Splice'
25 type Splice = Sym.SomeData TH.CodeQ
26
27 -- | Lift a 'TH.CodeQ' into a 'Sym.SomeData'.
28 splice :: TH.CodeQ a -> Splice a
29 splice x = Sym.SomeData (Sym.Var x)
30
31 -- ** Type 'ReprInstr'
32 type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
33
34 -- ** Type 'LetName'
35 -- | 'TH.Name' of a 'defLet' or 'defJoin'
36 -- indexed by the return type of the factorized 'Instr'uctions.
37 -- This helps type-inferencing.
38 newtype LetName a = LetName { unLetName :: TH.Name }
39 deriving Eq
40 deriving newtype Show
41
42 -- ** Class 'InstrComment'
43 class InstrComment (repr::ReprInstr) where
44 comment :: String -> repr inp vs a -> repr inp vs a
45
46 -- ** Class 'InstrValuable'
47 class InstrValuable (repr::ReprInstr) where
48 -- | @('pushValue' x k)@ pushes @(x)@ on the 'valueStack'
49 -- and continues with the next 'Instr'uction @(k)@.
50 pushValue ::
51 Splice v ->
52 repr inp (v ': vs) a ->
53 repr inp vs a
54 -- | @('popValue' k)@ pushes @(x)@ on the 'valueStack'.
55 popValue ::
56 repr inp vs a ->
57 repr inp (v ': vs) a
58 -- | @('lift2Value' f k)@ pops two values from the 'valueStack',
59 -- and pushes the result of @(f)@ applied to them.
60 lift2Value ::
61 Splice (x -> y -> z) ->
62 repr inp (z ': vs) a ->
63 repr inp (y ': x ': vs) a
64 -- | @('swapValue' k)@ pops two values on the 'valueStack',
65 -- pushes the first popped-out, then the second,
66 -- and continues with the next 'Instr'uction @(k)@.
67 swapValue ::
68 repr inp (x ': y ': vs) a ->
69 repr inp (y ': x ': vs) a
70 -- | @('mapValue' f k)@.
71 mapValue ::
72 Splice (x -> y) ->
73 repr inp (y ': vs) a ->
74 repr inp (x ': vs) a
75 mapValue f = pushValue f . lift2Value (Prod.flip Prod..@ (Prod.$))
76 -- | @('applyValue' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
77 -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
78 applyValue ::
79 repr inp (y ': vs) a ->
80 repr inp (x ': (x -> y) ': vs) a
81 applyValue = lift2Value (Prod.$)
82
83 -- ** Class 'InstrExceptionable'
84 class InstrExceptionable (repr::ReprInstr) where
85 -- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
86 raise :: ExceptionLabel -> repr inp vs a
87 -- | @('fail' fs)@ raises 'ExceptionFailure' @(exn)@.
88 -- As a special case, giving an empty 'Set' of failures
89 -- raises 'ExceptionFailure' without using the current position
90 -- to update the farthest error.
91 fail :: Set SomeFailure -> repr inp vs a
92 -- | @('commit' exn k)@ removes the 'Catcher'
93 -- from the 'onExceptionStackByLabel' for the given 'Exception' @(exn)@,
94 -- and continues with the next 'Instr'uction @(k)@.
95 commit :: Exception -> repr inp vs a -> repr inp vs a
96 -- | @('catch' exn l r)@ tries the @(l)@ 'Instr'uction
97 -- in a new failure scope such that if @(l)@ raises an exception within @(exn)@, it is caught,
98 -- then the input (and its 'Horizon') is pushed
99 -- as it was before trying @(l)@ on the 'valueStack' (resp. on the 'horizonStack'),
100 -- and the control flow goes on with the @(r)@ 'Instr'uction.
101 catch ::
102 Exception ->
103 {-scope-}repr inp vs ret ->
104 {-onException-}repr inp (Cursor inp ': vs) ret ->
105 repr inp vs ret
106
107 -- ** Class 'InstrBranchable'
108 class InstrBranchable (repr::ReprInstr) where
109 -- | @('caseBranch' l r)@.
110 caseBranch ::
111 repr inp (x ': vs) r ->
112 repr inp (y ': vs) r ->
113 repr inp (Either x y ': vs) r
114 -- | @('choicesBranch' ps bs d)@.
115 choicesBranch ::
116 [(Splice (v -> Bool), repr inp vs a)] ->
117 repr inp vs a ->
118 repr inp (v ': vs) a
119 -- | @('ifBranch' ok ko)@ pops a 'Bool' from the 'valueStack'
120 -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
121 -- or @(ko)@ otherwise.
122 ifBranch ::
123 repr inp vs a ->
124 repr inp vs a ->
125 repr inp (Bool ': vs) a
126 ifBranch ok ko = choicesBranch [(Prod.id, ok)] ko
127
128 -- ** Class 'InstrCallable'
129 class InstrCallable (repr::ReprInstr) where
130 -- | @('defLet' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,
131 -- 'Call's @(n)@ and
132 -- continues with the next 'Instr'uction @(k)@.
133 defLet ::
134 LetBindings TH.Name (repr inp '[]) ->
135 repr inp vs a ->
136 repr inp vs a
137 -- | @('call' isRec n k)@ pass the control-flow to the 'DefLet' named @(n)@,
138 -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
139 call ::
140 Bool ->
141 LetName v -> repr inp (v ': vs) a ->
142 repr inp vs a
143 -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
144 ret ::
145 repr inp '[a] a
146 -- | @('jump' isRec n k)@ pass the control-flow to the 'DefLet' named @(n)@.
147 jump ::
148 Bool ->
149 LetName a ->
150 repr inp '[] a
151
152 -- ** Class 'InstrJoinable'
153 class InstrJoinable (repr::ReprInstr) where
154 defJoin ::
155 LetName v -> repr inp (v ': vs) a ->
156 repr inp vs a ->
157 repr inp vs a
158 refJoin ::
159 LetName v ->
160 repr inp (v ': vs) a
161
162 -- ** Class 'InstrInputable'
163 class InstrInputable (repr::ReprInstr) where
164 -- | @('saveInput' k)@ pushes the input @(inp)@ on the 'valueStackHead'
165 -- and continues with the next 'Instr'uction @(k)@.
166 saveInput ::
167 repr inp (Cursor inp ': vs) a ->
168 repr inp vs a
169 -- | @('loadInput' k)@ removes the input from the 'valueStackHead'
170 -- and continues with the next 'Instr'uction @(k)@ using that input.
171 loadInput ::
172 repr inp vs a ->
173 repr inp (Cursor inp ': vs) a
174
175 -- ** Class 'InstrReadable'
176 class InstrReadable (tok::Type) (repr::ReprInstr) where
177 -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
178 -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
179 -- otherwise 'fail'.
180 read ::
181 tok ~ InputToken inp =>
182 Set SomeFailure ->
183 Splice (tok -> Bool) ->
184 repr inp (tok ': vs) a ->
185 repr inp vs a
186
187 -- ** Class 'InstrIterable'
188 class InstrIterable (repr::ReprInstr) where
189 -- | @('iter' loop done)@.
190 iter ::
191 LetName a ->
192 repr inp '[] a ->
193 repr inp (Cursor inp ': vs) a ->
194 repr inp vs a
195
196 -- ** Class 'InstrRegisterable'
197 class InstrRegisterable (repr::ReprInstr) where
198 newRegister ::
199 UnscopedRegister v ->
200 repr inp vs a ->
201 repr inp (v : vs) a
202 readRegister ::
203 UnscopedRegister v ->
204 repr inp (v : vs) a ->
205 repr inp vs a
206 writeRegister ::
207 UnscopedRegister v ->
208 repr inp vs a ->
209 repr inp (v : vs) a
210
211 -- | @('modifyRegister' reg k)@
212 -- modifies the content of register @(reg)@
213 -- with the function at the 'valueStackHead',
214 -- then continues with @(k)@.
215 modifyRegister ::
216 InstrRegisterable repr =>
217 InstrValuable repr =>
218 UnscopedRegister v -> repr inp vs a -> repr inp ((v -> v) : vs) a
219 modifyRegister r = readRegister r . applyValue . writeRegister r