]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Instructions.hs
machine: optimize ifThenElse on constant
[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 qualified Language.Haskell.TH as TH
17
18 import Symantic.Parser.Grammar
19 import Symantic.Parser.Machine.Input
20 import qualified Symantic.Typed.Lang as Prod
21 import qualified Symantic.Typed.Data as Sym
22
23 -- * Type 'Splice'
24 type Splice = Sym.SomeData TH.CodeQ
25
26 -- | Lift a 'TH.CodeQ' into a 'Sym.SomeData'.
27 splice :: TH.CodeQ a -> Splice a
28 splice x = Sym.SomeData (Sym.Var x)
29
30 -- ** Type 'ReprInstr'
31 type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
32
33 -- ** Type 'LetName'
34 -- | 'TH.Name' of a 'defLet' or 'defJoin'
35 -- indexed by the return type of the factorized 'Instr'uctions.
36 -- This helps type-inferencing.
37 newtype LetName a = LetName { unLetName :: TH.Name }
38 deriving Eq
39 deriving newtype Show
40
41 -- ** Class 'InstrValuable'
42 class InstrValuable (repr::ReprInstr) where
43 -- | @('pushValue' x k)@ pushes @(x)@ on the 'valueStack'
44 -- and continues with the next 'Instr'uction @(k)@.
45 pushValue ::
46 Splice v ->
47 repr inp (v ': vs) a ->
48 repr inp vs a
49 -- | @('popValue' k)@ pushes @(x)@ on the 'valueStack'.
50 popValue ::
51 repr inp vs a ->
52 repr inp (v ': vs) a
53 -- | @('lift2Value' f k)@ pops two values from the 'valueStack',
54 -- and pushes the result of @(f)@ applied to them.
55 lift2Value ::
56 Splice (x -> y -> z) ->
57 repr inp (z ': vs) a ->
58 repr inp (y ': x ': vs) a
59 -- | @('swapValue' k)@ pops two values on the 'valueStack',
60 -- pushes the first popped-out, then the second,
61 -- and continues with the next 'Instr'uction @(k)@.
62 swapValue ::
63 repr inp (x ': y ': vs) a ->
64 repr inp (y ': x ': vs) a
65 -- | @('mapValue' f k)@.
66 mapValue ::
67 Splice (x -> y) ->
68 repr inp (y ': vs) a ->
69 repr inp (x ': vs) a
70 mapValue f = pushValue f . lift2Value (Prod.flip Prod..@ (Prod.$))
71 -- | @('applyValue' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
72 -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
73 applyValue ::
74 repr inp (y ': vs) a ->
75 repr inp (x ': (x -> y) ': vs) a
76 applyValue = lift2Value (Prod.$)
77
78 -- ** Class 'InstrExceptionable'
79 class InstrExceptionable (repr::ReprInstr) where
80 -- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
81 raise :: ExceptionLabel -> repr inp vs a
82 -- | @('fail' fs)@ raises 'ExceptionFailure' @(exn)@.
83 -- As a special case, giving an empty 'Set' of failures
84 -- raises 'ExceptionFailure' without using the current position
85 -- to update the farthest error.
86 fail :: Set SomeFailure -> repr inp vs a
87 -- | @('commit' exn k)@ removes the 'Catcher'
88 -- from the 'catchStackByLabel' for the given 'Exception' @(exn)@,
89 -- and continues with the next 'Instr'uction @(k)@.
90 commit :: Exception -> repr inp vs a -> repr inp vs a
91 -- | @('catch' exn l r)@ tries the @(l)@ 'Instr'uction
92 -- in a new failure scope such that if @(l)@ raises an exception within @(exn)@, it is caught,
93 -- then the input (and its 'Horizon') is pushed as it was before trying @(l)@ on the 'valueStack',
94 -- and the control flow goes on with the @(r)@ 'Instr'uction.
95 catch ::
96 Exception ->
97 {-scope-}repr inp vs ret ->
98 {-catcher-}repr inp (Cursor inp ': vs) ret ->
99 repr inp vs ret
100
101 -- ** Class 'InstrBranchable'
102 class InstrBranchable (repr::ReprInstr) where
103 -- | @('caseBranch' l r)@.
104 caseBranch ::
105 repr inp (x ': vs) r ->
106 repr inp (y ': vs) r ->
107 repr inp (Either x y ': vs) r
108 -- | @('choicesBranch' ps bs d)@.
109 choicesBranch ::
110 [Splice (v -> Bool)] ->
111 [repr inp vs a] ->
112 repr inp vs a ->
113 repr inp (v ': vs) a
114 -- | @('ifBranch' ok ko)@ pops a 'Bool' from the 'valueStack'
115 -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
116 -- or @(ko)@ otherwise.
117 ifBranch ::
118 repr inp vs a ->
119 repr inp vs a ->
120 repr inp (Bool ': vs) a
121 ifBranch ok ko = choicesBranch [Prod.id] [ok] ko
122
123 -- ** Class 'InstrCallable'
124 class InstrCallable (repr::ReprInstr) where
125 -- | @('defLet' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,
126 -- 'Call's @(n)@ and
127 -- continues with the next 'Instr'uction @(k)@.
128 defLet ::
129 LetBindings TH.Name (repr inp '[]) ->
130 repr inp vs a ->
131 repr inp vs a
132 -- | @('call' n k)@ pass the control-flow to the 'DefLet' named @(n)@,
133 -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
134 call ::
135 LetName v -> repr inp (v ': vs) a ->
136 repr inp vs a
137 -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
138 ret ::
139 repr inp '[a] a
140 -- | @('jump' n k)@ pass the control-flow to the 'DefLet' named @(n)@.
141 jump ::
142 LetName a ->
143 repr inp '[] a
144
145 -- ** Class 'InstrJoinable'
146 class InstrJoinable (repr::ReprInstr) where
147 defJoin ::
148 LetName v -> repr inp (v ': vs) a ->
149 repr inp vs a ->
150 repr inp vs a
151 refJoin ::
152 LetName v ->
153 repr inp (v ': vs) a
154
155 -- ** Class 'InstrInputable'
156 class InstrInputable (repr::ReprInstr) where
157 -- | @('pushInput' k)@ pushes the input @(inp)@ on the 'valueStack'
158 -- and continues with the next 'Instr'uction @(k)@.
159 pushInput ::
160 repr inp (Cursor inp ': vs) a ->
161 repr inp vs a
162 -- | @('loadInput' k)@ removes the input from the 'valueStack'
163 -- and continues with the next 'Instr'uction @(k)@ using that input.
164 loadInput ::
165 repr inp vs a ->
166 repr inp (Cursor inp ': vs) a
167
168 -- ** Class 'InstrReadable'
169 class InstrReadable (tok::Type) (repr::ReprInstr) where
170 -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
171 -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
172 -- otherwise 'fail'.
173 read ::
174 tok ~ InputToken inp =>
175 Set SomeFailure ->
176 Splice (tok -> Bool) ->
177 repr inp (tok ': vs) a ->
178 repr inp vs a