]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Instructions.hs
remove useless benchmarks
[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.Ord (Ord(..))
15 import Data.Set (Set)
16 import Text.Show (Show(..), showParen, showString)
17 import qualified Language.Haskell.TH as TH
18 import qualified Language.Haskell.TH.Show as TH
19
20 import Symantic.Parser.Grammar
21 import Symantic.Parser.Machine.Input
22 import qualified Symantic.Univariant.Lang as H
23 import qualified Symantic.Univariant.Trans as Sym
24 import qualified Symantic.Univariant.Data as Sym
25
26 -- * Type 'Splice'
27 type Splice = Sym.SomeData TH.CodeQ
28
29 instance Show (Splice a) where
30 showsPrec p = showParen (p >= 0) . showString . TH.showCode . Sym.trans
31
32 splice :: TH.CodeQ a -> Splice a
33 splice x = Sym.SomeData (Sym.Var x)
34
35 -- ** Type 'ReprInstr'
36 type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
37
38 -- ** Type 'LetName'
39 -- | 'TH.Name' of a 'defLet' or 'defJoin'
40 -- indexed by the return type of the factorized 'Instr'uctions.
41 -- This helps type-inferencing.
42 newtype LetName a = LetName { unLetName :: TH.Name }
43 deriving Eq
44 deriving newtype Show
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 (H.flip H..@ (H.$))
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 (H.$)
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 'catchStackByLabel' 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 as it was before trying @(l)@ on the 'valueStack',
99 -- and the control flow goes on with the @(r)@ 'Instr'uction.
100 catch ::
101 Exception ->
102 {-scope-}repr inp vs ret ->
103 {-catcher-}repr inp (Cursor inp ': vs) ret ->
104 repr inp vs ret
105
106 -- ** Class 'InstrBranchable'
107 class InstrBranchable (repr::ReprInstr) where
108 -- | @('caseBranch' l r)@.
109 caseBranch ::
110 repr inp (x ': vs) r ->
111 repr inp (y ': vs) r ->
112 repr inp (Either x y ': vs) r
113 -- | @('choicesBranch' ps bs d)@.
114 choicesBranch ::
115 [Splice (v -> Bool)] ->
116 [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 [H.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' 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 LetName v -> repr inp (v ': vs) a ->
141 repr inp vs a
142 -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
143 ret ::
144 repr inp '[a] a
145 -- | @('jump' n k)@ pass the control-flow to the 'DefLet' named @(n)@.
146 jump ::
147 LetName a ->
148 repr inp '[] a
149
150 -- ** Class 'InstrJoinable'
151 class InstrJoinable (repr::ReprInstr) where
152 defJoin ::
153 LetName v -> repr inp (v ': vs) a ->
154 repr inp vs a ->
155 repr inp vs a
156 refJoin ::
157 LetName v ->
158 repr inp (v ': vs) a
159
160 -- ** Class 'InstrInputable'
161 class InstrInputable (repr::ReprInstr) where
162 -- | @('pushInput' k)@ pushes the input @(inp)@ on the 'valueStack'
163 -- and continues with the next 'Instr'uction @(k)@.
164 pushInput ::
165 repr inp (Cursor inp ': vs) a ->
166 repr inp vs a
167 -- | @('loadInput' k)@ removes the input from the 'valueStack'
168 -- and continues with the next 'Instr'uction @(k)@ using that input.
169 loadInput ::
170 repr inp vs a ->
171 repr inp (Cursor inp ': vs) a
172
173 -- ** Class 'InstrReadable'
174 class InstrReadable (tok::Type) (repr::ReprInstr) where
175 -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
176 -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
177 -- otherwise 'fail'.
178 read ::
179 tok ~ InputToken inp =>
180 Set SomeFailure ->
181 Splice (tok -> Bool) ->
182 repr inp (tok ': vs) a ->
183 repr inp vs a