]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Optimize.hs
b1b36ae0dcf32648655681092c6bf9fe7db39354
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Optimize.hs
1 {-# LANGUAGE PatternSynonyms #-} -- For Comb
2 {-# LANGUAGE TemplateHaskell #-} -- For branch
3 {-# LANGUAGE ViewPatterns #-} -- For unSimplComb
4 {-# OPTIONS_GHC -fno-warn-orphans #-} -- For MakeLetName TH.Name
5 -- | Bottom-up optimization of 'Comb'inators,
6 -- reexamining downward as needed after each optimization.
7 module Symantic.Parser.Grammar.Optimize where
8
9 import Data.Bool (Bool(..), (&&), not)
10 import Data.Bifunctor (second)
11 import Data.Either (Either(..), either)
12 import Data.Eq (Eq(..))
13 import Data.Function (($), (.))
14 import Data.Kind (Constraint)
15 import Data.Maybe (Maybe(..))
16 import Data.Set (Set)
17 import Data.Functor.Identity (Identity(..))
18 import Unsafe.Coerce (unsafeCoerce)
19 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
20 import Data.Semigroup (Semigroup(..))
21 import qualified Data.Foldable as Foldable
22 import qualified Data.Functor as F
23 import qualified Data.HashMap.Strict as HM
24 import qualified Data.HashSet as HS
25 import Data.Hashable (Hashable)
26 import qualified Language.Haskell.TH as TH
27
28 import Symantic.Parser.Grammar.Combinators
29 import Symantic.Parser.Grammar.Production
30 import Symantic.Parser.Grammar.SharingObserver
31 import Symantic.Syntaxes.Derive
32 import qualified Symantic.Syntaxes.Classes as Prod
33 import qualified Symantic.Semantics.Data as Prod
34
35 {-
36 import Data.Function (($), flip)
37 import Debug.Trace (trace)
38
39 (&) = flip ($)
40 infix 0 &
41 -}
42 type OptimizeGrammar = KnotComb TH.Name
43
44 -- | TODO: remove useless wrapping?
45 newtype TiedComb repr a = TiedComb
46 { combSimpl :: SimplComb repr a
47 --, combRefs :: HS.HashSet letName
48 }
49
50 -- * Type 'KnotComb'
51 data KnotComb letName repr a = KnotComb
52 { knotCombOpens :: OpenRecs letName (SomeLet (TiedComb repr))
53 -- ^ 'TiedComb' for all 'letName' in 'lets'.
54 , knotCombOpen ::
55 LetRecs letName (SomeLet (TiedComb repr)) ->
56 TiedComb repr a
57 -- ^ 'TiedComb' of the current combinator,
58 -- with access to the final 'knotCombOpens'.
59 }
60
61 optimizeGrammar ::
62 Derivable (SimplComb repr) =>
63 KnotComb TH.Name repr a -> repr a
64 optimizeGrammar = derive . derive
65
66 type instance Derived (KnotComb letName repr) = SimplComb repr
67 instance Derivable (KnotComb letName repr) where
68 derive opt = combSimpl $
69 knotCombOpen opt (mutualFix (knotCombOpens opt))
70 instance LiftDerived (KnotComb letName repr) where
71 liftDerived x = KnotComb
72 { knotCombOpens = HM.empty
73 , knotCombOpen = \_final -> TiedComb
74 { combSimpl = x
75 }
76 }
77 instance LiftDerived1 (KnotComb letName repr) where
78 liftDerived1 f a = a
79 { knotCombOpen = \final -> TiedComb
80 { combSimpl = f (combSimpl (knotCombOpen a final))
81 }
82 }
83 instance (Eq letName, Hashable letName) => LiftDerived2 (KnotComb letName repr) where
84 liftDerived2 f a b = KnotComb
85 { knotCombOpens = knotCombOpens a <> knotCombOpens b
86 , knotCombOpen = \final -> TiedComb
87 { combSimpl = f
88 (combSimpl (knotCombOpen a final))
89 (combSimpl (knotCombOpen b final))
90 }
91 }
92 instance (Eq letName, Hashable letName) => LiftDerived3 (KnotComb letName repr) where
93 liftDerived3 f a b c = KnotComb
94 { knotCombOpens = HM.unions
95 [ knotCombOpens a
96 , knotCombOpens b
97 , knotCombOpens c
98 ]
99 , knotCombOpen = \final -> TiedComb
100 { combSimpl = f
101 (combSimpl (knotCombOpen a final))
102 (combSimpl (knotCombOpen b final))
103 (combSimpl (knotCombOpen c final))
104 }
105 }
106 instance (Eq letName, Hashable letName) => LiftDerived4 (KnotComb letName repr) where
107 liftDerived4 f a b c d = KnotComb
108 { knotCombOpens = HM.unions
109 [ knotCombOpens a
110 , knotCombOpens b
111 , knotCombOpens c
112 , knotCombOpens d
113 ]
114 , knotCombOpen = \final -> TiedComb
115 { combSimpl = f
116 (combSimpl (knotCombOpen a final))
117 (combSimpl (knotCombOpen b final))
118 (combSimpl (knotCombOpen c final))
119 (combSimpl (knotCombOpen d final))
120 }
121 }
122
123 -- * Data family 'Comb'
124 -- | 'Comb'inators of the 'Grammar'.
125 -- This is an extensible data-type.
126 data family Comb
127 (comb :: ReprComb -> Constraint)
128 :: ReprComb -> ReprComb
129 type instance Derived (Comb comb repr) = repr
130
131 -- | 'unsafeCoerce' restrained to 'SimplComb'.
132 -- Useful to avoid dependant-map when inlining.
133 unsafeSimplComb :: SimplComb repr a -> SimplComb repr b
134 unsafeSimplComb = unsafeCoerce
135
136 -- | Convenient utility to pattern-match a 'SimplComb'.
137 pattern Comb :: Typeable comb => Comb comb repr a -> SimplComb repr a
138 pattern Comb x <- (unSimplComb -> Just x)
139
140 -- ** Type 'SimplComb'
141 -- | Interpreter simplifying combinators.
142 -- Useful to handle a list of 'Comb'inators
143 -- without requiring impredicative quantification.
144 -- Must be used by pattern-matching
145 -- on the 'SimplComb' data-constructor,
146 -- to bring the constraints in scope.
147 --
148 -- The optimizations are directly applied within it,
149 -- to avoid introducing an extra newtype,
150 -- this also give a more understandable code.
151 data SimplComb repr a =
152 forall comb.
153 (Derivable (Comb comb repr), Typeable comb) =>
154 SimplComb
155 { combData :: Comb comb repr a
156 -- ^ Some 'Comb'inator existentialized
157 -- over the actual combinator symantic class.
158 , combInline :: Bool
159 -- ^ Whether this combinator must be inlined
160 -- in place of a 'ref'erence pointing to it
161 -- (instead of generating a 'call').
162 , combRefs :: HS.HashSet TH.Name
163 -- ^ 'ref''s names reacheable from combinator
164 -- (including those behind 'ref's).
165 }
166
167 type instance Derived (SimplComb repr) = repr
168 instance Derivable (SimplComb repr) where
169 derive SimplComb{..} = derive combData
170
171 -- | @(unSimplComb c :: 'Maybe' ('Comb' comb repr a))@
172 -- extract the data-constructor from the given 'SimplComb'
173 -- iif. it belongs to the @('Comb' comb repr a)@ data-instance.
174 unSimplComb ::
175 forall comb repr a.
176 Typeable comb =>
177 SimplComb repr a -> Maybe (Comb comb repr a)
178 unSimplComb SimplComb{ combData = c :: Comb c repr a } =
179 case typeRep @comb `eqTypeRep` typeRep @c of
180 Just HRefl -> Just c
181 Nothing -> Nothing
182
183 -- CombAlternable
184 data instance Comb CombAlternable repr a where
185 Alt :: Exception -> SimplComb repr a -> SimplComb repr a -> Comb CombAlternable repr a
186 Empty :: Comb CombAlternable repr a
187 Failure :: SomeFailure -> Comb CombAlternable repr a
188 Throw :: ExceptionLabel -> Comb CombAlternable repr a
189 Try :: SimplComb repr a -> Comb CombAlternable repr a
190 instance CombAlternable repr => Derivable (Comb CombAlternable repr) where
191 derive = \case
192 Alt exn x y -> alt exn (derive x) (derive y)
193 Empty -> empty
194 Failure sf -> failure sf
195 Throw exn -> throw exn
196 Try x -> try (derive x)
197 instance
198 ( CombAlternable repr
199 , CombApplicable repr
200 , CombLookable repr
201 , CombMatchable repr
202 , CombSelectable repr
203 ) => CombAlternable (SimplComb repr) where
204 empty = SimplComb
205 { combData = Empty
206 , combInline = True
207 , combRefs = HS.empty
208 }
209 failure sf = SimplComb
210 { combData = Failure sf
211 , combInline = True
212 , combRefs = HS.empty
213 }
214
215 alt _exn p@(Comb Pure{}) _ = p
216 -- & trace "Left Catch Law"
217 alt _exn (Comb Empty) u = u
218 -- & trace "Left Neutral Law"
219 alt _exn u (Comb Empty) = u
220 -- & trace "Right Neutral Law"
221 alt exn (Comb (Alt exn' u v)) w | exn' == exn = u <|> (v <|> w)
222 -- See Lemma 1 (Associativity of choice for labeled PEGs)
223 -- in https://doi.org/10.1145/2851613.2851750
224 -- & trace "Associativity Law"
225 alt exn (Comb (Look p)) (Comb (Look q)) = look (alt exn (try p) q)
226 -- & trace "Distributivity Law"
227 alt exn x y = SimplComb
228 { combData = Alt exn x y
229 , combInline = False
230 , combRefs = combRefs x <> combRefs y
231 }
232
233 throw exn = SimplComb
234 { combData = Throw exn
235 , combInline = True
236 , combRefs = HS.empty
237 }
238
239 try (Comb (p :$>: x)) = try p $> x
240 -- & trace "Try Interchange Law"
241 try (Comb (f :<$>: p)) = f <$> try p
242 -- & trace "Try Interchange Law"
243 try x = SimplComb
244 { combData = Try x
245 , combInline = False
246 , combRefs = combRefs x
247 }
248 instance
249 ( CombApplicable repr
250 , CombAlternable repr
251 , CombLookable repr
252 , CombMatchable repr
253 , CombSelectable repr
254 , Eq letName
255 , Hashable letName
256 ) => CombAlternable (KnotComb letName repr)
257
258 -- CombApplicable
259 data instance Comb CombApplicable repr a where
260 Pure :: Production '[] a -> Comb CombApplicable repr a
261 (:<*>:) :: SimplComb repr (a -> b) -> SimplComb repr a -> Comb CombApplicable repr b
262 (:<*:) :: SimplComb repr a -> SimplComb repr b -> Comb CombApplicable repr a
263 (:*>:) :: SimplComb repr a -> SimplComb repr b -> Comb CombApplicable repr b
264 infixl 4 :<*>:, :<*:, :*>:
265 pattern (:<$>:) :: Production '[] (a -> b) -> SimplComb repr a -> Comb CombApplicable repr b
266 pattern t :<$>: x <- Comb (Pure t) :<*>: x
267 pattern (:$>:) :: SimplComb repr a -> Production '[] b -> Comb CombApplicable repr b
268 pattern x :$>: t <- x :*>: Comb (Pure t)
269 instance CombApplicable repr => Derivable (Comb CombApplicable repr) where
270 derive = \case
271 Pure x -> pure x
272 f :<*>: x -> derive f <*> derive x
273 x :<*: y -> derive x <* derive y
274 x :*>: y -> derive x *> derive y
275 instance
276 ( CombApplicable repr
277 , CombAlternable repr
278 , CombLookable repr
279 , CombMatchable repr
280 , CombSelectable repr
281 ) => CombApplicable (SimplComb repr) where
282 pure a = SimplComb
283 { combData = Pure a
284 , combInline = False -- TODO: maybe True?
285 , combRefs = HS.empty
286 }
287 f <$> Comb (Branch b l r) =
288 branch b
289 ((Prod..) Prod..@ f <$> l)
290 ((Prod..) Prod..@ f <$> r)
291 -- & trace "Branch Distributivity Law"
292 f <$> Comb (Conditional a bs def) =
293 conditional a
294 (second (f <$>) F.<$> bs)
295 (f <$> def)
296 -- & trace "Conditional Distributivity Law"
297 -- Being careful here to use (<*>),
298 -- instead of SimplComb { combData = f <$> combData x },
299 -- in order to apply the optimizations of (<*>).
300 f <$> x = pure f <*> x
301
302 x <$ u = u $> x
303 -- & trace "Commutativity Law"
304
305 Comb Empty <*> _ = empty
306 -- & trace "App Right Absorption Law"
307 u <*> Comb Empty = u *> empty
308 -- & trace "App Failure Weakening Law"
309 Comb (Pure f) <*> Comb (Pure x) = pure (f Prod..@ x)
310 -- & trace "Homomorphism Law"
311 {-
312 Comb (Pure f) <*> Comb (g :<$>: p) =
313 -- This is basically a shortcut,
314 -- it can be caught by one Composition Law
315 -- and two Homomorphism Law.
316 (Prod..) Prod..@ f Prod..@ g <$> p
317 -- & trace "Functor Composition Law"
318 -}
319 u <*> Comb (Pure x) = Prod.flip Prod..@ (Prod.$) Prod..@ x <$> u
320 -- & trace "Interchange Law"
321 u <*> Comb (v :<*>: w) = (((Prod..) <$> u) <*> v) <*> w
322 -- & trace "Composition Law"
323 Comb (u :*>: v) <*> w = u *> (v <*> w)
324 -- & trace "Reassociation Law 1"
325 u <*> Comb (v :<*: w) = (u <*> v) <* w
326 -- & trace "Reassociation Law 2"
327 u <*> Comb (v :$>: x) = (u <*> pure x) <* v
328 -- & trace "Reassociation Law 3"
329 p <*> Comb (NegLook q) =
330 (p <*> pure Prod.unit) <* negLook q
331 -- & trace "Absorption Law"
332 x <*> y = SimplComb
333 { combData = x :<*>: y
334 , combInline = False
335 , combRefs = combRefs x <> combRefs y
336 }
337
338 Comb Empty *> _ = empty
339 -- & trace "App Right Absorption Law"
340 Comb (_ :<$>: p) *> q = p *> q
341 -- & trace "Right Absorption Law"
342 Comb Pure{} *> u = u
343 -- & trace "Identity Law"
344 Comb (u :$>: _) *> v = u *> v
345 -- & trace "Identity Law"
346 u *> Comb (v :*>: w) = (u *> v) *> w
347 -- & trace "Associativity Law"
348 x *> y = SimplComb
349 { combData = x :*>: y
350 , combInline = False
351 , combRefs = combRefs x <> combRefs y
352 }
353
354 Comb Empty <* _ = empty
355 -- & trace "App Right Absorption Law"
356 u <* Comb Empty = u *> empty
357 -- & trace "App Failure Weakening Law"
358 p <* Comb (_ :<$>: q) = p <* q
359 -- & trace "Left Absorption Law"
360 u <* Comb Pure{} = u
361 -- & trace "Identity Law"
362 u <* Comb (v :$>: _) = u <* v
363 -- & trace "Identity Law"
364 Comb (u :<*: v) <* w = u <* (v <* w)
365 -- & trace "Associativity Law"
366 x <* y = SimplComb
367 { combData = x :<*: y
368 , combInline = False
369 , combRefs = combRefs x <> combRefs y
370 }
371 instance
372 ( CombApplicable repr
373 , CombAlternable repr
374 , CombLookable repr
375 , CombMatchable repr
376 , CombSelectable repr
377 , Eq letName
378 , Hashable letName
379 ) => CombApplicable (KnotComb letName repr)
380
381 -- CombFoldable
382 data instance Comb CombFoldable repr a where
383 ChainPre :: SimplComb repr (a -> a) -> SimplComb repr a -> Comb CombFoldable repr a
384 ChainPost :: SimplComb repr a -> SimplComb repr (a -> a) -> Comb CombFoldable repr a
385 instance CombFoldable repr => Derivable (Comb CombFoldable repr) where
386 derive = \case
387 ChainPre op p -> chainPre (derive op) (derive p)
388 ChainPost p op -> chainPost (derive p) (derive op)
389 instance CombFoldable repr => CombFoldable (SimplComb repr) where
390 chainPre op p = SimplComb
391 { combData = ChainPre op p
392 , combInline = False
393 , combRefs = combRefs op <> combRefs p
394 }
395 chainPost p op = SimplComb
396 { combData = ChainPost p op
397 , combInline = False
398 , combRefs = combRefs p <> combRefs op
399 }
400 instance
401 ( CombFoldable repr
402 , Eq letName
403 , Hashable letName
404 ) => CombFoldable (KnotComb letName repr)
405
406 -- CombLookable
407 data instance Comb CombLookable repr a where
408 Look :: SimplComb repr a -> Comb CombLookable repr a
409 NegLook :: SimplComb repr a -> Comb CombLookable repr ()
410 Eof :: Comb CombLookable repr ()
411 instance CombLookable repr => Derivable (Comb CombLookable repr) where
412 derive = \case
413 Look x -> look (derive x)
414 NegLook x -> negLook (derive x)
415 Eof -> eof
416 instance
417 ( CombAlternable repr
418 , CombApplicable repr
419 , CombLookable repr
420 , CombSelectable repr
421 , CombMatchable repr
422 ) => CombLookable (SimplComb repr) where
423 look p@(Comb Pure{}) = p
424 -- & trace "Pure Look Law"
425 look p@(Comb Empty) = p
426 -- & trace "Dead Look Law"
427 look (Comb (Look x)) = look x
428 -- & trace "Idempotence Law"
429 look (Comb (NegLook x)) = negLook x
430 -- & trace "Left Identity Law"
431 look (Comb (p :$>: x)) = look p $> x
432 -- & trace "Interchange Law"
433 look (Comb (f :<$>: p)) = f <$> look p
434 -- & trace "Interchange Law"
435 look x = SimplComb
436 { combData = Look x
437 , combInline = False
438 , combRefs = combRefs x
439 }
440
441 negLook (Comb Pure{}) = empty
442 -- & trace "Pure Negative-Look"
443 negLook (Comb Empty) = pure Prod.unit
444 -- & trace "Dead Negative-Look"
445 negLook (Comb (NegLook x)) = look (try x *> pure Prod.unit)
446 -- & trace "Double Negation Law"
447 negLook (Comb (Try x)) = negLook x
448 -- & trace "Zero Consumption Law"
449 negLook (Comb (Look x)) = negLook x
450 -- & trace "Right Identity Law"
451 negLook (Comb (Alt _exn (Comb (Try p)) q)) = negLook p *> negLook q
452 -- FIXME: see if this really holds for all exceptions.
453 -- & trace "Transparency Law"
454 negLook (Comb (p :$>: _)) = negLook p
455 -- & trace "NegLook Idempotence Law"
456 negLook x = SimplComb
457 { combData = NegLook x
458 , combInline = False
459 , combRefs = combRefs x
460 }
461
462 eof = SimplComb
463 { combData = Eof
464 , combInline = True
465 , combRefs = HS.empty
466 }
467 instance
468 ( CombLookable repr
469 , CombAlternable repr
470 , CombApplicable repr
471 , CombSelectable repr
472 , CombMatchable repr
473 , Eq letName
474 , Hashable letName
475 ) => CombLookable (KnotComb letName repr)
476
477 -- CombMatchable
478 data instance Comb CombMatchable repr a where
479 Conditional ::
480 SimplComb repr a ->
481 [(Production '[] (a -> Bool), SimplComb repr b)] ->
482 SimplComb repr b ->
483 Comb CombMatchable repr b
484 instance CombMatchable repr => Derivable (Comb CombMatchable repr) where
485 derive = \case
486 Conditional a bs def ->
487 conditional (derive a)
488 ((\(p, b) -> (p, derive b)) F.<$> bs)
489 (derive def)
490 instance
491 ( CombApplicable repr
492 , CombAlternable repr
493 , CombLookable repr
494 , CombSelectable repr
495 , CombMatchable repr
496 ) => CombMatchable (SimplComb repr) where
497 conditional (Comb Empty) _ def = def
498 -- & trace "Conditional Absorption Law"
499 conditional a bs (Comb Empty)
500 | Foldable.all (\case { (_, Comb Empty) -> True; _ -> False }) bs = a *> empty
501 -- & trace "Conditional Weakening Law"
502 conditional (Comb (Pure a)) bs def =
503 Foldable.foldr (\(p, b) acc ->
504 if runValue (p Prod..@ a) then b else acc
505 ) def bs
506 -- & trace "Conditional Pure Law"
507 conditional a bs d = SimplComb
508 { combData = Conditional a bs d
509 , combInline = False
510 , combRefs = HS.unions
511 $ combRefs a
512 : combRefs d
513 : ((\(_p, b) -> combRefs b) F.<$> bs)
514 }
515 instance
516 ( CombMatchable repr
517 , CombAlternable repr
518 , CombApplicable repr
519 , CombLookable repr
520 , CombSelectable repr
521 , Eq letName
522 , Hashable letName
523 ) => CombMatchable (KnotComb letName repr) where
524 conditional a bs d = KnotComb
525 { knotCombOpens = HM.unions
526 $ knotCombOpens a
527 : knotCombOpens d
528 : ((\(_p, b) -> knotCombOpens b) F.<$> bs)
529 , knotCombOpen = \final -> TiedComb
530 { combSimpl = conditional
531 (combSimpl (knotCombOpen a final))
532 ((\(p, b) -> (p, combSimpl (knotCombOpen b final))) F.<$> bs)
533 (combSimpl (knotCombOpen d final))
534 }
535 }
536
537 -- CombSatisfiable
538 data instance Comb (CombSatisfiable tok) repr a where
539 -- | To include the @('Set' 'SomeFailure')@ is a little kludge
540 -- it would be cleaner to be able to pattern-match
541 -- on @(alt exn (Comb 'Satisfy'{}) (Failure{}))@
542 -- when generating 'Program', but this is not easily possible then
543 -- because data types have already been converted back to class methods,
544 -- hence pattern-matching is no longer possible
545 -- (at least not without reintroducing data types).
546 SatisfyOrFail ::
547 CombSatisfiable tok repr =>
548 Set SomeFailure ->
549 Production '[] (tok -> Bool) ->
550 Comb (CombSatisfiable tok) repr tok
551 instance
552 CombSatisfiable tok repr =>
553 Derivable (Comb (CombSatisfiable tok) repr) where
554 derive = \case
555 SatisfyOrFail fs p -> satisfyOrFail fs p
556 instance
557 (CombSatisfiable tok repr, Typeable tok) =>
558 CombSatisfiable tok (SimplComb repr) where
559 satisfyOrFail fs p = SimplComb
560 { combData = SatisfyOrFail fs p
561 , combInline = False -- TODO: True? depending on p?
562 , combRefs = HS.empty
563 }
564 instance
565 ( CombSatisfiable tok repr
566 , Typeable tok
567 , Eq letName
568 , Hashable letName
569 ) => CombSatisfiable tok (KnotComb letName repr)
570
571 -- CombSelectable
572 data instance Comb CombSelectable repr a where
573 Branch ::
574 SimplComb repr (Either a b) ->
575 SimplComb repr (a -> c) ->
576 SimplComb repr (b -> c) ->
577 Comb CombSelectable repr c
578 instance CombSelectable repr => Derivable (Comb CombSelectable repr) where
579 derive = \case
580 Branch lr l r -> branch (derive lr) (derive l) (derive r)
581 instance
582 ( CombApplicable repr
583 , CombAlternable repr
584 , CombLookable repr
585 , CombSelectable repr
586 , CombMatchable repr
587 ) => CombSelectable (SimplComb repr) where
588 branch (Comb Empty) _ _ = empty
589 -- & trace "Branch Absorption Law"
590 branch b (Comb Empty) (Comb Empty) = b *> empty
591 -- & trace "Branch Weakening Law"
592 branch (Comb (Pure lr)) l r =
593 case runValue lr of
594 Left value -> l <*> pure (ProdE (Prod v c))
595 where
596 v = Prod.SomeData $ Prod.Var $ Identity value
597 c = Prod.SomeData $ Prod.Var
598 [|| case $$(runCode lr) of Left x -> x ||]
599 Right value -> r <*> pure (ProdE (Prod v c))
600 where
601 v = Prod.SomeData $ Prod.Var $ Identity value
602 c = Prod.SomeData $ Prod.Var
603 [|| case $$(runCode lr) of Right x -> x ||]
604 -- & trace "Branch Pure Either Law"
605 branch b (Comb (Pure l)) (Comb (Pure r)) =
606 ProdE (Prod v c) <$> b
607 -- & trace "Branch Generalised Identity Law"
608 where
609 v = Prod.SomeData $ Prod.Var $ Identity $ either (runValue l) (runValue r)
610 c = Prod.SomeData $ Prod.Var [|| either $$(runCode l) $$(runCode r) ||]
611 branch (Comb (x :*>: y)) p q = x *> branch y p q
612 -- & trace "Interchange Law"
613 branch b l (Comb Empty) =
614 branch (pure (ProdE (Prod v c)) <*> b) empty l
615 -- & trace "Negated Branch Law"
616 where
617 v = Prod.SomeData $ Prod.Var $ Identity $ either Right Left
618 c = Prod.SomeData $ Prod.Var $ [||either Right Left||]
619 branch (Comb (Branch b (Comb Empty) (Comb (Pure lr)))) (Comb Empty) br =
620 branch (pure (ProdE (Prod v c)) <*> b) empty br
621 -- & trace "Branch Fusion Law"
622 where
623 v = Prod.SomeData $ Prod.Var $ Identity $ \case
624 Left{} -> Left ()
625 Right r ->
626 case runValue lr r of
627 Left{} -> Left ()
628 Right rr -> Right rr
629 c = Prod.SomeData $ Prod.Var
630 [|| \case Left{} -> Left ()
631 Right r -> case $$(runCode lr) r of
632 Left{} -> Left ()
633 Right rr -> Right rr ||]
634 branch b l r = SimplComb
635 { combData = Branch b l r
636 , combInline = False
637 , combRefs = HS.unions [ combRefs b, combRefs l, combRefs r ]
638 }
639 instance
640 ( CombSelectable repr
641 , CombAlternable repr
642 , CombApplicable repr
643 , CombLookable repr
644 , CombMatchable repr
645 , Eq letName
646 , Hashable letName
647 ) => CombSelectable (KnotComb letName repr)
648
649 -- CombRegisterableUnscoped
650 data instance Comb CombRegisterableUnscoped repr a where
651 NewUnscoped :: UnscopedRegister a -> SimplComb repr a -> SimplComb repr b -> Comb CombRegisterableUnscoped repr b
652 GetUnscoped :: UnscopedRegister a -> Comb CombRegisterableUnscoped repr a
653 PutUnscoped :: UnscopedRegister a -> SimplComb repr a -> Comb CombRegisterableUnscoped repr ()
654 instance CombRegisterableUnscoped repr => Derivable (Comb CombRegisterableUnscoped repr) where
655 derive = \case
656 NewUnscoped r ini x -> newUnscoped r (derive ini) (derive x)
657 GetUnscoped r -> getUnscoped r
658 PutUnscoped r x -> putUnscoped r (derive x)
659 instance -- TODO: optimizations
660 ( CombRegisterableUnscoped repr
661 ) => CombRegisterableUnscoped (SimplComb repr) where
662 newUnscoped r ini x = SimplComb
663 { combData = NewUnscoped r ini x
664 , combInline = combInline ini && combInline x
665 , combRefs = combRefs ini <> combRefs x
666 }
667 getUnscoped r = SimplComb
668 { combData = GetUnscoped r
669 , combInline = True
670 , combRefs = HS.empty
671 }
672 putUnscoped r x = SimplComb
673 { combData = PutUnscoped r x
674 , combInline = combInline x
675 , combRefs = combRefs x
676 }
677 instance
678 ( CombRegisterableUnscoped repr
679 , Eq letName
680 , Hashable letName
681 ) => CombRegisterableUnscoped (KnotComb letName repr) where
682
683 -- Letsable
684 data instance Comb (Letsable letName) repr a where
685 Lets ::
686 LetBindings letName (SimplComb repr) ->
687 SimplComb repr a ->
688 Comb (Letsable letName) repr a
689 instance
690 Letsable letName repr =>
691 Derivable (Comb (Letsable letName) repr) where
692 derive = \case
693 Lets defs x -> lets
694 ((\(SomeLet sub) -> SomeLet (derive sub)) F.<$> defs)
695 (derive x)
696 instance
697 (Letsable letName repr, Typeable letName) =>
698 Letsable letName (SimplComb repr) where
699 lets defs body = SimplComb
700 { combData = Lets defs body
701 , combInline = False
702 , combRefs = HS.unions
703 $ combRefs body
704 : ((\(SomeLet sub) -> combRefs sub) F.<$> HM.elems defs)
705 }
706 instance
707 Letsable TH.Name repr =>
708 Letsable TH.Name (KnotComb TH.Name repr) where
709 lets defs body = KnotComb
710 { knotCombOpens =
711 HM.unions
712 $ knotCombOpens body
713 : ((\(SomeLet sub) -> SomeLet . knotCombOpen sub) F.<$> defs)
714 -- Not really necessary to include 'knotCombOpens' of 'defs' here
715 -- since there is only a single 'lets' at the top of the AST,
716 -- but well.
717 : ((\(SomeLet sub) -> knotCombOpens sub) F.<$> HM.elems defs)
718 , knotCombOpen = \final -> TiedComb
719 { combSimpl =
720 let bodySimpl = combSimpl $ knotCombOpen body final in
721 let defsSimpl = (\(SomeLet sub) -> SomeLet $ combSimpl $ knotCombOpen sub final) F.<$> defs in
722 let defsUsed = HS.unions
723 $ combRefs bodySimpl
724 : ((\(SomeLet sub) -> combRefs sub) F.<$> HM.elems defsSimpl) in
725 lets (HM.intersection defsSimpl (HS.toMap defsUsed)) bodySimpl
726 }
727 }
728
729 -- Referenceable
730 data instance Comb (Referenceable letName) repr a where
731 Ref :: Bool -> letName -> Comb (Referenceable letName) repr a
732 instance
733 Referenceable letName repr =>
734 Derivable (Comb (Referenceable letName) repr) where
735 derive = \case
736 Ref isRec name -> ref isRec name
737 instance
738 Referenceable TH.Name repr =>
739 Referenceable TH.Name (SimplComb repr) where
740 ref isRec name = SimplComb
741 { combData = Ref isRec name
742 , combInline = not isRec
743 , combRefs = HS.singleton name
744 }
745 instance
746 Referenceable TH.Name repr =>
747 Referenceable TH.Name (KnotComb TH.Name repr) where
748 ref isRec name = KnotComb
749 { knotCombOpens = HM.empty
750 , knotCombOpen = \final ->
751 if isRec
752 then TiedComb
753 { combSimpl = ref isRec name
754 }
755 else case final HM.! name of
756 SomeLet a@TiedComb
757 { combSimpl = p@SimplComb{ combInline = True }
758 } -> a{combSimpl = unsafeSimplComb p}
759 SomeLet TiedComb
760 { combSimpl = SimplComb{ combRefs = refs }
761 } -> TiedComb
762 { combSimpl = (ref isRec name)
763 { combRefs = HS.insert name refs }
764 }
765 }