{-# LANGUAGE PatternSynonyms #-} -- For Comb
{-# LANGUAGE TemplateHaskell #-} -- For branch
-{-# LANGUAGE ViewPatterns #-} -- For unSomeComb
+{-# LANGUAGE ViewPatterns #-} -- For unSimplComb
{-# OPTIONS_GHC -fno-warn-orphans #-} -- For MakeLetName TH.Name
-- | Bottom-up optimization of 'Comb'inators,
-- reexamining downward as needed after each optimization.
module Symantic.Parser.Grammar.Optimize where
-import Data.Bool (Bool(..))
+import Data.Bool (Bool(..), (&&), not)
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Functor.Identity (Identity(..))
+import Data.Functor.Product (Product(..))
+import Unsafe.Coerce (unsafeCoerce)
import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
+import Data.Semigroup (Semigroup(..))
import qualified Data.Foldable as Foldable
-import qualified Data.Functor as Functor
-import qualified Data.List as List
+import qualified Data.Functor as F
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+import Data.Hashable (Hashable)
+import qualified Language.Haskell.TH as TH
-import Symantic.Parser.Grammar.Combinators hiding (code)
-import qualified Symantic.Parser.Grammar.Production as Prod
+import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.Production
-import Symantic.Univariant.Letable
-import Symantic.Univariant.Trans
-import qualified Symantic.Univariant.Lang as H
-import qualified Symantic.Univariant.Data as H
+import Symantic.Parser.Grammar.ObserveSharing
+import Symantic.Derive
+import qualified Symantic.Class as Prod
+import qualified Symantic.Data as Prod
{-
import Data.Function (($), flip)
(&) = flip ($)
infix 0 &
-}
+type OptimizeGrammar = KnotComb TH.Name
--- * Type 'OptimizeGrammar'
-type OptimizeGrammar = SomeComb
+-- | TODO: remove useless wrapping?
+newtype TiedComb repr a = TiedComb
+ { combSimpl :: SimplComb repr a
+ --, combRefs :: HS.HashSet letName
+ }
+
+-- * Type 'KnotComb'
+data KnotComb letName repr a = KnotComb
+ { knotCombOpens :: OpenRecs letName (SomeLet (TiedComb repr))
+ -- ^ 'TiedComb' for all 'letName' in 'lets'.
+ , knotCombOpen ::
+ LetRecs letName (SomeLet (TiedComb repr)) ->
+ TiedComb repr a
+ -- ^ 'TiedComb' of the current combinator,
+ -- with access to the final 'knotCombOpens'.
+ }
optimizeGrammar ::
- Trans (SomeComb repr) repr =>
- SomeComb repr a -> repr a
-optimizeGrammar = trans
+ Derivable (SimplComb repr) =>
+ KnotComb TH.Name repr a -> repr a
+optimizeGrammar = derive . derive
+
+type instance Derived (KnotComb letName repr) = SimplComb repr
+instance Derivable (KnotComb letName repr) where
+ derive opt = combSimpl $
+ knotCombOpen opt (mutualFix (knotCombOpens opt))
+instance LiftDerived (KnotComb letName repr) where
+ liftDerived x = KnotComb
+ { knotCombOpens = HM.empty
+ , knotCombOpen = \_final -> TiedComb
+ { combSimpl = x
+ }
+ }
+instance LiftDerived1 (KnotComb letName repr) where
+ liftDerived1 f a = a
+ { knotCombOpen = \final -> TiedComb
+ { combSimpl = f (combSimpl (knotCombOpen a final))
+ }
+ }
+instance (Eq letName, Hashable letName) => LiftDerived2 (KnotComb letName repr) where
+ liftDerived2 f a b = KnotComb
+ { knotCombOpens = knotCombOpens a <> knotCombOpens b
+ , knotCombOpen = \final -> TiedComb
+ { combSimpl = f
+ (combSimpl (knotCombOpen a final))
+ (combSimpl (knotCombOpen b final))
+ }
+ }
+instance (Eq letName, Hashable letName) => LiftDerived3 (KnotComb letName repr) where
+ liftDerived3 f a b c = KnotComb
+ { knotCombOpens = HM.unions
+ [ knotCombOpens a
+ , knotCombOpens b
+ , knotCombOpens c
+ ]
+ , knotCombOpen = \final -> TiedComb
+ { combSimpl = f
+ (combSimpl (knotCombOpen a final))
+ (combSimpl (knotCombOpen b final))
+ (combSimpl (knotCombOpen c final))
+ }
+ }
+instance (Eq letName, Hashable letName) => LiftDerived4 (KnotComb letName repr) where
+ liftDerived4 f a b c d = KnotComb
+ { knotCombOpens = HM.unions
+ [ knotCombOpens a
+ , knotCombOpens b
+ , knotCombOpens c
+ , knotCombOpens d
+ ]
+ , knotCombOpen = \final -> TiedComb
+ { combSimpl = f
+ (combSimpl (knotCombOpen a final))
+ (combSimpl (knotCombOpen b final))
+ (combSimpl (knotCombOpen c final))
+ (combSimpl (knotCombOpen d final))
+ }
+ }
-- * Data family 'Comb'
-- | 'Comb'inators of the 'Grammar'.
data family Comb
(comb :: ReprComb -> Constraint)
:: ReprComb -> ReprComb
+type instance Derived (Comb comb repr) = repr
--- | Convenient utility to pattern-match a 'SomeComb'.
-pattern Comb :: Typeable comb => Comb comb repr a -> SomeComb repr a
-pattern Comb x <- (unSomeComb -> Just x)
+-- | 'unsafeCoerce' restrained to 'SimplComb'.
+-- Useful to avoid dependant-map when inlining.
+unsafeSimplComb :: SimplComb repr a -> SimplComb repr b
+unsafeSimplComb = unsafeCoerce
--- ** Type 'SomeComb'
--- | Some 'Comb'inator existentialized over the actual combinator symantic class.
+-- | Convenient utility to pattern-match a 'SimplComb'.
+pattern Comb :: Typeable comb => Comb comb repr a -> SimplComb repr a
+pattern Comb x <- (unSimplComb -> Just x)
+
+-- ** Type 'SimplComb'
+-- | Interpreter simplifying combinators.
-- Useful to handle a list of 'Comb'inators
-- without requiring impredicative quantification.
-- Must be used by pattern-matching
--- on the 'SomeComb' data-constructor,
+-- on the 'SimplComb' data-constructor,
-- to bring the constraints in scope.
--
-- The optimizations are directly applied within it,
-- to avoid introducing an extra newtype,
-- this also give a more understandable code.
-data SomeComb repr a =
+data SimplComb repr a =
forall comb.
- (Trans (Comb comb repr) repr, Typeable comb) =>
- SomeComb (Comb comb repr a)
+ (Derivable (Comb comb repr), Typeable comb) =>
+ SimplComb
+ { combData :: Comb comb repr a
+ -- ^ Some 'Comb'inator existentialized
+ -- over the actual combinator symantic class.
+ , combInline :: Bool
+ -- ^ Whether this combinator must be inlined
+ -- in place of a 'ref'erence pointing to it
+ -- (instead of generating a 'call').
+ , combRefs :: HS.HashSet TH.Name
+ -- ^ 'ref''s names reacheable from combinator
+ -- (including those behind 'ref's).
+ }
-instance Trans (SomeComb repr) repr where
- trans (SomeComb x) = trans x
+type instance Derived (SimplComb repr) = repr
+instance Derivable (SimplComb repr) where
+ derive SimplComb{..} = derive combData
--- | @(unSomeComb c :: 'Maybe' ('Comb' comb repr a))@
--- extract the data-constructor from the given 'SomeComb'
+-- | @(unSimplComb c :: 'Maybe' ('Comb' comb repr a))@
+-- extract the data-constructor from the given 'SimplComb'
-- iif. it belongs to the @('Comb' comb repr a)@ data-instance.
-unSomeComb ::
+unSimplComb ::
forall comb repr a.
Typeable comb =>
- SomeComb repr a -> Maybe (Comb comb repr a)
-unSomeComb (SomeComb (c::Comb c repr a)) =
+ SimplComb repr a -> Maybe (Comb comb repr a)
+unSimplComb SimplComb{ combData = c :: Comb c repr a } =
case typeRep @comb `eqTypeRep` typeRep @c of
Just HRefl -> Just c
Nothing -> Nothing
-- CombAlternable
data instance Comb CombAlternable repr a where
- Alt :: Exception -> SomeComb repr a -> SomeComb repr a -> Comb CombAlternable repr a
+ Alt :: Exception -> SimplComb repr a -> SimplComb repr a -> Comb CombAlternable repr a
Empty :: Comb CombAlternable repr a
Failure :: SomeFailure -> Comb CombAlternable repr a
Throw :: ExceptionLabel -> Comb CombAlternable repr a
- Try :: SomeComb repr a -> Comb CombAlternable repr a
-instance CombAlternable repr => Trans (Comb CombAlternable repr) repr where
- trans = \case
- Alt exn x y -> alt exn (trans x) (trans y)
+ Try :: SimplComb repr a -> Comb CombAlternable repr a
+instance CombAlternable repr => Derivable (Comb CombAlternable repr) where
+ derive = \case
+ Alt exn x y -> alt exn (derive x) (derive y)
Empty -> empty
Failure sf -> failure sf
Throw exn -> throw exn
- Try x -> try (trans x)
+ Try x -> try (derive x)
instance
( CombAlternable repr
, CombApplicable repr
, CombLookable repr
, CombMatchable repr
, CombSelectable repr
- ) => CombAlternable (SomeComb repr) where
- empty = SomeComb Empty
- failure sf = SomeComb (Failure sf)
+ ) => CombAlternable (SimplComb repr) where
+ empty = SimplComb
+ { combData = Empty
+ , combInline = True
+ , combRefs = HS.empty
+ }
+ failure sf = SimplComb
+ { combData = Failure sf
+ , combInline = True
+ , combRefs = HS.empty
+ }
alt _exn p@(Comb Pure{}) _ = p
-- & trace "Left Catch Law"
-- & trace "Associativity Law"
alt exn (Comb (Look p)) (Comb (Look q)) = look (alt exn (try p) q)
-- & trace "Distributivity Law"
- alt exn x y = SomeComb (Alt exn x y)
+ alt exn x y = SimplComb
+ { combData = Alt exn x y
+ , combInline = False
+ , combRefs = combRefs x <> combRefs y
+ }
- throw exn = SomeComb (Throw exn)
+ throw exn = SimplComb
+ { combData = Throw exn
+ , combInline = True
+ , combRefs = HS.empty
+ }
try (Comb (p :$>: x)) = try p $> x
-- & trace "Try Interchange Law"
try (Comb (f :<$>: p)) = f <$> try p
-- & trace "Try Interchange Law"
- try x = SomeComb (Try x)
+ try x = SimplComb
+ { combData = Try x
+ , combInline = False
+ , combRefs = combRefs x
+ }
+instance
+ ( CombApplicable repr
+ , CombAlternable repr
+ , CombLookable repr
+ , CombMatchable repr
+ , CombSelectable repr
+ , Eq letName
+ , Hashable letName
+ ) => CombAlternable (KnotComb letName repr)
-- CombApplicable
data instance Comb CombApplicable repr a where
Pure :: Production a -> Comb CombApplicable repr a
- (:<*>:) :: SomeComb repr (a -> b) -> SomeComb repr a -> Comb CombApplicable repr b
- (:<*:) :: SomeComb repr a -> SomeComb repr b -> Comb CombApplicable repr a
- (:*>:) :: SomeComb repr a -> SomeComb repr b -> Comb CombApplicable repr b
+ (:<*>:) :: SimplComb repr (a -> b) -> SimplComb repr a -> Comb CombApplicable repr b
+ (:<*:) :: SimplComb repr a -> SimplComb repr b -> Comb CombApplicable repr a
+ (:*>:) :: SimplComb repr a -> SimplComb repr b -> Comb CombApplicable repr b
infixl 4 :<*>:, :<*:, :*>:
-pattern (:<$>:) :: Production (a -> b) -> SomeComb repr a -> Comb CombApplicable repr b
+pattern (:<$>:) :: Production (a -> b) -> SimplComb repr a -> Comb CombApplicable repr b
pattern t :<$>: x <- Comb (Pure t) :<*>: x
-pattern (:$>:) :: SomeComb repr a -> Production b -> Comb CombApplicable repr b
+pattern (:$>:) :: SimplComb repr a -> Production b -> Comb CombApplicable repr b
pattern x :$>: t <- x :*>: Comb (Pure t)
-instance CombApplicable repr => Trans (Comb CombApplicable repr) repr where
- trans = \case
- Pure x -> pure (optimizeProduction x)
- f :<*>: x -> trans f <*> trans x
- x :<*: y -> trans x <* trans y
- x :*>: y -> trans x *> trans y
+instance CombApplicable repr => Derivable (Comb CombApplicable repr) where
+ derive = \case
+ Pure x -> pure x
+ f :<*>: x -> derive f <*> derive x
+ x :<*: y -> derive x <* derive y
+ x :*>: y -> derive x *> derive y
instance
( CombApplicable repr
, CombAlternable repr
, CombLookable repr
, CombMatchable repr
, CombSelectable repr
- ) => CombApplicable (SomeComb repr) where
- pure = SomeComb . Pure
+ ) => CombApplicable (SimplComb repr) where
+ pure a = SimplComb
+ { combData = Pure a
+ , combInline = False -- TODO: maybe True?
+ , combRefs = HS.empty
+ }
f <$> Comb (Branch b l r) =
branch b
- ((H..) H..@ f <$> l)
- ((H..) H..@ f <$> r)
+ ((Prod..) Prod..@ f <$> l)
+ ((Prod..) Prod..@ f <$> r)
-- & trace "Branch Distributivity Law"
- f <$> Comb (Conditional a ps bs d) =
- conditional a ps
- ((f <$>) Functor.<$> bs)
- (f <$> d)
+ f <$> Comb (Conditional a bs def) =
+ conditional a
+ ((\(p, b) -> (p, f <$> b)) F.<$> bs)
+ (f <$> def)
-- & trace "Conditional Distributivity Law"
-- Being careful here to use (<*>),
- -- instead of SomeComb (f <$> unOptComb x),
+ -- instead of SimplComb { combData = f <$> combData x },
-- in order to apply the optimizations of (<*>).
f <$> x = pure f <*> x
-- & trace "App Right Absorption Law"
u <*> Comb Empty = u *> empty
-- & trace "App Failure Weakening Law"
- Comb (Pure f) <*> Comb (Pure x) = pure (f H..@ x)
+ Comb (Pure f) <*> Comb (Pure x) = pure (f Prod..@ x)
-- & trace "Homomorphism Law"
{-
Comb (Pure f) <*> Comb (g :<$>: p) =
-- This is basically a shortcut,
-- it can be caught by one Composition Law
-- and two Homomorphism Law.
- (H..) H..@ f H..@ g <$> p
+ (Prod..) Prod..@ f Prod..@ g <$> p
-- & trace "Functor Composition Law"
-}
- u <*> Comb (Pure x) = H.flip H..@ (H.$) H..@ x <$> u
+ u <*> Comb (Pure x) = Prod.flip Prod..@ (Prod.$) Prod..@ x <$> u
-- & trace "Interchange Law"
- u <*> Comb (v :<*>: w) = (((H..) <$> u) <*> v) <*> w
+ u <*> Comb (v :<*>: w) = (((Prod..) <$> u) <*> v) <*> w
-- & trace "Composition Law"
Comb (u :*>: v) <*> w = u *> (v <*> w)
-- & trace "Reassociation Law 1"
u <*> Comb (v :$>: x) = (u <*> pure x) <* v
-- & trace "Reassociation Law 3"
p <*> Comb (NegLook q) =
- (p <*> pure H.unit) <* negLook q
+ (p <*> pure Prod.unit) <* negLook q
-- & trace "Absorption Law"
- x <*> y = SomeComb (x :<*>: y)
+ x <*> y = SimplComb
+ { combData = x :<*>: y
+ , combInline = False
+ , combRefs = combRefs x <> combRefs y
+ }
Comb Empty *> _ = empty
-- & trace "App Right Absorption Law"
-- & trace "Identity Law"
u *> Comb (v :*>: w) = (u *> v) *> w
-- & trace "Associativity Law"
- x *> y = SomeComb (x :*>: y)
+ x *> y = SimplComb
+ { combData = x :*>: y
+ , combInline = False
+ , combRefs = combRefs x <> combRefs y
+ }
Comb Empty <* _ = empty
-- & trace "App Right Absorption Law"
-- & trace "Identity Law"
Comb (u :<*: v) <* w = u <* (v <* w)
-- & trace "Associativity Law"
- x <* y = SomeComb (x :<*: y)
+ x <* y = SimplComb
+ { combData = x :<*: y
+ , combInline = False
+ , combRefs = combRefs x <> combRefs y
+ }
+instance
+ ( CombApplicable repr
+ , CombAlternable repr
+ , CombLookable repr
+ , CombMatchable repr
+ , CombSelectable repr
+ , Eq letName
+ , Hashable letName
+ ) => CombApplicable (KnotComb letName repr)
-- CombFoldable
data instance Comb CombFoldable repr a where
- ChainPreC :: SomeComb repr (a -> a) -> SomeComb repr a -> Comb CombFoldable repr a
- ChainPostC :: SomeComb repr a -> SomeComb repr (a -> a) -> Comb CombFoldable repr a
-instance CombFoldable repr => Trans (Comb CombFoldable repr) repr where
- trans = \case
- ChainPreC x y -> chainPre (trans x) (trans y)
- ChainPostC x y -> chainPost (trans x) (trans y)
-instance CombFoldable repr => CombFoldable (SomeComb repr) where
- chainPre x = SomeComb . ChainPreC x
- chainPost x = SomeComb . ChainPostC x
-
--- Letable
-data instance Comb (Letable letName) repr a where
- Shareable :: letName -> SomeComb repr a -> Comb (Letable letName) repr a
- Ref :: Bool -> letName -> Comb (Letable letName) repr a
-instance
- Letable letName repr =>
- Trans (Comb (Letable letName) repr) repr where
- trans = \case
- Shareable n x -> shareable n (trans x)
- Ref isRec n -> ref isRec n
+ ChainPre :: SimplComb repr (a -> a) -> SimplComb repr a -> Comb CombFoldable repr a
+ ChainPost :: SimplComb repr a -> SimplComb repr (a -> a) -> Comb CombFoldable repr a
+instance CombFoldable repr => Derivable (Comb CombFoldable repr) where
+ derive = \case
+ ChainPre op p -> chainPre (derive op) (derive p)
+ ChainPost p op -> chainPost (derive p) (derive op)
+instance CombFoldable repr => CombFoldable (SimplComb repr) where
+ chainPre op p = SimplComb
+ { combData = ChainPre op p
+ , combInline = False
+ , combRefs = combRefs op <> combRefs p
+ }
+ chainPost p op = SimplComb
+ { combData = ChainPost p op
+ , combInline = False
+ , combRefs = combRefs p <> combRefs op
+ }
instance
- (Letable letName repr, Typeable letName) =>
- Letable letName (SomeComb repr) where
- shareable n = SomeComb . Shareable n
- ref isRec = SomeComb . Ref isRec
-
--- Letsable
-data instance Comb (Letsable letName) repr a where
- Lets :: LetBindings letName (SomeComb repr) ->
- SomeComb repr a -> Comb (Letsable letName) repr a
-instance
- Letsable letName repr =>
- Trans (Comb (Letsable letName) repr) repr where
- trans = \case
- Lets defs x -> lets ((\(SomeLet sub) -> SomeLet (trans sub)) Functor.<$> defs) (trans x)
-instance
- (Letsable letName repr, Typeable letName) =>
- Letsable letName (SomeComb repr) where
- lets defs = SomeComb . Lets defs
+ ( CombFoldable repr
+ , Eq letName
+ , Hashable letName
+ ) => CombFoldable (KnotComb letName repr)
-- CombLookable
data instance Comb CombLookable repr a where
- Look :: SomeComb repr a -> Comb CombLookable repr a
- NegLook :: SomeComb repr a -> Comb CombLookable repr ()
+ Look :: SimplComb repr a -> Comb CombLookable repr a
+ NegLook :: SimplComb repr a -> Comb CombLookable repr ()
Eof :: Comb CombLookable repr ()
-instance CombLookable repr => Trans (Comb CombLookable repr) repr where
- trans = \case
- Look x -> look (trans x)
- NegLook x -> negLook (trans x)
+instance CombLookable repr => Derivable (Comb CombLookable repr) where
+ derive = \case
+ Look x -> look (derive x)
+ NegLook x -> negLook (derive x)
Eof -> eof
instance
( CombAlternable repr
, CombLookable repr
, CombSelectable repr
, CombMatchable repr
- ) => CombLookable (SomeComb repr) where
+ ) => CombLookable (SimplComb repr) where
look p@(Comb Pure{}) = p
-- & trace "Pure Look Law"
look p@(Comb Empty) = p
-- & trace "Interchange Law"
look (Comb (f :<$>: p)) = f <$> look p
-- & trace "Interchange Law"
- look x = SomeComb (Look x)
+ look x = SimplComb
+ { combData = Look x
+ , combInline = False
+ , combRefs = combRefs x
+ }
negLook (Comb Pure{}) = empty
-- & trace "Pure Negative-Look"
- negLook (Comb Empty) = pure H.unit
+ negLook (Comb Empty) = pure Prod.unit
-- & trace "Dead Negative-Look"
- negLook (Comb (NegLook x)) = look (try x *> pure H.unit)
+ negLook (Comb (NegLook x)) = look (try x *> pure Prod.unit)
-- & trace "Double Negation Law"
negLook (Comb (Try x)) = negLook x
-- & trace "Zero Consumption Law"
-- & trace "Transparency Law"
negLook (Comb (p :$>: _)) = negLook p
-- & trace "NegLook Idempotence Law"
- negLook x = SomeComb (NegLook x)
+ negLook x = SimplComb
+ { combData = NegLook x
+ , combInline = False
+ , combRefs = combRefs x
+ }
- eof = SomeComb Eof
+ eof = SimplComb
+ { combData = Eof
+ , combInline = True
+ , combRefs = HS.empty
+ }
+instance
+ ( CombLookable repr
+ , CombAlternable repr
+ , CombApplicable repr
+ , CombSelectable repr
+ , CombMatchable repr
+ , Eq letName
+ , Hashable letName
+ ) => CombLookable (KnotComb letName repr)
-- CombMatchable
data instance Comb CombMatchable repr a where
- Conditional :: Eq a =>
- SomeComb repr a ->
- [Production (a -> Bool)] ->
- [SomeComb repr b] ->
- SomeComb repr b ->
+ Conditional ::
+ SimplComb repr a ->
+ [(Production (a -> Bool), SimplComb repr b)] ->
+ SimplComb repr b ->
Comb CombMatchable repr b
-instance CombMatchable repr => Trans (Comb CombMatchable repr) repr where
- trans = \case
- Conditional a ps bs b ->
- conditional (trans a)
- (optimizeProduction Functor.<$> ps)
- (trans Functor.<$> bs) (trans b)
+instance CombMatchable repr => Derivable (Comb CombMatchable repr) where
+ derive = \case
+ Conditional a bs def ->
+ conditional (derive a)
+ ((\(p, b) -> (p, derive b)) F.<$> bs)
+ (derive def)
instance
( CombApplicable repr
, CombAlternable repr
, CombLookable repr
, CombSelectable repr
, CombMatchable repr
- ) => CombMatchable (SomeComb repr) where
- conditional (Comb Empty) _ _ d = d
+ ) => CombMatchable (SimplComb repr) where
+ conditional (Comb Empty) _ def = def
-- & trace "Conditional Absorption Law"
- conditional p _ qs (Comb Empty)
- | Foldable.all (\case { Comb Empty -> True; _ -> False }) qs = p *> empty
- -- & trace "Conditional Weakening Law"
- conditional a _ps bs (Comb Empty)
- | Foldable.all (\case { Comb Empty -> True; _ -> False }) bs = a *> empty
+ conditional a bs (Comb Empty)
+ | Foldable.all (\case { (_, Comb Empty) -> True; _ -> False }) bs = a *> empty
-- & trace "Conditional Weakening Law"
- conditional (Comb (Pure a)) ps bs d =
- Foldable.foldr (\(p, b) next ->
- if runValue (p H..@ a) then b else next
- ) d (List.zip ps bs)
+ conditional (Comb (Pure a)) bs def =
+ Foldable.foldr (\(p, b) acc ->
+ if runValue (p Prod..@ a) then b else acc
+ ) def bs
-- & trace "Conditional Pure Law"
- conditional a ps bs d = SomeComb (Conditional a ps bs d)
+ conditional a bs d = SimplComb
+ { combData = Conditional a bs d
+ , combInline = False
+ , combRefs = HS.unions
+ $ combRefs a
+ : combRefs d
+ : ((\(_p, b) -> combRefs b) F.<$> bs)
+ }
+instance
+ ( CombMatchable repr
+ , CombAlternable repr
+ , CombApplicable repr
+ , CombLookable repr
+ , CombSelectable repr
+ , Eq letName
+ , Hashable letName
+ ) => CombMatchable (KnotComb letName repr) where
+ conditional a bs d = KnotComb
+ { knotCombOpens = HM.unions
+ $ knotCombOpens a
+ : knotCombOpens d
+ : ((\(_p, b) -> knotCombOpens b) F.<$> bs)
+ , knotCombOpen = \final -> TiedComb
+ { combSimpl = conditional
+ (combSimpl (knotCombOpen a final))
+ ((\(p, b) -> (p, combSimpl (knotCombOpen b final))) F.<$> bs)
+ (combSimpl (knotCombOpen d final))
+ }
+ }
-- CombSatisfiable
data instance Comb (CombSatisfiable tok) repr a where
Comb (CombSatisfiable tok) repr tok
instance
CombSatisfiable tok repr =>
- Trans (Comb (CombSatisfiable tok) repr) repr where
- trans = \case
- SatisfyOrFail fs p -> satisfyOrFail fs (optimizeProduction p)
+ Derivable (Comb (CombSatisfiable tok) repr) where
+ derive = \case
+ SatisfyOrFail fs p -> satisfyOrFail fs p
instance
(CombSatisfiable tok repr, Typeable tok) =>
- CombSatisfiable tok (SomeComb repr) where
- satisfyOrFail fs = SomeComb . SatisfyOrFail fs
+ CombSatisfiable tok (SimplComb repr) where
+ satisfyOrFail fs p = SimplComb
+ { combData = SatisfyOrFail fs p
+ , combInline = False -- TODO: True? depending on p?
+ , combRefs = HS.empty
+ }
+instance
+ ( CombSatisfiable tok repr
+ , Typeable tok
+ , Eq letName
+ , Hashable letName
+ ) => CombSatisfiable tok (KnotComb letName repr)
-- CombSelectable
data instance Comb CombSelectable repr a where
Branch ::
- SomeComb repr (Either a b) ->
- SomeComb repr (a -> c) ->
- SomeComb repr (b -> c) ->
+ SimplComb repr (Either a b) ->
+ SimplComb repr (a -> c) ->
+ SimplComb repr (b -> c) ->
Comb CombSelectable repr c
-instance CombSelectable repr => Trans (Comb CombSelectable repr) repr where
- trans = \case
- Branch lr l r -> branch (trans lr) (trans l) (trans r)
+instance CombSelectable repr => Derivable (Comb CombSelectable repr) where
+ derive = \case
+ Branch lr l r -> branch (derive lr) (derive l) (derive r)
instance
( CombApplicable repr
, CombAlternable repr
, CombLookable repr
, CombSelectable repr
, CombMatchable repr
- ) => CombSelectable (SomeComb repr) where
+ ) => CombSelectable (SimplComb repr) where
branch (Comb Empty) _ _ = empty
-- & trace "Branch Absorption Law"
branch b (Comb Empty) (Comb Empty) = b *> empty
-- & trace "Branch Weakening Law"
branch (Comb (Pure lr)) l r =
case runValue lr of
- Left value -> l <*> pure Production{..}
+ Left value -> l <*> pure (Pair v c)
where
- prodValue = H.SomeData $ H.Var $ Identity value
- prodCode = H.SomeData $ H.Var
+ v = Prod.SomeData $ Prod.Var $ Identity value
+ c = Prod.SomeData $ Prod.Var
[|| case $$(runCode lr) of Left x -> x ||]
- Right value -> r <*> pure Production{..}
+ Right value -> r <*> pure (Pair v c)
where
- prodValue = H.SomeData $ H.Var $ Identity value
- prodCode = H.SomeData $ H.Var
+ v = Prod.SomeData $ Prod.Var $ Identity value
+ c = Prod.SomeData $ Prod.Var
[|| case $$(runCode lr) of Right x -> x ||]
-- & trace "Branch Pure Either Law"
branch b (Comb (Pure l)) (Comb (Pure r)) =
- Production{..} <$> b
+ Pair v c <$> b
-- & trace "Branch Generalised Identity Law"
where
- prodValue = H.SomeData $ H.Var $ Identity $ either (runValue l) (runValue r)
- prodCode = H.SomeData $ H.Var [|| either $$(runCode l) $$(runCode r) ||]
+ v = Prod.SomeData $ Prod.Var $ Identity $ either (runValue l) (runValue r)
+ c = Prod.SomeData $ Prod.Var [|| either $$(runCode l) $$(runCode r) ||]
branch (Comb (x :*>: y)) p q = x *> branch y p q
-- & trace "Interchange Law"
branch b l (Comb Empty) =
- branch (pure Production{..} <*> b) empty l
+ branch (pure (Pair v c) <*> b) empty l
-- & trace "Negated Branch Law"
where
- prodValue = H.SomeData $ H.Var $ Identity $ either Right Left
- prodCode = H.SomeData $ H.Var $ [||either Right Left||]
+ v = Prod.SomeData $ Prod.Var $ Identity $ either Right Left
+ c = Prod.SomeData $ Prod.Var $ [||either Right Left||]
branch (Comb (Branch b (Comb Empty) (Comb (Pure lr)))) (Comb Empty) br =
- branch (pure Production{..} <*> b) empty br
+ branch (pure (Pair v c) <*> b) empty br
-- & trace "Branch Fusion Law"
where
- prodValue = H.SomeData $ H.Var $ Identity $ \case
+ v = Prod.SomeData $ Prod.Var $ Identity $ \case
Left{} -> Left ()
Right r ->
case runValue lr r of
Left{} -> Left ()
Right rr -> Right rr
- prodCode = H.SomeData $ H.Var
+ c = Prod.SomeData $ Prod.Var
[|| \case Left{} -> Left ()
Right r -> case $$(runCode lr) r of
Left{} -> Left ()
Right rr -> Right rr ||]
- branch b l r = SomeComb (Branch b l r)
+ branch b l r = SimplComb
+ { combData = Branch b l r
+ , combInline = False
+ , combRefs = HS.unions [ combRefs b, combRefs l, combRefs r ]
+ }
+instance
+ ( CombSelectable repr
+ , CombAlternable repr
+ , CombApplicable repr
+ , CombLookable repr
+ , CombMatchable repr
+ , Eq letName
+ , Hashable letName
+ ) => CombSelectable (KnotComb letName repr)
+
+-- CombRegisterableUnscoped
+data instance Comb CombRegisterableUnscoped repr a where
+ NewUnscoped :: UnscopedRegister a -> SimplComb repr a -> SimplComb repr b -> Comb CombRegisterableUnscoped repr b
+ GetUnscoped :: UnscopedRegister a -> Comb CombRegisterableUnscoped repr a
+ PutUnscoped :: UnscopedRegister a -> SimplComb repr a -> Comb CombRegisterableUnscoped repr ()
+instance CombRegisterableUnscoped repr => Derivable (Comb CombRegisterableUnscoped repr) where
+ derive = \case
+ NewUnscoped r ini x -> newUnscoped r (derive ini) (derive x)
+ GetUnscoped r -> getUnscoped r
+ PutUnscoped r x -> putUnscoped r (derive x)
+instance -- TODO: optimizations
+ ( CombRegisterableUnscoped repr
+ ) => CombRegisterableUnscoped (SimplComb repr) where
+ newUnscoped r ini x = SimplComb
+ { combData = NewUnscoped r ini x
+ , combInline = combInline ini && combInline x
+ , combRefs = combRefs ini <> combRefs x
+ }
+ getUnscoped r = SimplComb
+ { combData = GetUnscoped r
+ , combInline = True
+ , combRefs = HS.empty
+ }
+ putUnscoped r x = SimplComb
+ { combData = PutUnscoped r x
+ , combInline = combInline x
+ , combRefs = combRefs x
+ }
+instance
+ ( CombRegisterableUnscoped repr
+ , Eq letName
+ , Hashable letName
+ ) => CombRegisterableUnscoped (KnotComb letName repr) where
+
+-- Letsable
+data instance Comb (Letsable letName) repr a where
+ Lets ::
+ LetBindings letName (SimplComb repr) ->
+ SimplComb repr a ->
+ Comb (Letsable letName) repr a
+instance
+ Letsable letName repr =>
+ Derivable (Comb (Letsable letName) repr) where
+ derive = \case
+ Lets defs x -> lets
+ ((\(SomeLet sub) -> SomeLet (derive sub)) F.<$> defs)
+ (derive x)
+instance
+ (Letsable letName repr, Typeable letName) =>
+ Letsable letName (SimplComb repr) where
+ lets defs body = SimplComb
+ { combData = Lets defs body
+ , combInline = False
+ , combRefs = HS.unions
+ $ combRefs body
+ : ((\(SomeLet sub) -> combRefs sub) F.<$> HM.elems defs)
+ }
+instance
+ Letsable TH.Name repr =>
+ Letsable TH.Name (KnotComb TH.Name repr) where
+ lets defs body = KnotComb
+ { knotCombOpens =
+ HM.unions
+ $ knotCombOpens body
+ : ((\(SomeLet sub) -> SomeLet . knotCombOpen sub) F.<$> defs)
+ -- Not really necessary to include 'knotCombOpens' of 'defs' here
+ -- since there is only a single 'lets' at the top of the AST,
+ -- but well.
+ : ((\(SomeLet sub) -> knotCombOpens sub) F.<$> HM.elems defs)
+ , knotCombOpen = \final -> TiedComb
+ { combSimpl =
+ let bodySimpl = combSimpl $ knotCombOpen body final in
+ let defsSimpl = (\(SomeLet sub) -> SomeLet $ combSimpl $ knotCombOpen sub final) F.<$> defs in
+ let defsUsed = HS.unions
+ $ combRefs bodySimpl
+ : ((\(SomeLet sub) -> combRefs sub) F.<$> HM.elems defsSimpl) in
+ lets (HM.intersection defsSimpl (HS.toMap defsUsed)) bodySimpl
+ }
+ }
+
+-- Referenceable
+data instance Comb (Referenceable letName) repr a where
+ Ref :: Bool -> letName -> Comb (Referenceable letName) repr a
+instance
+ Referenceable letName repr =>
+ Derivable (Comb (Referenceable letName) repr) where
+ derive = \case
+ Ref isRec name -> ref isRec name
+instance
+ Referenceable TH.Name repr =>
+ Referenceable TH.Name (SimplComb repr) where
+ ref isRec name = SimplComb
+ { combData = Ref isRec name
+ , combInline = not isRec
+ , combRefs = HS.singleton name
+ }
+instance
+ Referenceable TH.Name repr =>
+ Referenceable TH.Name (KnotComb TH.Name repr) where
+ ref isRec name = KnotComb
+ { knotCombOpens = HM.empty
+ , knotCombOpen = \final ->
+ if isRec
+ then TiedComb
+ { combSimpl = ref isRec name
+ }
+ else case final HM.! name of
+ SomeLet a@TiedComb
+ { combSimpl = p@SimplComb{ combInline = True }
+ } -> a{combSimpl = unsafeSimplComb p}
+ SomeLet TiedComb
+ { combSimpl = SimplComb{ combRefs = refs }
+ } -> TiedComb
+ { combSimpl = (ref isRec name)
+ { combRefs = HS.insert name refs }
+ }
+ }
sourcephile / git / haskell / symantic-parser.git / blobdiff