-{-# LANGUAGE PatternSynonyms #-} -- For aliased combinators
-{-# LANGUAGE TemplateHaskell #-} -- For optimizeCombNode
-{-# LANGUAGE ViewPatterns #-} -- For optimizeCombNode
+{-# LANGUAGE PatternSynonyms #-} -- For Comb
+{-# LANGUAGE TemplateHaskell #-} -- For branch
+{-# 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.Char (Char)
+import Data.Bool (Bool(..), (&&), not)
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
-import Data.Foldable (all, foldr)
-import Data.Function ((.))
-import Data.Kind (Type)
-import qualified Data.Functor as Functor
-import qualified Data.List as List
-import qualified Language.Haskell.TH.Syntax as TH
-
-import Symantic.Parser.Grammar.Combinators as Comb
-import Symantic.Parser.Staging (ValueCode(..), Value(..), getValue, code)
-import Symantic.Univariant.Letable
-import Symantic.Univariant.Trans
-import qualified Symantic.Parser.Staging as H
-
--- import Debug.Trace (trace)
-
--- * Type 'Comb'
--- | Pattern-matchable 'Comb'inators of the grammar.
--- @(repr)@ is not strictly necessary since it's only a phantom type
--- (no constructor use it as a value), but having it:
---
--- 1. emphasizes that those 'Comb'inators will be 'trans'formed again
--- (eg. in 'DumpComb' or 'Instr'uctions).
+import Data.Function (($), (.))
+import Data.Kind (Constraint)
+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 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
+import Symantic.Parser.Grammar.Production
+import Symantic.Parser.Grammar.ObserveSharing hiding (def)
+import Symantic.Derive
+import qualified Symantic.Data as Prod
+import qualified Symantic.Lang as Prod
+
+{-
+import Data.Function (($), flip)
+import Debug.Trace (trace)
+
+(&) = flip ($)
+infix 0 &
+-}
+type OptimizeGrammar = KnotComb TH.Name
+
+-- | 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 ::
+ 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'.
+-- This is an extensible data-type.
+data family Comb
+ (comb :: ReprComb -> Constraint)
+ :: ReprComb -> ReprComb
+type instance Derived (Comb comb repr) = repr
+
+-- | 'unsafeCoerce' restrained to 'SimplComb'.
+-- Useful to avoid dependant-map when inlining.
+unsafeSimplComb :: SimplComb repr a -> SimplComb repr b
+unsafeSimplComb = unsafeCoerce
+
+-- | 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 'SimplComb' data-constructor,
+-- to bring the constraints in scope.
--
--- 2. Avoid overlapping instances between
--- @('Trans' ('Comb' repr) repr)@ and
--- @('Trans' ('Comb' repr) ('OptimizeComb' letName repr))@
-data Comb (repr :: Type -> Type) a where
- Pure :: H.Haskell a -> Comb repr a
- Satisfy :: H.Haskell (Char -> Bool) -> Comb repr Char
- Item :: Comb repr Char
- Try :: Comb repr a -> Comb repr a
- Look :: Comb repr a -> Comb repr a
- NegLook :: Comb repr a -> Comb repr ()
- (:<*>) :: Comb repr (a -> b) -> Comb repr a -> Comb repr b
- (:<|>) :: Comb repr a -> Comb repr a -> Comb repr a
- Empty :: Comb repr a
- Branch :: Comb repr (Either a b) -> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
- Match :: Eq a => [H.Haskell (a -> Bool)] -> [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
- ChainPre :: Comb repr (a -> a) -> Comb repr a -> Comb repr a
- ChainPost :: Comb repr a -> Comb repr (a -> a) -> Comb repr a
- Def :: TH.Name -> Comb repr a -> Comb repr a
- Ref :: Bool -> TH.Name -> Comb repr a
-
-pattern (:<$>) :: H.Haskell (a -> b) -> Comb repr a -> Comb repr b
-pattern (:$>) :: Comb repr a -> H.Haskell b -> Comb repr b
-pattern (:<$) :: H.Haskell a -> Comb repr b -> Comb repr a
-pattern (:*>) :: Comb repr a -> Comb repr b -> Comb repr b
-pattern (:<*) :: Comb repr a -> Comb repr b -> Comb repr a
-pattern x :<$> p = Pure x :<*> p
-pattern p :$> x = p :*> Pure x
-pattern x :<$ p = Pure x :<* p
-pattern x :<* p = H.Const :<$> x :<*> p
-pattern p :*> x = H.Id :<$ p :<*> x
-
-infixl 3 :<|>
-infixl 4 :<*>, :<*, :*>
-infixl 4 :<$>, :<$, :$>
-
-instance Applicable (Comb repr) where
- pure = Pure
- (<*>) = (:<*>)
-instance Alternable (Comb repr) where
- (<|>) = (:<|>)
- empty = Empty
- try = Try
-instance Selectable (Comb repr) where
- branch = Branch
-instance Matchable (Comb repr) where
- conditional = Match
-instance Foldable (Comb repr) where
- chainPre = ChainPre
- chainPost = ChainPost
-instance Charable (Comb repr) where
- satisfy = Satisfy
-instance Lookable (Comb repr) where
- look = Look
- negLook = NegLook
-instance Letable TH.Name (Comb repr) where
- def = Def
- ref = Ref
-instance MakeLetName TH.Name where
- makeLetName _ = TH.qNewName "let"
-
--- Pattern-matchable 'Comb'inators keep enough structure
--- to have some of the symantics producing them interpreted again
--- (eg. after being modified by 'optimizeComb').
-type instance Output (Comb repr) = repr
-instance
- ( Applicable repr
- , Alternable repr
- , Selectable repr
- , Foldable repr
- , Charable repr
- , Lookable repr
- , Matchable repr
- , Letable TH.Name repr
- ) => Trans (Comb repr) repr where
- trans = \case
- Pure a -> pure a
- Satisfy p -> satisfy p
- Item -> item
- Try x -> try (trans x)
- Look x -> look (trans x)
- NegLook x -> negLook (trans x)
- x :<*> y -> trans x <*> trans y
- x :<|> y -> trans x <|> trans y
+-- The optimizations are directly applied within it,
+-- to avoid introducing an extra newtype,
+-- this also give a more understandable code.
+data SimplComb repr a =
+ forall comb.
+ (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).
+ }
+
+type instance Derived (SimplComb repr) = repr
+instance Derivable (SimplComb repr) where
+ derive SimplComb{..} = derive combData
+
+-- | @(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.
+unSimplComb ::
+ forall comb repr a.
+ Typeable comb =>
+ 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 -> 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 :: 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
- Branch lr l r -> branch (trans lr) (trans l) (trans r)
- Match ps bs a b -> conditional ps (trans Functor.<$> bs) (trans a) (trans b)
- ChainPre x y -> chainPre (trans x) (trans y)
- ChainPost x y -> chainPost (trans x) (trans y)
- Def n x -> def n (trans x)
- Ref r n -> ref r n
-
--- * Type 'OptimizeComb'
--- Bottom-up application of 'optimizeCombNode'.
-newtype OptimizeComb letName repr a = OptimizeComb { unOptimizeComb :: Comb repr a }
-
-optimizeComb ::
- Trans (OptimizeComb TH.Name repr) repr =>
- OptimizeComb TH.Name repr a -> repr a
-optimizeComb = trans
+ Failure sf -> failure sf
+ Throw exn -> throw exn
+ Try x -> try (derive x)
+instance
+ ( CombAlternable repr
+ , CombApplicable repr
+ , CombLookable repr
+ , CombMatchable repr
+ , CombSelectable repr
+ ) => 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"
+ alt _exn (Comb Empty) u = u
+ -- & trace "Left Neutral Law"
+ alt _exn u (Comb Empty) = u
+ -- & trace "Right Neutral Law"
+ alt exn (Comb (Alt exn' u v)) w | exn' == exn = u <|> (v <|> w)
+ -- See Lemma 1 (Associativity of choice for labeled PEGs)
+ -- in https://doi.org/10.1145/2851613.2851750
+ -- & trace "Associativity Law"
+ alt exn (Comb (Look p)) (Comb (Look q)) = look (alt exn (try p) q)
+ -- & trace "Distributivity Law"
+ alt exn x y = SimplComb
+ { combData = Alt exn x y
+ , combInline = False
+ , combRefs = combRefs x <> combRefs y
+ }
+
+ 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 = 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
+ (:<*>:) :: 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) -> SimplComb repr a -> Comb CombApplicable repr b
+pattern t :<$>: x <- Comb (Pure t) :<*>: x
+pattern (:$>:) :: SimplComb repr a -> Production b -> Comb CombApplicable repr b
+pattern x :$>: t <- x :*>: Comb (Pure t)
+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 (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
+ ((Prod..) Prod..@ f <$> l)
+ ((Prod..) Prod..@ f <$> r)
+ -- & trace "Branch Distributivity Law"
+ 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 SimplComb { combData = f <$> combData x },
+ -- in order to apply the optimizations of (<*>).
+ f <$> x = pure f <*> x
+
+ x <$ u = u $> x
+ -- & trace "Commutativity Law"
+
+ Comb Empty <*> _ = empty
+ -- & trace "App Right Absorption Law"
+ u <*> Comb Empty = u *> empty
+ -- & trace "App Failure Weakening Law"
+ 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.
+ (Prod..) Prod..@ f Prod..@ g <$> p
+ -- & trace "Functor Composition Law"
+ -}
+ u <*> Comb (Pure x) = Prod.flip Prod..@ (Prod.$) Prod..@ x <$> u
+ -- & trace "Interchange Law"
+ 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 :<*: w) = (u <*> v) <* w
+ -- & trace "Reassociation Law 2"
+ u <*> Comb (v :$>: x) = (u <*> pure x) <* v
+ -- & trace "Reassociation Law 3"
+ p <*> Comb (NegLook q) =
+ (p <*> pure Prod.unit) <* negLook q
+ -- & trace "Absorption Law"
+ x <*> y = SimplComb
+ { combData = x :<*>: y
+ , combInline = False
+ , combRefs = combRefs x <> combRefs y
+ }
+
+ Comb Empty *> _ = empty
+ -- & trace "App Right Absorption Law"
+ Comb (_ :<$>: p) *> q = p *> q
+ -- & trace "Right Absorption Law"
+ Comb Pure{} *> u = u
+ -- & trace "Identity Law"
+ Comb (u :$>: _) *> v = u *> v
+ -- & trace "Identity Law"
+ u *> Comb (v :*>: w) = (u *> v) *> w
+ -- & trace "Associativity Law"
+ x *> y = SimplComb
+ { combData = x :*>: y
+ , combInline = False
+ , combRefs = combRefs x <> combRefs y
+ }
+
+ Comb Empty <* _ = empty
+ -- & trace "App Right Absorption Law"
+ u <* Comb Empty = u *> empty
+ -- & trace "App Failure Weakening Law"
+ p <* Comb (_ :<$>: q) = p <* q
+ -- & trace "Left Absorption Law"
+ u <* Comb Pure{} = u
+ -- & trace "Identity Law"
+ u <* Comb (v :$>: _) = u <* v
+ -- & trace "Identity Law"
+ Comb (u :<*: v) <* w = u <* (v <* w)
+ -- & trace "Associativity Law"
+ 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
+ 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
+ ( CombFoldable repr
+ , Eq letName
+ , Hashable letName
+ ) => CombFoldable (KnotComb letName repr)
+
+-- CombLookable
+data instance Comb CombLookable repr a where
+ Look :: SimplComb repr a -> Comb CombLookable repr a
+ NegLook :: SimplComb repr a -> Comb CombLookable repr ()
+ Eof :: Comb CombLookable repr ()
+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
+ , CombApplicable repr
+ , CombLookable repr
+ , CombSelectable repr
+ , CombMatchable repr
+ ) => CombLookable (SimplComb repr) where
+ look p@(Comb Pure{}) = p
+ -- & trace "Pure Look Law"
+ look p@(Comb Empty) = p
+ -- & trace "Dead Look Law"
+ look (Comb (Look x)) = look x
+ -- & trace "Idempotence Law"
+ look (Comb (NegLook x)) = negLook x
+ -- & trace "Left Identity Law"
+ look (Comb (p :$>: x)) = look p $> x
+ -- & trace "Interchange Law"
+ look (Comb (f :<$>: p)) = f <$> look p
+ -- & trace "Interchange Law"
+ look x = SimplComb
+ { combData = Look x
+ , combInline = False
+ , combRefs = combRefs x
+ }
+
+ negLook (Comb Pure{}) = empty
+ -- & trace "Pure Negative-Look"
+ negLook (Comb Empty) = pure Prod.unit
+ -- & trace "Dead Negative-Look"
+ negLook (Comb (NegLook x)) = look (try x *> pure Prod.unit)
+ -- & trace "Double Negation Law"
+ negLook (Comb (Try x)) = negLook x
+ -- & trace "Zero Consumption Law"
+ negLook (Comb (Look x)) = negLook x
+ -- & trace "Right Identity Law"
+ negLook (Comb (Alt _exn (Comb (Try p)) q)) = negLook p *> negLook q
+ -- FIXME: see if this really holds for all exceptions.
+ -- & trace "Transparency Law"
+ negLook (Comb (p :$>: _)) = negLook p
+ -- & trace "NegLook Idempotence Law"
+ negLook x = SimplComb
+ { combData = NegLook x
+ , combInline = False
+ , combRefs = combRefs x
+ }
+
+ 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 ::
+ SimplComb repr a ->
+ [(Production (a -> Bool), SimplComb repr b)] ->
+ SimplComb repr b ->
+ Comb CombMatchable repr 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 (SimplComb repr) where
+ conditional (Comb Empty) _ def = def
+ -- & trace "Conditional Absorption Law"
+ conditional a bs (Comb Empty)
+ | Foldable.all (\case { (_, Comb Empty) -> True; _ -> False }) bs = a *> empty
+ -- & trace "Conditional Weakening Law"
+ 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 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
+ -- | To include the @('Set' 'SomeFailure')@ is a little kludge
+ -- it would be cleaner to be able to pattern-match
+ -- on @(alt exn (Comb 'Satisfy'{}) (Failure{}))@
+ -- when generating 'Program', but this is not easily possible then
+ -- because data types have already been converted back to class methods,
+ -- hence pattern-matching is no longer possible
+ -- (at least not without reintroducing data types).
+ SatisfyOrFail ::
+ CombSatisfiable tok repr =>
+ Set SomeFailure ->
+ Production (tok -> Bool) ->
+ Comb (CombSatisfiable tok) repr tok
+instance
+ CombSatisfiable tok repr =>
+ Derivable (Comb (CombSatisfiable tok) repr) where
+ derive = \case
+ SatisfyOrFail fs p -> satisfyOrFail fs p
instance
- Trans (Comb repr) repr =>
- Trans (OptimizeComb letName repr) repr where
- trans = trans . unOptimizeComb
-
-type instance Output (OptimizeComb _letName repr) = Comb repr
-instance Trans (OptimizeComb letName repr) (Comb repr) where
- trans = unOptimizeComb
-instance Trans (Comb repr) (OptimizeComb letName repr) where
- trans = OptimizeComb . optimizeCombNode
-instance Trans1 (Comb repr) (OptimizeComb letName repr)
-instance Trans2 (Comb repr) (OptimizeComb letName repr)
-instance Trans3 (Comb repr) (OptimizeComb letName repr)
+ (CombSatisfiable tok repr, Typeable tok) =>
+ 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 ::
+ SimplComb repr (Either a b) ->
+ SimplComb repr (a -> c) ->
+ SimplComb repr (b -> c) ->
+ Comb CombSelectable repr c
+instance CombSelectable repr => Derivable (Comb CombSelectable repr) where
+ derive = \case
+ Branch lr l r -> branch (derive lr) (derive l) (derive r)
instance
- Letable letName (Comb repr) =>
- Letable letName (OptimizeComb letName repr) where
- -- Disable useless calls to 'optimizeCombNode'
- -- because 'Def' or 'Ref' have no matching in it.
- def n = OptimizeComb . def n . unOptimizeComb
- ref r n = OptimizeComb (ref r n)
-instance Comb.Applicable (OptimizeComb letName repr)
-instance Comb.Alternable (OptimizeComb letName repr)
-instance Comb.Charable (OptimizeComb letName repr)
-instance Comb.Selectable (OptimizeComb letName repr)
-instance Comb.Matchable (OptimizeComb letName repr)
-instance Comb.Lookable (OptimizeComb letName repr)
-instance Comb.Foldable (OptimizeComb letName repr)
-
-optimizeCombNode :: Comb repr a -> Comb repr a
-optimizeCombNode = \case
- -- Functor Identity Law
- H.Id :<$> x ->
- -- trace "Functor Identity Law" $
- x
- -- Functor Commutativity Law
- x :<$ u ->
- -- trace "Functor Commutativity Law" $
- optimizeCombNode (u :$> x)
- -- Functor Flip Const Law
- H.Flip H.:@ H.Const :<$> u ->
- -- trace "Functor Flip Const Law" $
- optimizeCombNode (u :*> Pure H.Id)
- -- Functor Homomorphism Law
- f :<$> Pure x ->
- -- trace "Functor Homomorphism Law" $
- Pure (f H..@ x)
-
- -- App Right Absorption Law
- Empty :<*> _ ->
- -- trace "App Right Absorption Law" $
- Empty
- _ :<*> Empty ->
- -- In Parsley: this is only a weakening to u :*> Empty
- -- but here :*> is an alias to :<*>
- -- hence it would loop on itself forever.
- -- trace "App Left Absorption Law" $
- Empty
- -- App Composition Law
- u :<*> (v :<*> w) ->
- -- trace "App Composition Law" $
- optimizeCombNode (optimizeCombNode (optimizeCombNode ((H.:.) :<$> u) :<*> v) :<*> w)
- -- App Interchange Law
- u :<*> Pure x ->
- -- trace "App Interchange Law" $
- optimizeCombNode (H.Flip H..@ (H.:$) H..@ x :<$> u)
- -- App Left Absorption Law
- p :<* (_ :<$> q) ->
- -- trace "App Left Absorption Law" $
- p :<* q
- -- App Right Absorption Law
- (_ :<$> p) :*> q ->
- -- trace "App Right Absorption Law" $
- p :*> q
- -- App Pure Left Identity Law
- Pure _ :*> u ->
- -- trace "App Pure Left Identity Law" $
- u
- -- App Functor Left Identity Law
- (u :$> _) :*> v ->
- -- trace "App Functor Left Identity Law" $
- u :*> v
- -- App Pure Right Identity Law
- u :<* Pure _ ->
- -- trace "App Pure Right Identity Law" $
- u
- -- App Functor Right Identity Law
- u :<* (v :$> _) ->
- -- trace "App Functor Right Identity Law" $
- optimizeCombNode (u :<* v)
- -- App Left Associativity Law
- (u :<* v) :<* w ->
- -- trace "App Left Associativity Law" $
- optimizeCombNode (u :<* optimizeCombNode (v :<* w))
-
- -- Alt Left Catch Law
- p@Pure{} :<|> _ ->
- -- trace "Alt Left Catch Law" $
- p
- -- Alt Left Neutral Law
- Empty :<|> u ->
- -- trace "Alt Left Neutral Law" $
- u
- -- All Right Neutral Law
- u :<|> Empty ->
- -- trace "Alt Right Neutral Law" $
- u
- -- Alt Associativity Law
- (u :<|> v) :<|> w ->
- -- trace "Alt Associativity Law" $
- u :<|> optimizeCombNode (v :<|> w)
-
- -- Look Pure Law
- Look p@Pure{} ->
- -- trace "Look Pure Law" $
- p
- -- Look Empty Law
- Look p@Empty ->
- -- trace "Look Empty Law" $
- p
- -- NegLook Pure Law
- NegLook Pure{} ->
- -- trace "NegLook Pure Law" $
- Empty
- -- NegLook Empty Law
- NegLook Empty ->
- -- trace "NegLook Dead Law" $
- Pure H.unit
- -- NegLook Double Negation Law
- NegLook (NegLook p) ->
- -- trace "NegLook Double Negation Law" $
- optimizeCombNode (Look (Try p) :*> Pure H.unit)
- -- NegLook Zero Consumption Law
- NegLook (Try p) ->
- -- trace "NegLook Zero Consumption Law" $
- optimizeCombNode (NegLook p)
- -- Idempotence Law
- Look (Look p) ->
- -- trace "Look Idempotence Law" $
- Look p
- -- Look Right Identity Law
- NegLook (Look p) ->
- -- trace "Look Right Identity Law" $
- optimizeCombNode (NegLook p)
- -- Look Left Identity Law
- Look (NegLook p) ->
- -- trace "Look Left Identity Law" $
- NegLook p
- -- NegLook Transparency Law
- NegLook (Try p :<|> q) ->
- -- trace "NegLook Transparency Law" $
- optimizeCombNode (optimizeCombNode (NegLook p) :*> optimizeCombNode (NegLook q))
- -- Look Distributivity Law
- Look p :<|> Look q ->
- -- trace "Look Distributivity Law" $
- optimizeCombNode (Look (optimizeCombNode (Try p :<|> q)))
- -- Look Interchange Law
- Look (f :<$> p) ->
- -- trace "Look Interchange Law" $
- optimizeCombNode (f :<$> optimizeCombNode (Look p))
- -- NegLook Absorption Law
- p :<*> NegLook q ->
- -- trace "Neglook Absorption Law" $
- optimizeCombNode (optimizeCombNode (p :<*> Pure H.unit) :<* NegLook q)
- -- NegLook Idempotence Right Law
- NegLook (_ :<$> p) ->
- -- trace "NegLook Idempotence Law" $
- optimizeCombNode (NegLook p)
- -- Try Interchange Law
- Try (f :<$> p) ->
- -- trace "Try Interchange Law" $
- optimizeCombNode (f :<$> optimizeCombNode (Try p))
-
- -- Branch Absorption Law
- Branch Empty _ _ ->
- -- trace "Branch Absorption Law" $
- empty
- -- Branch Weakening Law
- Branch b Empty Empty ->
- -- trace "Branch Weakening Law" $
- optimizeCombNode (b :*> Empty)
- -- Branch Pure Left/Right Laws
- Branch (Pure (trans -> lr)) l r ->
- -- trace "Branch Pure Left/Right Law" $
- case getValue lr of
- Left v -> optimizeCombNode (l :<*> Pure (H.Haskell (ValueCode (Value v) c)))
- where c = [|| case $$(code lr) of Left x -> x ||]
- Right v -> optimizeCombNode (r :<*> Pure (H.Haskell (ValueCode (Value v) c)))
- where c = [|| case $$(code lr) of Right x -> x ||]
- -- Branch Generalised Identity Law
- Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->
- -- trace "Branch Generalised Identity Law" $
- optimizeCombNode (H.Haskell (ValueCode v c) :<$> b)
+ ( CombApplicable repr
+ , CombAlternable repr
+ , CombLookable repr
+ , CombSelectable repr
+ , CombMatchable repr
+ ) => 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 (Pair v c)
+ where
+ v = Prod.SomeData $ Prod.Var $ Identity value
+ c = Prod.SomeData $ Prod.Var
+ [|| case $$(runCode lr) of Left x -> x ||]
+ Right value -> r <*> pure (Pair v c)
+ where
+ 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)) =
+ Pair v c <$> b
+ -- & trace "Branch Generalised Identity Law"
where
- v = Value (either (getValue l) (getValue r))
- c = [|| either $$(code l) $$(code r) ||]
- -- Branch Interchange Law
- Branch (x :*> y) p q ->
- -- trace "Branch Interchange Law" $
- optimizeCombNode (x :*> optimizeCombNode (Branch y p q))
- -- Branch Empty Right Law
- Branch b l Empty ->
- -- trace " Branch Empty Right Law" $
- Branch (Pure (H.Haskell (ValueCode v c)) :<*> b) Empty l
+ 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 (Pair v c) <*> b) empty l
+ -- & trace "Negated Branch Law"
where
- v = Value (either Right Left)
- c = [||either Right Left||]
- -- Branch Fusion Law
- Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->
- -- trace "Branch Fusion Law" $
- optimizeCombNode (Branch (optimizeCombNode (Pure (H.Haskell (ValueCode (Value v) c)) :<*> b))
- Empty br)
+ 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 (Pair v c) <*> b) empty br
+ -- & trace "Branch Fusion Law"
where
- v Left{} = Left ()
- v (Right r) = case getValue lr r of
- Left _ -> Left ()
- Right rr -> Right rr
- c = [|| \case Left{} -> Left ()
- Right r -> case $$(code lr) r of
- Left _ -> Left ()
- Right rr -> Right rr ||]
- -- Branch Distributivity Law
- f :<$> Branch b l r ->
- -- trace "Branch Distributivity Law" $
- optimizeCombNode (Branch b (optimizeCombNode ((H..@) (H..) f :<$> l))
- (optimizeCombNode ((H..@) (H..) f :<$> r)))
-
- -- Match Absorption Law
- Match _ _ Empty d ->
- -- trace "Match Absorption Law" $
- d
- -- Match Weakening Law
- Match _ bs a Empty
- | all (\case {Empty -> True; _ -> False}) bs ->
- -- trace "Match Weakening Law" $
- optimizeCombNode (a :*> Empty)
- -- Match Pure Law
- Match ps bs (Pure (trans -> a)) d ->
- -- trace "Match Pure Law" $
- foldr (\(trans -> p, b) next ->
- if getValue p (getValue a) then b else next
- ) d (List.zip ps bs)
- -- Match Distributivity Law
- f :<$> Match ps bs a d ->
- -- trace "Match Distributivity Law" $
- Match ps (optimizeCombNode . (f :<$>) Functor.<$> bs) a
- (optimizeCombNode (f :<$> d))
-
- {- Possibly useless laws to be tested
- Empty :*> _ -> Empty
- Empty :<* _ -> Empty
- -- App Definition of *> Law
- H.Flip H..@ H.Const :<$> p :<*> q ->
- -- trace "EXTRALAW: App Definition of *> Law" $
- p :*> q
- -- App Definition of <* Law
- H.Const :<$> p :<*> q ->
- -- trace "EXTRALAW: App Definition of <* Law" $
- p :<* q
-
- -- Functor Composition Law
- -- (a shortcut that could also have been be caught
- -- by the Composition Law and Homomorphism Law)
- f :<$> (g :<$> p) ->
- -- trace "EXTRALAW: Functor Composition Law" $
- optimizeCombNode ((H.:.) H..@ f H..@ g :<$> p)
- -- Applicable Failure Weakening Law
- u :<* Empty ->
- -- trace "EXTRALAW: App Failure Weakening Law" $
- optimizeCombNode (u :*> Empty)
- Try (p :$> x) ->
- -- trace "EXTRALAW: Try Interchange Right Law" $
- optimizeCombNode (optimizeCombNode (Try p) :$> x)
- -- App Reassociation Law 1
- (u :*> v) :<*> w ->
- -- trace "EXTRALAW: App Reassociation Law 1" $
- optimizeCombNode (u :*> optimizeCombNode (v :<*> w))
- -- App Reassociation Law 2
- u :<*> (v :<* w) ->
- -- trace "EXTRALAW: App Reassociation Law 2" $
- optimizeCombNode (optimizeCombNode (u :<*> v) :<* w)
- -- App Right Associativity Law
- u :*> (v :*> w) ->
- -- trace "EXTRALAW: App Right Associativity Law" $
- optimizeCombNode (optimizeCombNode (u :*> v) :*> w)
- -- App Reassociation Law 3
- u :<*> (v :$> x) ->
- -- trace "EXTRALAW: App Reassociation Law 3" $
- optimizeCombNode (optimizeCombNode (u :<*> Pure x) :<* v)
-
- Look (p :$> x) ->
- optimizeCombNode (optimizeCombNode (Look p) :$> x)
- NegLook (p :$> _) -> optimizeCombNode (NegLook p)
+ v = Prod.SomeData $ Prod.Var $ Identity $ \case
+ Left{} -> Left ()
+ Right r ->
+ case runValue lr r of
+ Left{} -> Left ()
+ Right rr -> Right rr
+ 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 = 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
- x -> x
+-- 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