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