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