src/Symantic/Parser/Grammar/Optimize.hs

   1 {-# LANGUAGE PatternSynonyms #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 {-# LANGUAGE UndecidableInstances #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Symantic.Parser.Grammar.Optimize where
   7
   8 import Data.Bool (Bool(..))
   9 import Data.Char (Char)
  10 import Data.Either (Either(..), either)
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (all, foldr)
  13 import Data.Function ((.))
  14 import Debug.Trace (trace)
  15 import Data.Function (($))
  16 import qualified Data.Functor as Functor
  17 import qualified Data.List as List
  18
  19 import Symantic.Parser.Grammar.Combinators as Comb
  20 import Symantic.Parser.Staging (ValueCode(..), Value(..),  Code(..), getValue, getCode)
  21 import Symantic.Univariant.Letable
  22 import Symantic.Univariant.Trans
  23 import qualified Language.Haskell.TH.Syntax as TH
  24 import qualified Symantic.Parser.Staging as Hask
  25
  26 -- * Type 'Grammar'
  27 data Grammar a where
  28   Pure :: Hask.Haskell a -> Grammar a
  29   Satisfy :: Hask.Haskell (Char -> Bool) -> Grammar Char
  30   Item :: Grammar Char
  31   Try :: Grammar a -> Grammar a
  32   Look :: Grammar a -> Grammar a
  33   NegLook :: Grammar a -> Grammar ()
  34   (:<*>) :: Grammar (a -> b) -> Grammar a -> Grammar b
  35   (:<|>) :: Grammar a -> Grammar a -> Grammar a
  36   Empty :: Grammar a
  37   Branch :: Grammar (Either a b) -> Grammar (a -> c) -> Grammar (b -> c) -> Grammar c
  38   Match :: Eq a => [Hask.Haskell (a -> Bool)] -> [Grammar b] -> Grammar a -> Grammar b -> Grammar b
  39   ChainPre :: Grammar (a -> a) -> Grammar a -> Grammar a
  40   ChainPost :: Grammar a -> Grammar (a -> a) -> Grammar a
  41   Def :: TH.Name -> Grammar a -> Grammar a
  42   Ref :: Bool -> TH.Name -> Grammar a
  43
  44 pattern (:<$>) :: Hask.Haskell (a -> b) -> Grammar a -> Grammar b
  45 pattern (:$>) :: Grammar a -> Hask.Haskell b -> Grammar b
  46 pattern (:<$) :: Hask.Haskell a -> Grammar b -> Grammar a
  47 pattern (:*>) :: Grammar a -> Grammar b -> Grammar b
  48 pattern (:<*) :: Grammar a -> Grammar b -> Grammar a
  49 pattern x :<$> p = Pure x :<*> p
  50 pattern p :$> x = p :*> Pure x
  51 pattern x :<$ p = Pure x :<* p
  52 pattern x :<* p = Hask.Const :<$> x :<*> p
  53 pattern p :*> x = Hask.Id :<$ p :<*> x
  54
  55 infixl 3 :<|>
  56 infixl 4 :<*>, :<*, :*>
  57 infixl 4 :<$>, :<$, :$>
  58
  59 instance Applicable Grammar where
  60   pure = Pure
  61   (<*>) = (:<*>)
  62 instance Alternable Grammar where
  63   (<|>) = (:<|>)
  64   empty = Empty
  65   try = Try
  66 instance Selectable Grammar where
  67   branch = Branch
  68 instance Matchable Grammar where
  69   conditional = Match
  70 instance Foldable Grammar where
  71   chainPre = ChainPre
  72   chainPost = ChainPost
  73 instance Charable Grammar where
  74   satisfy = Satisfy
  75 instance Lookable Grammar where
  76   look = Look
  77   negLook = NegLook
  78 instance Letable TH.Name Grammar where
  79   def = Def
  80   ref = Ref
  81 instance MakeLetName TH.Name where
  82   makeLetName _ = TH.qNewName "let"
  83
  84 instance Letable letName repr =>
  85          Letable letName (Any repr)
  86 instance
  87   ( Applicable repr
  88   , Alternable repr
  89   , Selectable repr
  90   , Foldable repr
  91   , Charable repr
  92   , Lookable repr
  93   , Matchable repr
  94   , Letable TH.Name repr
  95   ) =>
  96   Trans Grammar (Any repr) where
  97   trans = \case
  98     Pure a -> pure a
  99     Satisfy p -> satisfy p
 100     Item -> item
 101     Try x -> try (trans x)
 102     Look x -> look (trans x)
 103     NegLook x -> negLook (trans x)
 104     x :<*> y -> trans x <*> trans y
 105     x :<|> y -> trans x <|> trans y
 106     Empty -> empty
 107     Branch lr l r -> branch (trans lr) (trans l) (trans r)
 108     Match ps bs a b -> conditional ps (trans Functor.<$> bs) (trans a) (trans b)
 109     ChainPre x y -> chainPre (trans x) (trans y)
 110     ChainPost x y -> chainPost (trans x) (trans y)
 111     Def n x -> def n (trans x)
 112     Ref r n -> ref r n
 113
 114 -- * Type 'OptimizeGrammar'
 115 -- Bottom-up application of 'optimizeGrammarNode'.
 116 newtype OptimizeGrammar letName a = OptimizeGrammar { unOptimizeGrammar ::
 117   Grammar a }
 118
 119 optimizeGrammar :: OptimizeGrammar TH.Name a -> Grammar a
 120 optimizeGrammar = unOptimizeGrammar
 121
 122 type instance Output (OptimizeGrammar letName) = Grammar
 123 instance Trans Grammar (OptimizeGrammar letName) where
 124   trans = OptimizeGrammar . optimizeGrammarNode
 125 instance Trans1 Grammar (OptimizeGrammar letName)
 126 instance Trans2 Grammar (OptimizeGrammar letName)
 127 instance Trans3 Grammar (OptimizeGrammar letName)
 128 instance Trans (OptimizeGrammar letName) Grammar where
 129   trans = unOptimizeGrammar
 130
 131 instance
 132   Letable letName Grammar =>
 133   Letable letName (OptimizeGrammar letName) where
 134   -- Disable useless calls to 'optimizeGrammarNode'
 135   -- because 'Def' or 'Ref' have no matching in it.
 136   def n = OptimizeGrammar . def n . unOptimizeGrammar
 137   ref r n = OptimizeGrammar (ref r n)
 138 instance Comb.Applicable (OptimizeGrammar letName)
 139 instance Comb.Alternable (OptimizeGrammar letName)
 140 instance Comb.Charable (OptimizeGrammar letName)
 141 instance Comb.Selectable (OptimizeGrammar letName)
 142 instance Comb.Matchable (OptimizeGrammar letName)
 143 instance Comb.Lookable (OptimizeGrammar letName)
 144 instance Comb.Foldable (OptimizeGrammar letName)
 145
 146 optimizeGrammarNode :: Grammar a -> Grammar a
 147 optimizeGrammarNode = \case
 148   -- Pure merge optimisation
 149   -- Pure x :<*> Pure y -> Pure (x Hask.:@ y)
 150
 151   -- Functor Identity Law
 152   Hask.Id :<$> x ->
 153     trace "Functor Identity Law" $
 154     x
 155   -- Functor Commutativity Law
 156   x :<$ u ->
 157     trace "Functor Commutativity Law" $
 158     optimizeGrammarNode (u :$> x)
 159   -- Functor Flip Const Law
 160   Hask.Flip Hask.:@ Hask.Const :<$> u ->
 161     trace "Functor Flip Const Law" $
 162     optimizeGrammarNode (u :*> Pure Hask.Id)
 163   -- Functor Homomorphism Law
 164   f :<$> Pure x ->
 165     trace "Functor Homomorphism Law" $
 166     Pure (f Hask.:@ x)
 167
 168   -- App Right Absorption Law
 169   Empty :<*> _ ->
 170     trace "App Right Absorption Law" $
 171     Empty
 172   _ :<*> Empty ->
 173     -- In Parsley: this is only a weakening to u :*> Empty
 174     -- but here :*> is an alias to :<*>
 175     -- hence it would loop on itself forever.
 176     trace "App Left Absorption Law" $
 177     Empty
 178   -- App Composition Law
 179   u :<*> (v :<*> w) ->
 180     trace "App Composition Law" $
 181     optimizeGrammarNode (optimizeGrammarNode (optimizeGrammarNode ((Hask.:.) :<$> u) :<*> v) :<*> w)
 182   -- App Interchange Law
 183   u :<*> Pure x ->
 184     trace "App Interchange Law" $
 185     optimizeGrammarNode (Hask.Flip Hask.:@ (Hask.:$) Hask.:@ x :<$> u)
 186   -- App Left Absorption Law
 187   p :<* (_ :<$> q) ->
 188     trace "App Left Absorption Law" $
 189     p :<* q
 190   -- App Right Absorption Law
 191   (_ :<$> p) :*> q ->
 192     trace "App Right Absorption Law" $
 193     p :*> q
 194   -- App Pure Left Identity Law
 195   Pure _ :*> u ->
 196     trace "App Pure Left Identity Law" $
 197     u
 198   -- App Functor Left Identity Law
 199   (u :$> _) :*> v ->
 200     trace "App Functor Left Identity Law" $
 201     u :*> v
 202   -- App Pure Right Identity Law
 203   u :<* Pure _ ->
 204     trace "App Pure Right Identity Law" $
 205     u
 206   -- App Functor Right Identity Law
 207   u :<* (v :$> _) ->
 208     trace "App Functor Right Identity Law" $
 209     optimizeGrammarNode (u :<* v)
 210   -- App Left Associativity Law
 211   (u :<* v) :<* w ->
 212     trace "App Left Associativity Law" $
 213     optimizeGrammarNode (u :<* optimizeGrammarNode (v :<* w))
 214
 215   -- Alt Left Catch Law
 216   p@Pure{} :<|> _ ->
 217     trace "Alt Left Catch Law" $
 218     p
 219   -- Alt Left Neutral Law
 220   Empty :<|> u ->
 221     trace "Alt Left Neutral Law" $
 222     u
 223   -- All Right Neutral Law
 224   u :<|> Empty ->
 225     trace "Alt Right Neutral Law" $
 226     u
 227   -- Alt Associativity Law
 228   (u :<|> v) :<|> w ->
 229     trace "Alt Associativity Law" $
 230     u :<|> optimizeGrammarNode (v :<|> w)
 231
 232   -- Look Pure Law
 233   Look p@Pure{} ->
 234     trace "Look Pure Law" $
 235     p
 236   -- Look Empty Law
 237   Look p@Empty ->
 238     trace "Look Empty Law" $
 239     p
 240   -- NegLook Pure Law
 241   NegLook Pure{} ->
 242     trace "NegLook Pure Law" $
 243     Empty
 244   -- NegLook Empty Law
 245   NegLook Empty ->
 246     trace "NegLook Dead Law" $
 247     Pure Hask.unit
 248   -- NegLook Double Negation Law
 249   NegLook (NegLook p) ->
 250     trace "NegLook Double Negation Law" $
 251     optimizeGrammarNode (Look (Try p) :*> Pure Hask.unit)
 252   -- NegLook Zero Consumption Law
 253   NegLook (Try p) ->
 254     trace "NegLook Zero Consumption Law" $
 255     optimizeGrammarNode (NegLook p)
 256   -- Idempotence Law
 257   Look (Look p) ->
 258     trace "Look Idempotence Law" $
 259     Look p
 260   -- Look Right Identity Law
 261   NegLook (Look p) ->
 262     trace "Look Right Identity Law" $
 263     optimizeGrammarNode (NegLook p)
 264   -- Look Left Identity Law
 265   Look (NegLook p) ->
 266     trace "Look Left Identity Law" $
 267     NegLook p
 268   -- NegLook Transparency Law
 269   NegLook (Try p :<|> q) ->
 270     trace "NegLook Transparency Law" $
 271     optimizeGrammarNode (optimizeGrammarNode (NegLook p) :*> optimizeGrammarNode (NegLook q))
 272   -- Look Distributivity Law
 273   Look p :<|> Look q ->
 274     trace "Look Distributivity Law" $
 275     optimizeGrammarNode (Look (optimizeGrammarNode (Try p :<|> q)))
 276   -- Look Interchange Law
 277   Look (f :<$> p) ->
 278     trace "Look Interchange Law" $
 279     optimizeGrammarNode (f :<$> optimizeGrammarNode (Look p))
 280   -- NegLook Absorption Law
 281   p :<*> NegLook q ->
 282     trace "Neglook Absorption Law" $
 283     optimizeGrammarNode (optimizeGrammarNode (p :<*> Pure Hask.unit) :<* NegLook q)
 284   -- NegLook Idempotence Right Law
 285   NegLook (_ :<$> p) ->
 286     trace "NegLook Idempotence Law" $
 287     optimizeGrammarNode (NegLook p)
 288   -- Try Interchange Law
 289   Try (f :<$> p) ->
 290     trace "Try Interchange Law" $
 291     optimizeGrammarNode (f :<$> optimizeGrammarNode (Try p))
 292
 293   -- Branch Absorption Law
 294   Branch Empty _ _ ->
 295     trace "Branch Absorption Law" $
 296     empty
 297   -- Branch Weakening Law
 298   Branch b Empty Empty ->
 299     trace "Branch Weakening Law" $
 300     optimizeGrammarNode (b :*> Empty)
 301   -- Branch Pure Left/Right Laws
 302   Branch (Pure (trans -> lr)) l r ->
 303     trace "Branch Pure Left/Right Law" $
 304     case getValue lr of
 305      Left v -> optimizeGrammarNode (l :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
 306       where c = Code [|| case $$(getCode lr) of Left x -> x ||]
 307      Right v -> optimizeGrammarNode (r :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
 308       where c = Code [|| case $$(getCode lr) of Right x -> x ||]
 309   -- Branch Generalised Identity Law
 310   Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->
 311     trace "Branch Generalised Identity Law" $
 312     optimizeGrammarNode (Hask.Haskell (ValueCode v c) :<$> b)
 313     where
 314     v = Value (either (getValue l) (getValue r))
 315     c = Code [|| either $$(getCode l) $$(getCode r) ||]
 316   -- Branch Interchange Law
 317   Branch (x :*> y) p q ->
 318     trace "Branch Interchange Law" $
 319     optimizeGrammarNode (x :*> optimizeGrammarNode (Branch y p q))
 320   -- Branch Empty Right Law
 321   Branch b l Empty ->
 322     trace " Branch Empty Right Law" $
 323     Branch (Pure (Hask.Haskell (ValueCode v c)) :<*> b) Empty l
 324     where
 325     v = Value (either Right Left)
 326     c = Code [||either Right Left||]
 327   -- Branch Fusion Law
 328   Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->
 329     trace "Branch Fusion Law" $
 330     optimizeGrammarNode (Branch (optimizeGrammarNode (Pure (Hask.Haskell (ValueCode (Value v) c)) :<*> b)) Empty br)
 331     where
 332     v Left{} = Left ()
 333     v (Right r) = case getValue lr r of
 334                    Left _ -> Left ()
 335                    Right rr -> Right rr
 336     c = Code [|| \case Left{} -> Left ()
 337                        Right r -> case $$(getCode lr) r of
 338                                    Left _ -> Left ()
 339                                    Right rr -> Right rr ||]
 340   -- Branch Distributivity Law
 341   f :<$> Branch b l r ->
 342     trace "Branch Distributivity Law" $
 343     optimizeGrammarNode (Branch b (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> l)) (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> r)))
 344
 345   -- Match Absorption Law
 346   Match _ _ Empty d ->
 347     trace "Match Absorption Law" $
 348     d
 349   -- Match Weakening Law
 350   Match _ bs a Empty
 351     | all (\case {Empty -> True; _ -> False}) bs ->
 352       trace "Match Weakening Law" $
 353       optimizeGrammarNode (a :*> Empty)
 354   -- Match Pure Law
 355   Match ps bs (Pure (trans -> a)) d ->
 356     trace "Match Pure Law" $
 357     foldr (\(trans -> p, b) next -> if getValue p (getValue a) then b else next) d (List.zip ps bs)
 358   -- Match Distributivity Law
 359   f :<$> Match ps bs a d ->
 360     trace "Match Distributivity Law" $
 361     Match ps (optimizeGrammarNode . (f :<$>) Functor.<$> bs) a (optimizeGrammarNode (f :<$> d))
 362
 363   {- Possibly useless laws to be tested
 364   Empty  :*> _ -> Empty
 365   Empty :<*  _ -> Empty
 366   -- App Definition of *> Law
 367   Hask.Flip Hask.:@ Hask.Const :<$> p :<*> q ->
 368     trace "EXTRALAW: App Definition of *> Law" $
 369     p :*> q
 370   -- App Definition of <* Law
 371   Hask.Const :<$> p :<*> q ->
 372     trace "EXTRALAW: App Definition of <* Law" $
 373     p :<* q
 374
 375   -- Functor Composition Law
 376   -- (a shortcut that could also have been be caught
 377   -- by the Composition Law and Homomorphism Law)
 378   f :<$> (g :<$> p) ->
 379     trace "EXTRALAW: Functor Composition Law" $
 380     optimizeGrammarNode ((Hask.:.) Hask.:@ f Hask.:@ g :<$> p)
 381   -- Applicable Failure Weakening Law
 382   u :<*  Empty ->
 383     trace "EXTRALAW: App Failure Weakening Law" $
 384     optimizeGrammarNode (u :*> Empty)
 385   Try (p :$> x) ->
 386     trace "EXTRALAW: Try Interchange Right Law" $
 387     optimizeGrammarNode (optimizeGrammarNode (Try p) :$> x)
 388   -- App Reassociation Law 1
 389   (u :*> v) :<*> w ->
 390     trace "EXTRALAW: App Reassociation Law 1" $
 391     optimizeGrammarNode (u :*> optimizeGrammarNode (v :<*> w))
 392   -- App Reassociation Law 2
 393   u :<*> (v :<* w) ->
 394     trace "EXTRALAW: App Reassociation Law 2" $
 395     optimizeGrammarNode (optimizeGrammarNode (u :<*> v) :<* w)
 396   -- App Right Associativity Law
 397   u :*> (v :*> w) ->
 398     trace "EXTRALAW: App Right Associativity Law" $
 399     optimizeGrammarNode (optimizeGrammarNode (u :*> v) :*> w)
 400   -- App Reassociation Law 3
 401   u :<*> (v :$> x) ->
 402     trace "EXTRALAW: App Reassociation Law 3" $
 403     optimizeGrammarNode (optimizeGrammarNode (u :<*> Pure x) :<* v)
 404
 405   Look (p :$> x) ->
 406     optimizeGrammarNode (optimizeGrammarNode (Look p) :$> x)
 407   NegLook (p :$> _) -> optimizeGrammarNode (NegLook p)
 408   -}
 409
 410   x -> x