Trace and organize grammar optimizing rules

diff --git a/src/Symantic/Parser/Grammar/Optimize.hs b/src/Symantic/Parser/Grammar/Optimize.hs
index c0a996fd2076ff3b70d7977dd90b376351a60dbf..9149cf6555fefb52b8ee17dcc7fa4d0c2b120f99 100644 (file)
--- a/src/Symantic/Parser/Grammar/Optimize.hs
+++ b/src/Symantic/Parser/Grammar/Optimize.hs
@@ -11,6 +11,8 @@ 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.List as List
 
@@ -143,144 +145,188 @@ 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)
-  -- Match Absorbtion Law
-  Match _ _ Empty d -> d
-  -- Match Weakening Law
-  Match _ bs a Empty
-    | all (\case {Empty -> True; _ -> False}) bs -> optimizeGrammarNode (a :*> Empty)
-  -- Pure Match Law
-  Match ps bs (Pure (trans -> a)) d -> foldr (\(trans -> p, b) next -> if getValue p (getValue a) then b else next) d (List.zip ps bs)
-
   -- 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)
 
-  -- 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)
+  -- 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)
 
-  -- Pure Left Identity Law
-  Pure _ :*> u -> u
-  -- Functor Left Identity Law
-  (u :$> _) :*> v -> u :*> v
-  -- Associativity Law
-  u :*> (v :*> w) -> optimizeGrammarNode (optimizeGrammarNode (u :*> v) :*> w)
-  -- Pure Right Identity Law
-  u :<* Pure _ -> u
-  -- Functor Right Identity Law
-  u :<* (v :$> _) -> optimizeGrammarNode (u :<* v)
-  -- Commutativity Law
-  x :<$ u -> optimizeGrammarNode (u :$> x)
-  -- Associativity Law
-  (u :<* v) :<* w -> optimizeGrammarNode (u :<* optimizeGrammarNode (v :<* w))
+  -- 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))
 
-  -- Pure lookahead
-  Look p@Pure{} -> p
-  -- Dead lookahead
-  Look p@Empty -> p
-  -- Pure negative-lookahead
-  NegLook Pure{} -> Empty
+  -- 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)
 
-  -- 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)
-
-  -- 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 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
-  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" $
+    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))
 
-  -- 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" $
+    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 ||]
-  -- Generalised Identity Law
+  -- 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) ||]
-  -- Interchange Law
+  -- Branch Interchange Law
   Branch (x :*> y) p q ->
+    trace "Branch Interchange Law" $
     optimizeGrammarNode (x :*> optimizeGrammarNode (Branch y p q))
-  -- Negated Branch Law
+  -- 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 ()
@@ -292,9 +338,73 @@ optimizeGrammarNode = \case
                                    Left _ -> Left ()
                                    Right rr -> Right rr ||]
   -- Branch Distributivity Law
-  f :<$> Branch b l r -> optimizeGrammarNode (Branch b (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> l))
-                                           (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> r)))
+  f :<$> Branch b l r ->
+    trace "Branch Distributivity Law" $
+    optimizeGrammarNode (Branch b (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> l)) (optimizeGrammarNode ((Hask..@) (Hask..) 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" $
+      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 -> Match ps (optimizeGrammarNode . (f :<$>) Functor.<$> bs) a (optimizeGrammarNode (f :<$> d))
+  f :<$> Match ps bs a d ->
+    trace "Match Distributivity Law" $
+    Match ps (optimizeGrammarNode . (f :<$>) Functor.<$> bs) a (optimizeGrammarNode (f :<$> d))
+
+  {- 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
+
+  -- 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)
+
+  Look (p :$> x) ->
+    optimizeGrammarNode (optimizeGrammarNode (Look p) :$> x)
+  NegLook (p :$> _) -> optimizeGrammarNode (NegLook p)
+  -}
 
   x -> x