-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# 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.Either (Either(..), either)
import Data.Eq (Eq(..))
-import Data.Foldable (all, foldr)
import Data.Function ((.))
-import Debug.Trace (trace)
-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.Parser.Grammar.Combinators as Comb
-import Symantic.Parser.Staging (ValueCode(..), Value(..), Code(..), getValue, getCode)
+import Symantic.Parser.Haskell ()
import Symantic.Univariant.Letable
import Symantic.Univariant.Trans
-import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Parser.Staging as Hask
+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 :: TH.Name -> Grammar a -> Grammar a
- Ref :: Bool -> TH.Name -> Grammar a
+-- 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 '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 (:<$>) :: 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
+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 TH.Name Grammar where
+ eof = Eof
+instance Letable TH.Name (Comb repr) where
def = Def
ref = Ref
instance MakeLetName TH.Name where
- makeLetName _ = TH.qNewName "let"
+ makeLetName _ = TH.qNewName "name"
-instance Letable letName repr =>
- Letable letName (Any repr)
+-- 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 TH.Name repr
- ) =>
- Trans Grammar (Any repr) where
+ ) => Trans (Comb repr) repr where
trans = \case
- Pure a -> pure a
- Satisfy p -> satisfy p
+ Pure a -> pure (H.optimizeTerm a)
+ Satisfy es p -> satisfy es p
Item -> item
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 (trans lr) (trans l) (trans r)
- Match ps bs a b -> conditional ps (trans Functor.<$> bs) (trans a) (trans b)
+ 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 'OptimizeHaskell'
+newtype OptimizeHaskell letName repr a =
+ OptimizeHaskell { unOptimizeHaskell :: Comb repr a }
+instance
+ 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)
+-}
+
-- * Type 'OptimizeGrammar'
--- Bottom-up application of 'optimizeGrammarNode'.
-newtype OptimizeGrammar letName a = OptimizeGrammar { unOptimizeGrammar ::
- Grammar a }
+-- | Bottom-up application of 'optimizeCombNode'.
+newtype OptimizeGrammar letName repr a =
+ OptimizeGrammar { unOptimizeGrammar :: Comb repr a }
-optimizeGrammar :: OptimizeGrammar TH.Name a -> Grammar a
-optimizeGrammar = unOptimizeGrammar
+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
-type instance Output (OptimizeGrammar letName) = Grammar
-instance Trans Grammar (OptimizeGrammar letName) where
- trans = OptimizeGrammar . optimizeGrammarNode
-instance Trans1 Grammar (OptimizeGrammar letName)
-instance Trans2 Grammar (OptimizeGrammar letName)
-instance Trans3 Grammar (OptimizeGrammar letName)
-instance Trans (OptimizeGrammar letName) Grammar where
+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)
instance
- Letable letName Grammar =>
- Letable letName (OptimizeGrammar letName) where
- -- Disable useless calls to 'optimizeGrammarNode'
+ 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)
-instance Comb.Alternable (OptimizeGrammar letName)
-instance Comb.Charable (OptimizeGrammar letName)
-instance Comb.Selectable (OptimizeGrammar letName)
-instance Comb.Matchable (OptimizeGrammar letName)
-instance Comb.Lookable (OptimizeGrammar letName)
-instance Comb.Foldable (OptimizeGrammar letName)
+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
-optimizeGrammarNode :: Grammar a -> Grammar a
-optimizeGrammarNode = \case
- -- Pure merge optimisation
- -- Pure x :<*> Pure y -> Pure (x Hask.:@ y)
+----------------------------------------------
+-- Destructive optimizations
+----------------------------------------------
- -- Functor Identity Law
- Hask.Id :<$> x ->
- trace "Functor Identity Law" $
- x
- -- Functor Commutativity Law
- x :<$ u ->
- trace "Functor Commutativity Law" $
- optimizeGrammarNode (u :$> x)
- -- Functor Flip Const Law
- Hask.Flip Hask.:@ Hask.Const :<$> u ->
- trace "Functor Flip Const Law" $
- optimizeGrammarNode (u :*> Pure Hask.Id)
- -- Functor Homomorphism Law
- f :<$> Pure x ->
- trace "Functor Homomorphism Law" $
- Pure (f Hask.:@ x)
+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)
- -- 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" $
- optimizeGrammarNode (optimizeGrammarNode (optimizeGrammarNode ((Hask.:.) :<$> u) :<*> v) :<*> w)
- -- App Interchange Law
- u :<*> Pure x ->
- trace "App Interchange Law" $
- optimizeGrammarNode (Hask.Flip Hask.:@ (Hask.:$) Hask.:@ 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" $
- optimizeGrammarNode (u :<* v)
- -- App Left Associativity Law
- (u :<* v) :<* w ->
- trace "App Left Associativity Law" $
- optimizeGrammarNode (u :<* optimizeGrammarNode (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 :<|> optimizeGrammarNode (v :<|> w)
+----------------------------------------------
+-- Applicative optimizations
+----------------------------------------------
- -- 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 Hask.unit
- -- NegLook Double Negation Law
- NegLook (NegLook p) ->
- trace "NegLook Double Negation Law" $
- optimizeGrammarNode (Look (Try p) :*> Pure Hask.unit)
- -- NegLook Zero Consumption Law
- NegLook (Try p) ->
- trace "NegLook Zero Consumption Law" $
- optimizeGrammarNode (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" $
- optimizeGrammarNode (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" $
- optimizeGrammarNode (optimizeGrammarNode (NegLook p) :*> optimizeGrammarNode (NegLook q))
- -- Look Distributivity Law
- Look p :<|> Look q ->
- trace "Look Distributivity Law" $
- optimizeGrammarNode (Look (optimizeGrammarNode (Try p :<|> q)))
- -- Look Interchange Law
- Look (f :<$> p) ->
- trace "Look Interchange Law" $
- optimizeGrammarNode (f :<$> optimizeGrammarNode (Look p))
- -- NegLook Absorption Law
- p :<*> NegLook q ->
- trace "Neglook Absorption Law" $
- optimizeGrammarNode (optimizeGrammarNode (p :<*> Pure Hask.unit) :<* NegLook q)
- -- NegLook Idempotence Right Law
- NegLook (_ :<$> p) ->
- trace "NegLook Idempotence Law" $
- optimizeGrammarNode (NegLook p)
- -- Try Interchange Law
- Try (f :<$> p) ->
- trace "Try Interchange Law" $
- optimizeGrammarNode (f :<$> optimizeGrammarNode (Try p))
+{- 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.
- -- Branch Absorption Law
- Branch Empty _ _ ->
- trace "Branch Absorption Law" $
- empty
- -- Branch Weakening Law
- Branch b Empty Empty ->
- trace "Branch Weakening Law" $
- optimizeGrammarNode (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 -> optimizeGrammarNode (l :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
- where c = Code [|| case $$(getCode lr) of Left x -> x ||]
- Right v -> optimizeGrammarNode (r :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
- where c = Code [|| case $$(getCode lr) of Right x -> x ||]
- -- Branch Generalised Identity Law
- Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->
- trace "Branch Generalised Identity Law" $
- optimizeGrammarNode (Hask.Haskell (ValueCode v c) :<$> b)
- where
- v = Value (either (getValue l) (getValue r))
- c = Code [|| either $$(getCode l) $$(getCode r) ||]
- -- Branch Interchange Law
- Branch (x :*> y) p q ->
- trace "Branch Interchange Law" $
- optimizeGrammarNode (x :*> optimizeGrammarNode (Branch y p q))
- -- Branch Empty Right Law
- Branch b l Empty ->
- trace " Branch Empty Right Law" $
- 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 (trans -> lr))) Empty br ->
- trace "Branch Fusion Law" $
- optimizeGrammarNode (Branch (optimizeGrammarNode (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 ||]
- -- Branch Distributivity Law
- f :<$> Branch b l r ->
- trace "Branch Distributivity Law" $
- optimizeGrammarNode (Branch b (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> l)) (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> r)))
+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)
- -- 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" $
- optimizeGrammarNode (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 (optimizeGrammarNode . (f :<$>) Functor.<$> bs) a (optimizeGrammarNode (f :<$> d))
+----------------------------------------------
+-- Alternative optimizations
+----------------------------------------------
- {- Possibly useless laws to be tested
- Empty :*> _ -> Empty
- Empty :<* _ -> Empty
- -- App Definition of *> Law
- Hask.Flip Hask.:@ Hask.Const :<$> p :<*> q ->
- trace "EXTRALAW: App Definition of *> Law" $
- p :*> q
- -- App Definition of <* Law
- Hask.Const :<$> p :<*> q ->
- trace "EXTRALAW: App Definition of <* Law" $
- p :<* q
+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)
- -- 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" $
- optimizeGrammarNode ((Hask.:.) Hask.:@ f Hask.:@ g :<$> p)
- -- Applicable Failure Weakening Law
- u :<* Empty ->
- trace "EXTRALAW: App Failure Weakening Law" $
- optimizeGrammarNode (u :*> Empty)
- Try (p :$> x) ->
- trace "EXTRALAW: Try Interchange Right Law" $
- optimizeGrammarNode (optimizeGrammarNode (Try p) :$> x)
- -- App Reassociation Law 1
- (u :*> v) :<*> w ->
- trace "EXTRALAW: App Reassociation Law 1" $
- optimizeGrammarNode (u :*> optimizeGrammarNode (v :<*> w))
- -- App Reassociation Law 2
- u :<*> (v :<* w) ->
- trace "EXTRALAW: App Reassociation Law 2" $
- optimizeGrammarNode (optimizeGrammarNode (u :<*> v) :<* w)
- -- App Right Associativity Law
- u :*> (v :*> w) ->
- trace "EXTRALAW: App Right Associativity Law" $
- optimizeGrammarNode (optimizeGrammarNode (u :*> v) :*> w)
- -- App Reassociation Law 3
- u :<*> (v :$> x) ->
- trace "EXTRALAW: App Reassociation Law 3" $
- optimizeGrammarNode (optimizeGrammarNode (u :<*> Pure x) :<* v)
+----------------------------------------------
+-- Sequencing optimizations
+----------------------------------------------
- Look (p :$> x) ->
- optimizeGrammarNode (optimizeGrammarNode (Look p) :$> x)
- NegLook (p :$> _) -> optimizeGrammarNode (NegLook p)
- -}
+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