-{-# 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.Bool (Bool(..))
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
+import Data.Foldable (all, foldr)
import Data.Function ((.))
-import qualified Prelude as Pre
+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(..), Code(..), getValue, getCode)
+import Symantic.Parser.Grammar.Pure (ValueCode(..), Value(..), getValue, getCode)
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.Grammar.Pure 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)
-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 'DumpComb' or 'Instr'uctions).
+--
+-- 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.CombPure a -> Comb repr a
+ Satisfy ::
+ Satisfiable repr tok =>
+ [ErrorItem tok] ->
+ H.CombPure (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 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.CombPure (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.CombPure (a -> b) -> Comb repr a -> Comb repr b
+pattern (:$>) :: Comb repr a -> H.CombPure b -> Comb repr b
+pattern (:<$) :: H.CombPure 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 = Hask.Const :<$> x :<*> p
-pattern p :*> x = Hask.Id :<$ p :<*> x
+pattern x :<* p = H.Const :<$> x :<*> p
+pattern p :*> x = H.Id :<$ p :<*> x
infixl 3 :<|>
infixl 4 :<*>, :<*, :*>
infixl 4 :<$>, :<$, :$>
-instance Applicable Grammar where
+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 '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 Grammar (Any repr) where
+ ) => Trans (Comb repr) repr where
trans = \case
Pure a -> pure a
- Satisfy p -> satisfy p
+ 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
Empty -> empty
Branch lr l r -> branch (trans lr) (trans l) (trans r)
- Match cs bs a b -> conditional cs (trans Pre.<$> bs) (trans a) (trans b)
+ 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 'OptimizeGrammar'
--- Bottom-up application of 'optimizeGrammarNode'.
-newtype OptimizeGrammar letName a = OptimizeGrammar { unOptimizeGrammar ::
- Grammar a }
-
-optimizeGrammar :: OptimizeGrammar TH.Name a -> Grammar a
-optimizeGrammar = 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
- trans = unOptimizeGrammar
+-- * 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
instance
- Letable letName Grammar =>
- Letable letName (OptimizeGrammar letName) where
- -- Disable useless calls to 'optimizeGrammarNode'
- -- where 'Def' or 'Ref' have no matching.
- 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)
-
-optimizeGrammarNode :: Grammar a -> Grammar a
-optimizeGrammarNode = \case
- -- Applicable Right Absorption Law
- Empty :<*> _ -> Empty
- Empty :*> _ -> Empty
- Empty :<* _ -> Empty
- -- Applicable Failure Weakening Law
- u :<*> Empty -> optimizeGrammarNode (u :*> Empty)
- u :<* Empty -> optimizeGrammarNode (u :*> Empty)
- -- Branch Absorption Law
- Branch Empty _ _ -> empty
- -- Branch Weakening Law
- Branch b Empty Empty -> optimizeGrammarNode (b :*> Empty)
+ Trans (Comb repr) repr =>
+ Trans (OptimizeComb letName repr) repr where
+ trans = trans . unOptimizeComb
- -- Pure merge optimisation
- -- TODO: use trace to see why it's already handled by other laws
- -- Pure x :<*> Pure y -> Pure (x Hask.:@ y)
- -- Applicable Identity Law
- Hask.Id :<$> x -> x
- -- Flip const optimisation
- Hask.Flip Hask.:@ Hask.Const :<$> u -> optimizeGrammarNode (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) -> optimizeGrammarNode ((Hask.:.) Hask.:@ f Hask.:@ g :<$> p)
- -- Composition Law
- u :<*> (v :<*> w) -> optimizeGrammarNode (optimizeGrammarNode (optimizeGrammarNode ((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 -> optimizeGrammarNode (u :*> optimizeGrammarNode (v :<*> w))
- -- Interchange Law
- u :<*> Pure x -> optimizeGrammarNode (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) -> optimizeGrammarNode (optimizeGrammarNode (u :<*> v) :<* w)
- -- Reassociation Law 3
- u :<*> (v :$> x) -> optimizeGrammarNode (optimizeGrammarNode (u :<*> Pure x) :<* v)
+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)
- -- Left Catch Law
- p@Pure{} :<|> _ -> p
- -- Left Neutral Law
- Empty :<|> u -> u
- -- Right Neutral Law
- u :<|> Empty -> u
- -- Associativity Law
- (u :<|> v) :<|> w -> u :<|> optimizeGrammarNode (v :<|> w)
+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.Satisfiable repr tok =>
+ Comb.Satisfiable (OptimizeComb letName repr) tok
+instance Comb.Selectable (OptimizeComb letName repr)
+instance Comb.Matchable (OptimizeComb letName repr)
+instance Comb.Lookable (OptimizeComb letName repr)
+instance Comb.Foldable (OptimizeComb letName repr)
- -- Identity law
- Pure _ :*> u -> u
- -- Identity law
- (u :$> _) :*> v -> u :*> v
- -- Associativity Law
- u :*> (v :*> w) -> optimizeGrammarNode (optimizeGrammarNode (u :*> v) :*> w)
- -- Identity law
- u :<* Pure _ -> u
- -- Identity law
- u :<* (v :$> _) -> optimizeGrammarNode (u :<* v)
- -- Commutativity Law
- x :<$ u -> optimizeGrammarNode (u :$> x)
- -- Associativity Law
- (u :<* v) :<* w -> optimizeGrammarNode (u :<* optimizeGrammarNode (v :<* w))
+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)
- -- Pure lookahead
- Look p@Pure{} -> p
- -- Dead lookahead
- Look p@Empty -> p
- -- Pure negative-lookahead
- NegLook Pure{} -> Empty
+ -- App Right Absorption Law
+ Empty :<*> _ ->
+ -- trace "App Right Absorption Law" $
+ Empty
+ -- App Left Absorption Law
+ _ :<*> 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))
- -- Dead negative-lookahead
- NegLook Empty -> Pure Hask.unit
- -- Double Negation Law
- NegLook (NegLook p) -> optimizeGrammarNode (Look (Try p) :*> Pure Hask.unit)
- -- Zero Consumption Law
- NegLook (Try p) -> optimizeGrammarNode (NegLook p)
- -- Idempotence Law
- Look (Look p) -> Look p
- -- Right Identity Law
- NegLook (Look p) -> optimizeGrammarNode (NegLook p)
+ -- Alt Left CatchFail Law
+ p@Pure{} :<|> _ ->
+ -- trace "Alt Left CatchFail 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)
- -- Left Identity Law
- Look (NegLook p) -> NegLook p
- -- Transparency Law
- NegLook (Try p :<|> q) -> optimizeGrammarNode (optimizeGrammarNode (NegLook p) :*> optimizeGrammarNode (NegLook q))
- -- Distributivity Law
- Look p :<|> Look q -> optimizeGrammarNode (Look (optimizeGrammarNode (Try p :<|> q)))
- -- Interchange Law
- Look (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Look p) :$> x)
- -- Interchange law
- Look (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Look p))
- -- Absorption Law
- p :<*> NegLook q -> optimizeGrammarNode (optimizeGrammarNode (p :<*> Pure Hask.unit) :<* NegLook q)
- -- Idempotence Law
- NegLook (p :$> _) -> optimizeGrammarNode (NegLook p)
+ -- 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
- NegLook (_ :<$> p) -> optimizeGrammarNode (NegLook p)
- -- Interchange Law
- Try (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Try p) :$> x)
- -- Interchange law
- Try (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Try p))
+ 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 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))
- -- pure Left/Right laws
+ -- 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 -> 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 ||]
- -- Generalised Identity law
+ Left v -> optimizeCombNode (l :<*> Pure (H.CombPure (ValueCode (Value v) c)))
+ where c = [|| case $$(getCode lr) of Left x -> x ||]
+ Right v -> optimizeCombNode (r :<*> Pure (H.CombPure (ValueCode (Value v) c)))
+ where c = [|| case $$(getCode lr) of Right x -> x ||]
+ -- Branch Generalised Identity Law
Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->
- optimizeGrammarNode (Hask.Haskell (ValueCode v c) :<$> b)
+ -- trace "Branch Generalised Identity Law" $
+ optimizeCombNode (H.CombPure (ValueCode v c) :<$> b)
where
v = Value (either (getValue l) (getValue r))
- c = Code [|| either $$(getCode l) $$(getCode r) ||]
- -- Interchange law
+ c = [|| either $$(getCode l) $$(getCode r) ||]
+ -- Branch Interchange Law
Branch (x :*> y) p q ->
- optimizeGrammarNode (x :*> optimizeGrammarNode (Branch y p q))
- -- Negated Branch law
+ -- trace "Branch Interchange Law" $
+ optimizeCombNode (x :*> optimizeCombNode (Branch y p q))
+ -- Branch Empty Right Law
Branch b l Empty ->
- Branch (Pure (Hask.Haskell (ValueCode v c)) :<*> b) Empty l
+ -- trace " Branch Empty Right Law" $
+ Branch (Pure (H.CombPure (ValueCode v c)) :<*> b) Empty l
where
v = Value (either Right Left)
- c = Code [||either Right Left||]
- -- Branch Fusion law
+ c = [||either Right Left||]
+ -- Branch Fusion Law
Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->
- optimizeGrammarNode (Branch (optimizeGrammarNode (Pure (Hask.Haskell (ValueCode (Value v) c)) :<*> b)) Empty br)
+ -- trace "Branch Fusion Law" $
+ optimizeCombNode (Branch (optimizeCombNode (Pure (H.CombPure (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 -> optimizeGrammarNode (Branch b (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> l))
- (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> r)))
+ c = [|| \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" $
+ 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)
+
+ -- NegLook Absorption Law
+ p :<*> NegLook q ->
+ -- trace "EXTRALAW: Neglook Absorption Law" $
+ optimizeCombNode (optimizeCombNode (p :<*> Pure H.unit) :<* NegLook q)
+ -- Infinite loop, because :<* expands to :<*>
+ -}
x -> x
sourcephile / git / haskell / symantic-parser.git / blobdiff