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     }