]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Optimize.hs
impl: add attoparsec's Text.Buffer
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Optimize.hs
1 {-# LANGUAGE PatternSynonyms #-} -- For Instr
2 {-# LANGUAGE ViewPatterns #-} -- For unSomeInstr
3 -- | Initial encoding with bottom-up optimizations of 'Instr'uctions,
4 -- re-optimizing downward as needed after each optimization.
5 -- There is only one optimization (for 'pushValue') so far,
6 -- but the introspection enabled by the 'Instr' data-type
7 -- is also useful to optimize with more context in the 'Machine'.
8 module Symantic.Parser.Machine.Optimize where
9
10 import Data.Bool (Bool(..))
11 import Data.Either (Either)
12 import Data.Function ((.))
13 import Data.Kind (Constraint)
14 import Data.Maybe (Maybe(..))
15 import Data.Set (Set)
16 import Data.String (String)
17 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
18 import qualified Data.Functor as Functor
19 import qualified Language.Haskell.TH as TH
20
21 import Symantic.Derive
22 import Symantic.Parser.Grammar
23 import Symantic.Parser.Machine.Input
24 import Symantic.Parser.Machine.Instructions
25
26 -- * Data family 'Instr'
27 -- | 'Instr'uctions of the 'Machine'.
28 -- This is an extensible data-type.
29 data family Instr
30 (instr :: ReprInstr -> Constraint)
31 :: ReprInstr -> ReprInstr
32 type instance Derived (Instr instr repr inp vs) = repr inp vs
33
34 -- | Convenient utility to pattern-match a 'SomeInstr'.
35 pattern Instr :: Typeable comb =>
36 Instr comb repr inp vs a ->
37 SomeInstr repr inp vs a
38 pattern Instr x <- (unSomeInstr -> Just x)
39
40 -- ** Type 'SomeInstr'
41 -- | Some 'Instr'uction existentialized over the actual instruction symantic class.
42 -- Useful to handle a list of 'Instr'uctions
43 -- without requiring impredicative quantification.
44 -- Must be used by pattern-matching
45 -- on the 'SomeInstr' data-constructor,
46 -- to bring the constraints in scope.
47 --
48 -- As in 'SomeComb', a first pass of optimizations
49 -- is directly applied in it
50 -- to avoid introducing an extra newtype,
51 -- this also gives a more undestandable code.
52 data SomeInstr repr inp vs a =
53 forall instr.
54 ( Derivable (Instr instr repr inp vs)
55 , Typeable instr
56 ) => SomeInstr (Instr instr repr inp vs a)
57
58 type instance Derived (SomeInstr repr inp vs) = repr inp vs
59 instance Derivable (SomeInstr repr inp vs) where
60 derive (SomeInstr x) = derive x
61
62 -- | @(unSomeInstr i :: 'Maybe' ('Instr' comb repr inp vs a))@
63 -- extract the data-constructor from the given 'SomeInstr'
64 -- iif. it belongs to the @('Instr' comb repr a)@ data-instance.
65 unSomeInstr ::
66 forall instr repr inp vs a.
67 Typeable instr =>
68 SomeInstr repr inp vs a ->
69 Maybe (Instr instr repr inp vs a)
70 unSomeInstr (SomeInstr (i::Instr i repr inp vs a)) =
71 case typeRep @instr `eqTypeRep` typeRep @i of
72 Just HRefl -> Just i
73 Nothing ->
74 case typeRep @InstrComment `eqTypeRep` typeRep @i of
75 Just HRefl | Comment _msg x <- i -> unSomeInstr x
76 Nothing -> Nothing
77
78 -- InstrComment
79 data instance Instr InstrComment repr inp vs a where
80 Comment ::
81 String ->
82 SomeInstr repr inp vs a ->
83 Instr InstrComment repr inp vs a
84 instance InstrComment repr => Derivable (Instr InstrComment repr inp vs) where
85 derive = \case
86 Comment msg k -> comment msg (derive k)
87 instance InstrComment repr => InstrComment (SomeInstr repr) where
88 comment msg = SomeInstr . Comment msg
89
90 -- InstrValuable
91 data instance Instr InstrValuable repr inp vs a where
92 PushValue ::
93 Splice v ->
94 SomeInstr repr inp (v ': vs) a ->
95 Instr InstrValuable repr inp vs a
96 PopValue ::
97 SomeInstr repr inp vs a ->
98 Instr InstrValuable repr inp (v ': vs) a
99 Lift2Value ::
100 Splice (x -> y -> z) ->
101 SomeInstr repr inp (z : vs) a ->
102 Instr InstrValuable repr inp (y : x : vs) a
103 SwapValue ::
104 SomeInstr repr inp (x ': y ': vs) a ->
105 Instr InstrValuable repr inp (y ': x ': vs) a
106 instance InstrValuable repr => Derivable (Instr InstrValuable repr inp vs) where
107 derive = \case
108 PushValue v k -> pushValue v (derive k)
109 PopValue k -> popValue (derive k)
110 Lift2Value v k -> lift2Value v (derive k)
111 SwapValue k -> swapValue (derive k)
112 instance InstrValuable repr => InstrValuable (SomeInstr repr) where
113 -- 'PopValue' after a 'PushValue' is a no-op.
114 pushValue _v (Instr (PopValue i)) = i
115 pushValue v i = SomeInstr (PushValue v i)
116 popValue = SomeInstr . PopValue
117 lift2Value f = SomeInstr . Lift2Value f
118 swapValue = SomeInstr . SwapValue
119
120 -- InstrExceptionable
121 data instance Instr InstrExceptionable repr inp vs a where
122 Raise ::
123 ExceptionLabel ->
124 Instr InstrExceptionable repr inp vs a
125 Fail ::
126 Set SomeFailure ->
127 Instr InstrExceptionable repr inp vs a
128 Commit ::
129 Exception ->
130 SomeInstr repr inp vs ret ->
131 Instr InstrExceptionable repr inp vs ret
132 Catch ::
133 Exception ->
134 SomeInstr repr inp vs ret ->
135 SomeInstr repr inp (Cursor inp ': vs) ret ->
136 Instr InstrExceptionable repr inp vs ret
137 instance InstrExceptionable repr => Derivable (Instr InstrExceptionable repr inp vs) where
138 derive = \case
139 Raise exn -> raise exn
140 Fail fs -> fail fs
141 Commit exn k -> commit exn (derive k)
142 Catch exn l r -> catch exn (derive l) (derive r)
143 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
144 raise = SomeInstr . Raise
145 fail = SomeInstr . Fail
146 commit exn = SomeInstr . Commit exn
147 catch exn x = SomeInstr . Catch exn x
148
149 -- InstrBranchable
150 data instance Instr InstrBranchable repr inp vs a where
151 CaseBranch ::
152 SomeInstr repr inp (x ': vs) a ->
153 SomeInstr repr inp (y ': vs) a ->
154 Instr InstrBranchable repr inp (Either x y ': vs) a
155 ChoicesBranch ::
156 [(Splice (v -> Bool), SomeInstr repr inp vs a)] ->
157 SomeInstr repr inp vs a ->
158 Instr InstrBranchable repr inp (v ': vs) a
159 instance InstrBranchable repr => Derivable (Instr InstrBranchable repr inp vs) where
160 derive = \case
161 CaseBranch l r -> caseBranch (derive l) (derive r)
162 ChoicesBranch bs d -> choicesBranch ((\(p,b) -> (p, derive b)) Functor.<$> bs) (derive d)
163 instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
164 caseBranch l = SomeInstr . CaseBranch l
165 choicesBranch bs = SomeInstr . ChoicesBranch bs
166
167 -- InstrCallable
168 data instance Instr InstrCallable repr inp vs a where
169 DefLet ::
170 LetBindings TH.Name (SomeInstr repr inp '[]) ->
171 SomeInstr repr inp vs a ->
172 Instr InstrCallable repr inp vs a
173 Call ::
174 Bool ->
175 LetName v ->
176 SomeInstr repr inp (v ': vs) a ->
177 Instr InstrCallable repr inp vs a
178 Ret ::
179 Instr InstrCallable repr inp '[a] a
180 Jump ::
181 Bool ->
182 LetName a ->
183 Instr InstrCallable repr inp '[] a
184 instance InstrCallable repr => Derivable (Instr InstrCallable repr inp vs) where
185 derive = \case
186 DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (derive sub)) Functor.<$> subs) (derive k)
187 Jump isRec n -> jump isRec n
188 Call isRec n k -> call isRec n (derive k)
189 Ret -> ret
190 instance InstrCallable repr => InstrCallable (SomeInstr repr) where
191 defLet subs = SomeInstr . DefLet subs
192 jump isRec = SomeInstr . Jump isRec
193 call isRec n = SomeInstr . Call isRec n
194 ret = SomeInstr Ret
195
196 -- InstrJoinable
197 data instance Instr InstrJoinable repr inp vs a where
198 DefJoin ::
199 LetName v ->
200 SomeInstr repr inp (v ': vs) a ->
201 SomeInstr repr inp vs a ->
202 Instr InstrJoinable repr inp vs a
203 RefJoin ::
204 LetName v ->
205 Instr InstrJoinable repr inp (v ': vs) a
206 instance InstrJoinable repr => Derivable (Instr InstrJoinable repr inp vs) where
207 derive = \case
208 DefJoin n sub k -> defJoin n (derive sub) (derive k)
209 RefJoin n -> refJoin n
210 instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
211 defJoin n sub = SomeInstr . DefJoin n sub
212 refJoin = SomeInstr . RefJoin
213
214 -- InstrInputable
215 data instance Instr InstrInputable repr inp vs a where
216 PushInput ::
217 SomeInstr repr inp (Cursor inp ': vs) a ->
218 Instr InstrInputable repr inp vs a
219 LoadInput ::
220 SomeInstr repr inp vs a ->
221 Instr InstrInputable repr inp (Cursor inp ': vs) a
222 instance InstrInputable repr => Derivable (Instr InstrInputable repr inp vs) where
223 derive = \case
224 PushInput k -> saveInput (derive k)
225 LoadInput k -> loadInput (derive k)
226 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
227 saveInput = SomeInstr . PushInput
228 loadInput = SomeInstr . LoadInput
229
230 -- InstrReadable
231 data instance Instr (InstrReadable tok) repr inp vs a where
232 Read ::
233 Set SomeFailure ->
234 Splice (InputToken inp -> Bool) ->
235 SomeInstr repr inp (InputToken inp ': vs) a ->
236 Instr (InstrReadable tok) repr inp vs a
237 instance
238 ( InstrReadable tok repr, tok ~ InputToken inp ) =>
239 Derivable (Instr (InstrReadable tok) repr inp vs) where
240 derive = \case
241 Read fs p k -> read fs p (derive k)
242 instance
243 ( InstrReadable tok repr, Typeable tok ) =>
244 InstrReadable tok (SomeInstr repr) where
245 read fs p = SomeInstr . Read fs p
246
247 -- InstrIterable
248 data instance Instr InstrIterable repr inp vs a where
249 Iter ::
250 LetName a ->
251 SomeInstr repr inp '[] a ->
252 SomeInstr repr inp (Cursor inp ': vs) a ->
253 Instr InstrIterable repr inp vs a
254 instance
255 InstrIterable repr =>
256 Derivable (Instr InstrIterable repr inp vs) where
257 derive = \case
258 Iter n op k -> iter n (derive op) (derive k)
259 instance
260 InstrIterable repr =>
261 InstrIterable (SomeInstr repr) where
262 iter n op = SomeInstr . Iter n op
263
264 -- InstrRegisterable
265 data instance Instr InstrRegisterable repr inp vs a where
266 NewRegister ::
267 UnscopedRegister v ->
268 SomeInstr repr inp vs a ->
269 Instr InstrRegisterable repr inp (v : vs) a
270 ReadRegister ::
271 UnscopedRegister v ->
272 SomeInstr repr inp (v : vs) a ->
273 Instr InstrRegisterable repr inp vs a
274 WriteRegister ::
275 UnscopedRegister v ->
276 SomeInstr repr inp vs a ->
277 Instr InstrRegisterable repr inp (v : vs) a
278 instance
279 InstrRegisterable repr =>
280 Derivable (Instr InstrRegisterable repr inp vs) where
281 derive = \case
282 NewRegister r k -> newRegister r (derive k)
283 ReadRegister r k -> readRegister r (derive k)
284 WriteRegister r k -> writeRegister r (derive k)
285 instance
286 InstrRegisterable repr =>
287 InstrRegisterable (SomeInstr repr) where
288 newRegister r = SomeInstr . NewRegister r
289 readRegister r = SomeInstr . ReadRegister r
290 writeRegister r = SomeInstr . WriteRegister r