-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PatternSynonyms #-} -- For aliased combinators
+{-# LANGUAGE TemplateHaskell #-} -- For optimizeCombNode
+{-# LANGUAGE ViewPatterns #-} -- For optimizeCombNode
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- For MakeLetName TH.Name
module Symantic.Parser.Grammar.Optimize where
-import Data.Bool (Bool)
-import Data.Char (Char)
+import Data.Bool (Bool(..))
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
-import qualified Prelude as Pre
+import Data.Function ((.))
+import qualified Data.Functor as Functor
+import qualified Data.Foldable as Foldable
+import qualified Data.List as List
+import qualified Language.Haskell.TH.Syntax as TH
-import Symantic.Base.Univariant
-import Symantic.Parser.Grammar.Combinators
-import Symantic.Parser.Grammar.ObserveSharing
-import Symantic.Parser.Staging hiding (Haskell(..))
-import qualified Symantic.Parser.Staging as Hask
--- import qualified Language.Haskell.TH.Syntax as TH
+import Symantic.Parser.Grammar.Combinators as Comb
+import Symantic.Parser.Haskell ()
+import Symantic.Univariant.Letable
+import Symantic.Univariant.Trans
+import qualified Symantic.Parser.Haskell as H
--- * Type 'Grammar'
-data Grammar a where
- Pure :: Hask.Haskell a -> Grammar a
- Satisfy :: Hask.Haskell (Char -> Bool) -> Grammar Char
- Item :: Grammar Char
- Try :: Grammar a -> Grammar a
- Look :: Grammar a -> Grammar a
- NegLook :: Grammar a -> Grammar ()
- (:<*>) :: Grammar (a -> b) -> Grammar a -> Grammar b
- (:<|>) :: Grammar a -> Grammar a -> Grammar a
- Empty :: Grammar a
- Branch :: Grammar (Either a b) -> Grammar (a -> c) -> Grammar (b -> c) -> Grammar c
- Match :: Eq a => [Hask.Haskell (a -> Bool)] -> [Grammar b] -> Grammar a -> Grammar b -> Grammar b
- ChainPre :: Grammar (a -> a) -> Grammar a -> Grammar a
- ChainPost :: Grammar a -> Grammar (a -> a) -> Grammar a
- Def :: Pointer -> Grammar a -> Grammar a
- Ref :: Bool -> Pointer -> Grammar a
+-- import Debug.Trace (trace)
-pattern (:<$>) :: Hask.Haskell (a -> b) -> Grammar a -> Grammar b
-pattern (:$>) :: Grammar a -> Hask.Haskell b -> Grammar b
-pattern (:<$) :: Hask.Haskell a -> Grammar b -> Grammar a
-pattern (:*>) :: Grammar a -> Grammar b -> Grammar b
-pattern (:<*) :: Grammar a -> Grammar b -> Grammar a
+-- * 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 'ViewGrammar' or 'Instr'uctions).
+--
+-- 2. Avoid overlapping instances between
+-- @('Trans' ('Comb' repr) repr)@ and
+-- @('Trans' ('Comb' repr) ('OptimizeGrammar' letName repr))@
+data Comb repr a where
+ Pure :: TermGrammar a -> Comb repr a
+ Satisfy ::
+ Satisfiable repr tok =>
+ [ErrorItem tok] ->
+ TermGrammar (tok -> Bool) -> Comb repr tok
+ Item :: Satisfiable repr tok => Comb repr tok
+ Try :: Comb repr a -> Comb repr a
+ Look :: Comb repr a -> Comb repr a
+ NegLook :: Comb repr a -> Comb repr ()
+ Eof :: Comb repr ()
+ (:<*>) :: Comb repr (a -> b) -> Comb repr a -> Comb repr b
+ (:<*) :: Comb repr a -> Comb repr b -> Comb repr a
+ (:*>) :: Comb repr a -> Comb repr b -> 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 =>
+ Comb repr a ->
+ [TermGrammar (a -> Bool)] ->
+ [Comb repr b] -> 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
+infixl 3 :<|>
+infixl 4 :<*>
+infixl 4 :<*, :*>
+
+pattern (:<$>) :: TermGrammar (a -> b) -> Comb repr a -> Comb repr b
pattern x :<$> p = Pure x :<*> p
+pattern (:$>) :: Comb repr a -> TermGrammar b -> Comb repr b
+pattern (:<$) :: TermGrammar a -> Comb repr b -> Comb repr a
pattern p :$> x = p :*> Pure x
pattern x :<$ p = Pure x :<* p
-pattern x :<* p = Hask.Const :<$> x :<*> p
-pattern p :*> x = Hask.Id :<$ p :<*> x
-
-infixl 3 :<|>
-infixl 4 :<*>, :<*, :*>
infixl 4 :<$>, :<$, :$>
-instance Applicable Grammar where
+{-
+pattern (:*>) :: Comb repr a -> Comb repr b -> Comb repr b
+pattern (:<*) :: Comb repr a -> Comb repr b -> Comb repr a
+pattern x :<* p = H.Const :<$> x :<*> p
+pattern p :*> x = H.Id :<$ p :<*> x
+x .<* p = H.const :<$> x :<*> p
+x .<$ p = Pure x .<* p
+p .*> x = H.id .<$ p :<*> x
+p .$> x = p .*> Pure x
+-}
+
+{-
+pattern (:<$>) :: Defunc (a -> b) -> Fix Combinator a -> Combinator (Fix Combinator) b
+pattern f :<$> p = (Pure f) :<*> p
+pattern (:$>) :: Fix Combinator a -> Defunc b -> Combinator (Fix Combinator) b
+pattern p :$> x = p :*> (Pure x)
+pattern (:<$) :: Defunc a -> Fix Combinator b -> Combinator (Fix Combinator) a
+pattern x :<$ p = (Pure x) :<* p
+-}
+
+
+instance Applicable (Comb repr) where
pure = Pure
(<*>) = (:<*>)
-instance Alternable Grammar where
+ (<*) = (:<*)
+ (*>) = (:*>)
+instance Alternable (Comb repr) where
(<|>) = (:<|>)
empty = Empty
try = Try
-instance Selectable Grammar where
+instance Selectable (Comb repr) where
branch = Branch
-instance Matchable Grammar where
+instance Matchable (Comb repr) where
conditional = Match
-instance Foldable Grammar where
+instance Foldable (Comb repr) where
chainPre = ChainPre
chainPost = ChainPost
-instance Charable Grammar where
+instance Satisfiable repr tok => Satisfiable (Comb repr) tok where
satisfy = Satisfy
-instance Lookable Grammar where
+instance Lookable (Comb repr) where
look = Look
negLook = NegLook
-instance Letable Grammar where
+ eof = Eof
+instance Letable TH.Name (Comb repr) where
def = Def
ref = Ref
+instance MakeLetName TH.Name where
+ makeLetName _ = TH.qNewName "name"
+
+-- Pattern-matchable 'Comb'inators keep enough structure
+-- to have some of the symantics producing them interpreted again
+-- (eg. after being modified by 'optimizeGrammar').
+type instance Output (Comb repr) = repr
instance
( Applicable repr
, Alternable repr
, Selectable repr
, Foldable repr
- , Charable repr
, Lookable repr
, Matchable repr
- , Letable repr
- ) =>
- Symantic Grammar repr where
- sym = \case
- Pure a -> pure a
- Satisfy p -> satisfy p
+ , Letable TH.Name repr
+ ) => Trans (Comb repr) repr where
+ trans = \case
+ Pure a -> pure (H.optimizeTerm a)
+ Satisfy es p -> satisfy es p
Item -> item
- Try x -> try (sym x)
- Look x -> look (sym x)
- NegLook x -> negLook (sym x)
- x :<*> y -> sym x <*> sym y
- x :<|> y -> sym x <|> sym y
+ Try x -> try (trans x)
+ Look x -> look (trans x)
+ NegLook x -> negLook (trans x)
+ Eof -> eof
+ x :<* y -> trans x <* trans y
+ x :*> y -> trans x *> trans y
+ x :<*> y -> trans x <*> trans y
+ x :<|> y -> trans x <|> trans y
Empty -> empty
- Branch lr l r -> branch (sym lr) (sym l) (sym r)
- Match cs bs a b -> conditional cs (sym Pre.<$> bs) (sym a) (sym b)
- ChainPre x y -> chainPre (sym x) (sym y)
- ChainPost x y -> chainPost (sym x) (sym y)
- Def n x -> def n (sym x)
+ Branch lr l r -> branch (trans lr) (trans l) (trans r)
+ Match a ps bs b -> conditional (trans a) ps (trans Functor.<$> bs) (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 instance Unlift Grammar = repr
+-- * Type 'OptimizeHaskell'
+newtype OptimizeHaskell letName repr a =
+ OptimizeHaskell { unOptimizeHaskell :: Comb repr a }
instance
- ( Applicable repr
- , Alternable repr
- , Selectable repr
- , Foldable repr
- , Charable repr
- , Lookable repr
- , Matchable repr
- , Letable repr
- ) => Unliftable Grammar where
- unlift = \case
- Pure a -> pure a
- Satisfy p -> satisfy p
- Item -> item
- Try x -> try (unlift x)
- Look x -> look (unlift x)
- NegLook x -> negLook (unlift x)
- x :<*> y -> unlift x <*> unlift y
- x :<|> y -> unlift x <|> unlift y
- Empty -> empty
- Branch lr l r -> branch (unlift lr) (unlift l) (unlift r)
- Match cs bs a b -> conditional cs (unlift Pre.<$> bs) (unlift a) (unlift b)
- ChainPre x y -> chainPre (unlift x) (unlift y)
- ChainPost x y -> chainPost (unlift x) (unlift y)
- Ref{..} -> let_ let_rec let_name
-
-unComb ::
- ( Applicable repr
- , Alternable repr
- , Selectable repr
- , Foldable repr
- , Charable repr
- , Lookable repr
- , Matchable repr
- , Letable repr
- ) => Grammar repr a -> repr a
-unComb = unlift
+ Letable letName (Comb repr) =>
+ Letable letName (OptimizeGrammar letName repr)
+instance Comb.Applicable (OptimizeGrammar letName repr) where
+ pure a = pure (optimizeTerm a)
+instance Comb.Alternable (OptimizeGrammar letName repr)
+instance Comb.Satisfiable repr tok =>
+ Comb.Satisfiable (OptimizeGrammar letName repr) tok
+instance Comb.Selectable (OptimizeGrammar letName repr)
+instance Comb.Matchable (OptimizeGrammar letName repr)
+instance Comb.Lookable (OptimizeGrammar letName repr)
+instance Comb.Foldable (OptimizeGrammar letName repr)
-}
-optimizeGrammar :: Grammar a -> Grammar a
-optimizeGrammar = \case
- -- Recurse into shared and/or recursive 'let' definition
- Def n x -> Def n (optimizeGrammar x)
+-- * Type 'OptimizeGrammar'
+-- | Bottom-up application of 'optimizeCombNode'.
+newtype OptimizeGrammar letName repr a =
+ OptimizeGrammar { unOptimizeGrammar :: Comb repr a }
- -- Applicable Right Absorption Law
- Empty :<*> _ -> Empty
- Empty :*> _ -> Empty
- Empty :<* _ -> Empty
- -- Applicable Failure Weakening Law
- u :<*> Empty -> optimizeGrammar (u :*> Empty)
- u :<* Empty -> optimizeGrammar (u :*> Empty)
- -- Branch Absorption Law
- Branch Empty _ _ -> empty
- -- Branch Weakening Law
- Branch b Empty Empty -> optimizeGrammar (b :*> Empty)
+optimizeGrammar ::
+ Trans (OptimizeGrammar TH.Name repr) repr =>
+ OptimizeGrammar TH.Name repr a -> repr a
+optimizeGrammar = trans
+instance
+ Trans (Comb repr) repr =>
+ Trans (OptimizeGrammar letName repr) repr where
+ trans = trans . unOptimizeGrammar
- -- Applicable Identity Law
- Hask.Id :<$> x -> x
- -- Flip const optimisation
- Hask.Flip Hask.:@ Hask.Const :<$> u -> optimizeGrammar (u :*> Pure Hask.Id)
- -- Homomorphism Law
- f :<$> Pure x -> Pure (f Hask.:@ x)
- -- Functor Composition Law
- -- (a shortcut that could also have been be caught
- -- by the Composition Law and Homomorphism law)
- f :<$> (g :<$> p) -> optimizeGrammar ((Hask.:.) Hask.:@ f Hask.:@ g :<$> p)
- -- Composition Law
- u :<*> (v :<*> w) -> optimizeGrammar (optimizeGrammar (optimizeGrammar ((Hask.:.) :<$> u) :<*> v) :<*> w)
- -- Definition of *>
- Hask.Flip Hask.:@ Hask.Const :<$> p :<*> q -> p :*> q
- -- Definition of <*
- Hask.Const :<$> p :<*> q -> p :<* q
- -- Reassociation Law 1
- (u :*> v) :<*> w -> optimizeGrammar (u :*> optimizeGrammar (v :<*> w))
- -- Interchange Law
- u :<*> Pure x -> optimizeGrammar (Hask.Flip Hask.:@ (Hask.:$) Hask.:@ x :<$> u)
- -- Right Absorption Law
- (_ :<$> p) :*> q -> p :*> q
- -- Left Absorption Law
- p :<* (_ :<$> q) -> p :<* q
- -- Reassociation Law 2
- u :<*> (v :<* w) -> optimizeGrammar (optimizeGrammar (u :<*> v) :<* w)
- -- Reassociation Law 3
- u :<*> (v :$> x) -> optimizeGrammar (optimizeGrammar (u :<*> Pure x) :<* v)
+type instance Output (OptimizeGrammar _letName repr) = Comb repr
+instance Trans (OptimizeGrammar letName repr) (Comb repr) where
+ trans = unOptimizeGrammar
+instance Trans (Comb repr) (OptimizeGrammar letName repr) where
+ trans = OptimizeGrammar . optimizeCombNode
+instance Trans1 (Comb repr) (OptimizeGrammar letName repr)
+instance Trans2 (Comb repr) (OptimizeGrammar letName repr)
+instance Trans3 (Comb repr) (OptimizeGrammar letName repr)
- -- Left Catch Law
- p@Pure{} :<|> _ -> p
- -- Left Neutral Law
- Empty :<|> u -> u
- -- Right Neutral Law
- u :<|> Empty -> u
- -- Associativity Law
- (u :<|> v) :<|> w -> u :<|> optimizeGrammar (v :<|> w)
+instance
+ Letable letName (Comb repr) =>
+ Letable letName (OptimizeGrammar letName repr) where
+ -- Disable useless calls to 'optimizeCombNode'
+ -- because 'Def' or 'Ref' have no matching in it.
+ def n = OptimizeGrammar . def n . unOptimizeGrammar
+ ref r n = OptimizeGrammar (ref r n)
+instance Comb.Applicable (OptimizeGrammar letName repr)
+instance Comb.Alternable (OptimizeGrammar letName repr)
+instance Comb.Satisfiable repr tok =>
+ Comb.Satisfiable (OptimizeGrammar letName repr) tok
+instance Comb.Selectable (OptimizeGrammar letName repr)
+instance Comb.Matchable (OptimizeGrammar letName repr)
+instance Comb.Lookable (OptimizeGrammar letName repr)
+instance Comb.Foldable (OptimizeGrammar letName repr)
+
+
+optimizeCombNode :: Comb repr a -> Comb repr a
+
+----------------------------------------------
+-- Destructive optimizations
+----------------------------------------------
+
+optimizeCombNode (Empty :<*> _) =
+ -- trace "App Right Absorption Law" $
+ Empty
+optimizeCombNode (u :<*> Empty) =
+ -- trace "App Failure Weakening Law" $
+ optimizeCombNode (u :*> Empty)
+optimizeCombNode (Empty :*> _) =
+ -- trace "App Right Absorption Law" $
+ Empty
+optimizeCombNode (Empty :<* _) =
+ -- trace "App Right Absorption Law" $
+ Empty
+optimizeCombNode (u :<* Empty) =
+ -- trace "App Failure Weakening Law" $
+ optimizeCombNode (u :*> Empty)
+optimizeCombNode (Branch Empty _ _) =
+ -- trace "Branch Absorption Law" $
+ Empty
+optimizeCombNode (Branch b Empty Empty) =
+ -- trace "Branch Weakening Law" $
+ optimizeCombNode (b :*> Empty)
+optimizeCombNode (Match Empty _ _ d) =
+ -- trace "Match Absorption Law" $
+ d
+optimizeCombNode (Match p _ qs Empty)
+ | Foldable.all (\case {Empty -> True; _ -> False}) qs =
+ -- trace "Match Weakening Law" $
+ optimizeCombNode (p :*> Empty)
- -- Identity law
- Pure _ :*> u -> u
- -- Identity law
- (u :$> _) :*> v -> u :*> v
- -- Associativity Law
- u :*> (v :*> w) -> optimizeGrammar (optimizeGrammar (u :*> v) :*> w)
- -- Identity law
- u :<* Pure _ -> u
- -- Identity law
- u :<* (v :$> _) -> optimizeGrammar (u :<* v)
- -- Commutativity Law
- x :<$ u -> optimizeGrammar (u :$> x)
- -- Associativity Law
- (u :<* v) :<* w -> optimizeGrammar (u :<* optimizeGrammar (v :<* w))
- -- Pure lookahead
- Look p@Pure{} -> p
- -- Dead lookahead
- Look p@Empty -> p
- -- Pure negative-lookahead
- NegLook Pure{} -> Empty
+----------------------------------------------
+-- Applicative optimizations
+----------------------------------------------
+
+{- Those laws require to pattern match on some singled-out pure constructors,
+ - but 'optimizeHaskellNode' is normalizing them using lambda abstractions
+ - and thus they will no longer match.
+
+optimizeCombNode (H.Id :<$> u) =
+ -- trace "Identity Law" $
+ u
+optimizeCombNode ((H.Flip H.:@ H.Const) :<$> u) =
+ -- trace "Flip Const Optimisation" $
+ optimizeCombNode (u :*> Pure H.id)
+optimizeCombNode (((H.Flip H.:@ H.Const) :<$> p) :<*> q) =
+ -- trace "Definition of *>" $
+ p :*> q
+optimizeCombNode ((H.Const :<$> p) :<*> q) =
+ -- trace "Definition of <*" $
+ p :<* q
+-}
+optimizeCombNode (f :<$> Pure x) =
+ -- trace "Homomorphism Law" $
+ Pure (f H..@ x)
+optimizeCombNode (f :<$> (g :<$> p)) =
+ -- NOTE: This is basically a shortcut, it can be caught by the Composition Law and Homomorphism Law
+ -- trace "Functor Composition Law" $
+ optimizeCombNode ((H..) H..@ f H..@ g :<$> p)
+optimizeCombNode (u :<*> (v :<*> w)) =
+ -- trace "Composition Law" $
+ optimizeCombNode (optimizeCombNode (optimizeCombNode ((H..) :<$> u) :<*> v) :<*> w)
+optimizeCombNode ((u :*> v) :<*> w) =
+ -- trace "Reassociation Law 1" $
+ optimizeCombNode (u :*> (optimizeCombNode (v :<*> w)))
+optimizeCombNode (u :<*> (Pure x)) =
+ -- trace "Interchange Law" $
+ optimizeCombNode (H.flip H..@ (H.$) H..@ x :<$> u)
+optimizeCombNode ((_ :<$> p) :*> q) =
+ -- trace "Right Absorption Law" $
+ p :*> q
+optimizeCombNode (p :<* (_ :<$> q)) =
+ -- trace "Left Absorption Law"
+ p :<* q
+optimizeCombNode (u :<*> (v :<* w)) =
+ -- trace "Reassociation Law 2" $
+ optimizeCombNode (optimizeCombNode (u :<*> v) :<* w)
+optimizeCombNode (u :<*> (v :$> x)) =
+ -- trace "Reassociation Law 3" $
+ optimizeCombNode (optimizeCombNode (u :<*> Pure x) :<* v)
+
+----------------------------------------------
+-- Alternative optimizations
+----------------------------------------------
- -- Dead negative-lookahead
- NegLook Empty -> Pure Hask.unit
- -- Double Negation Law
- NegLook (NegLook p) -> optimizeGrammar (Look (Try p) :*> Pure Hask.unit)
- -- Zero Consumption Law
- NegLook (Try p) -> optimizeGrammar (NegLook p)
- -- Idempotence Law
- Look (Look p) -> Look p
- -- Right Identity Law
- NegLook (Look p) -> optimizeGrammar (NegLook p)
+optimizeCombNode (p@Pure{} :<|> _) =
+ -- trace "Left Catch Law" $
+ p
+optimizeCombNode (Empty :<|> u) =
+ -- trace "Left Neutral Law" $
+ u
+optimizeCombNode (u :<|> Empty) =
+ -- trace "Right Neutral Law" $
+ u
+optimizeCombNode ((u :<|> v) :<|> w) =
+ -- trace "Associativity Law" $
+ u :<|> optimizeCombNode (v :<|> w)
- -- Left Identity Law
- Look (NegLook p) -> NegLook p
- -- Transparency Law
- NegLook (Try p :<|> q) -> optimizeGrammar (optimizeGrammar (NegLook p) :*> optimizeGrammar (NegLook q))
- -- Distributivity Law
- Look p :<|> Look q -> optimizeGrammar (Look (optimizeGrammar (Try p :<|> q)))
- -- Interchange Law
- Look (p :$> x) -> optimizeGrammar (optimizeGrammar (Look p) :$> x)
- -- Interchange law
- Look (f :<$> p) -> optimizeGrammar (f :<$> optimizeGrammar (Look p))
- -- Absorption Law
- p :<*> NegLook q -> optimizeGrammar (optimizeGrammar (p :<*> Pure Hask.unit) :<* NegLook q)
- -- Idempotence Law
- NegLook (p :$> _) -> optimizeGrammar (NegLook p)
- -- Idempotence Law
- NegLook (_ :<$> p) -> optimizeGrammar (NegLook p)
- -- Interchange Law
- Try (p :$> x) -> optimizeGrammar (optimizeGrammar (Try p) :$> x)
- -- Interchange law
- Try (f :<$> p) -> optimizeGrammar (f :<$> optimizeGrammar (Try p))
+----------------------------------------------
+-- Sequencing optimizations
+----------------------------------------------
- -- pure Left/Right laws
- Branch (Pure (unlift -> lr)) l r ->
- case getValue lr of
- Left v -> optimizeGrammar (l :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
- where c = Code [|| case $$(getCode lr) of Left x -> x ||]
- Right v -> optimizeGrammar (r :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
- where c = Code [|| case $$(getCode lr) of Right x -> x ||]
- -- Generalised Identity law
- Branch b (Pure (unlift -> l)) (Pure (unlift -> r)) ->
- optimizeGrammar (Hask.Haskell (ValueCode v c) :<$> b)
- where
- v = Value (either (getValue l) (getValue r))
- c = Code [|| either $$(getCode l) $$(getCode r) ||]
- -- Interchange law
- Branch (x :*> y) p q ->
- optimizeGrammar (x :*> optimizeGrammar (Branch y p q))
- -- Negated Branch law
- Branch b l Empty ->
- Branch (Pure (Hask.Haskell (ValueCode v c)) :<*> b) Empty l
- where
- v = Value (either Right Left)
- c = Code [||either Right Left||]
- -- Branch Fusion law
- Branch (Branch b Empty (Pure (unlift -> lr))) Empty br ->
- optimizeGrammar (Branch (optimizeGrammar (Pure (Hask.Haskell (ValueCode (Value v) c)) :<*> b)) Empty br)
- where
- v Left{} = Left ()
- v (Right r) = case getValue lr r of
- Left _ -> Left ()
- Right rr -> Right rr
- c = Code [|| \case Left{} -> Left ()
- Right r -> case $$(getCode lr) r of
- Left _ -> Left ()
- Right rr -> Right rr ||]
- -- Distributivity Law
- f :<$> Branch b l r -> optimizeGrammar (Branch b (optimizeGrammar ((Hask..@) (Hask..) f :<$> l))
- (optimizeGrammar ((Hask..@) (Hask..) f :<$> r)))
+optimizeCombNode ((Pure _) :*> u) =
+ -- trace "Identity Law" $
+ u
+optimizeCombNode ((u :$> _) :*> v) =
+ -- trace "Identity Law" $
+ u :*> v
+optimizeCombNode (u :*> (v :*> w)) =
+ -- trace "Associativity Law" $
+ optimizeCombNode (optimizeCombNode (u :*> v) :*> w)
+optimizeCombNode (u :<* (Pure _)) =
+ -- trace "Identity Law" $
+ u
+optimizeCombNode (u :<* (v :$> _)) =
+ -- trace "Identity Law" $
+ optimizeCombNode (u :<* v)
+optimizeCombNode (x :<$ u) =
+ -- trace "Commutativity Law" $
+ optimizeCombNode (u :$> x)
+optimizeCombNode ((u :<* v) :<* w) =
+ -- trace "Associativity Law" $
+ optimizeCombNode (u :<* optimizeCombNode (v :<* w))
+optimizeCombNode (Look p@Pure{}) =
+ -- trace "Pure Look Law" $
+ p
+optimizeCombNode (Look p@Empty) =
+ -- trace "Dead Look Law" $
+ p
+optimizeCombNode (NegLook Pure{}) =
+ -- trace "Pure Negative-Look" $
+ Empty
+optimizeCombNode (NegLook Empty) =
+ -- trace "Dead Negative-Look" $
+ Pure H.unit
+optimizeCombNode (NegLook (NegLook p)) =
+ -- trace "Double Negation Law" $
+ optimizeCombNode (Look (Try p :*> Pure H.unit))
+optimizeCombNode (NegLook (Try p)) =
+ -- trace "Zero Consumption Law" $
+ optimizeCombNode (NegLook p)
+optimizeCombNode (Look (Look p)) =
+ -- trace "Idempotence Law" $
+ Look p
+optimizeCombNode (NegLook (Look p)) =
+ -- trace "Right Identity Law" $
+ optimizeCombNode (NegLook p)
+optimizeCombNode (Look (NegLook p)) =
+ -- trace "Left Identity Law" $
+ NegLook p
+optimizeCombNode (NegLook (Try p :<|> q)) =
+ -- trace "Transparency Law" $
+ optimizeCombNode (optimizeCombNode (NegLook p) :*> optimizeCombNode (NegLook q))
+optimizeCombNode (Look p :<|> Look q) =
+ -- trace "Distributivity Law" $
+ optimizeCombNode (Look (optimizeCombNode ((Try p) :<|> q)))
+optimizeCombNode (Look (p :$> x)) =
+ -- trace "Interchange Law" $
+ optimizeCombNode (optimizeCombNode (Look p) :$> x)
+optimizeCombNode (Look (f :<$> p)) =
+ -- trace "Interchange Law" $
+ optimizeCombNode (f :<$> optimizeCombNode (Look p))
+optimizeCombNode (p :<*> NegLook q) =
+ -- trace "Absorption Law" $
+ optimizeCombNode (optimizeCombNode (p :<*> Pure H.unit) :<* NegLook q)
+optimizeCombNode (NegLook ((p :$> _))) =
+ -- trace "NegLookIdempotence Law" $
+ optimizeCombNode (NegLook p)
+optimizeCombNode (NegLook ((_ :<$> p))) =
+ -- trace "NegLook Idempotence Law" $
+ optimizeCombNode (NegLook p)
+optimizeCombNode (Try (p :$> x)) =
+ -- trace "Try Interchange Law" $
+ optimizeCombNode (optimizeCombNode (Try p) :$> x)
+optimizeCombNode (Try (f :<$> p)) =
+ -- trace "Try Interchange Law" $
+ optimizeCombNode (f :<$> optimizeCombNode (Try p))
+optimizeCombNode (Branch (Pure (trans -> lr)) l r) =
+ -- trace "Branch Pure Left/Right Law" $
+ case H.value lr of
+ Left value -> optimizeCombNode (l :<*> Pure (trans H.ValueCode{..}))
+ where code = [|| case $$(H.code lr) of Left x -> x ||]
+ Right value -> optimizeCombNode (r :<*> Pure (trans H.ValueCode{..}))
+ where code = [|| case $$(H.code lr) of Right x -> x ||]
+optimizeCombNode (Branch b (Pure (trans -> l)) (Pure (trans -> r))) =
+ -- trace "Branch Generalised Identity Law" $
+ optimizeCombNode (trans H.ValueCode{..} :<$> b)
+ where
+ value = either (H.value l) (H.value r)
+ code = [|| either $$(H.code l) $$(H.code r) ||]
+optimizeCombNode (Branch (x :*> y) p q) =
+ -- trace "Interchange Law" $
+ optimizeCombNode (x :*> optimizeCombNode (Branch y p q))
+optimizeCombNode (Branch b l Empty) =
+ -- trace "Negated Branch Law" $
+ Branch (Pure (trans (H.ValueCode{..})) :<*> b) Empty l
+ where
+ value = either Right Left
+ code = [||either Right Left||]
+optimizeCombNode (Branch (Branch b Empty (Pure (trans -> lr))) Empty br) =
+ -- trace "Branch Fusion Law" $
+ optimizeCombNode (Branch (optimizeCombNode (Pure (trans H.ValueCode{..}) :<*> b)) Empty br)
+ where
+ value Left{} = Left ()
+ value (Right r) = case H.value lr r of
+ Left _ -> Left ()
+ Right rr -> Right rr
+ code = [|| \case Left{} -> Left ()
+ Right r -> case $$(H.code lr) r of
+ Left _ -> Left ()
+ Right rr -> Right rr ||]
+optimizeCombNode (f :<$> Branch b l r) =
+ -- trace "Branch Distributivity Law" $
+ optimizeCombNode (Branch b (optimizeCombNode ((H..) H..@ f :<$> l))
+ (optimizeCombNode ((H..) H..@ f :<$> r)))
+optimizeCombNode (Match a _ps bs Empty)
+ | Foldable.all (\case { Empty -> True; _ -> False }) bs =
+ -- trace "Match Weakening Law" $
+ optimizeCombNode (a :*> Empty)
+optimizeCombNode (Match (Pure (trans -> a)) ps bs d) =
+ -- trace "Match Pure Law" $
+ Foldable.foldr (\(trans -> p, b) next ->
+ if H.value p (H.value a) then b else next
+ ) d (List.zip ps bs)
+optimizeCombNode (f :<$> Match a ps bs d) =
+ -- trace "Match Distributivity Law" $
+ Match a ps (optimizeCombNode . (f :<$>) Functor.<$> bs)
+ (optimizeCombNode (f :<$> d))
- x -> x
+optimizeCombNode x = x
sourcephile / git / haskell / symantic-parser.git / blobdiff