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 qualified Data.Functor as Functor
  15 import qualified Data.List as List
  16
  17 import Symantic.Parser.Grammar.Combinators as Comb
  18 import Symantic.Parser.Staging (ValueCode(..), Value(..),  Code(..), getValue, getCode)
  19 import Symantic.Univariant.Letable
  20 import Symantic.Univariant.Trans
  21 import qualified Language.Haskell.TH.Syntax as TH
  22 import qualified Symantic.Parser.Staging as Hask
  23
  24 -- * Type 'Grammar'
  25 data Grammar a where
  26   Pure :: Hask.Haskell a -> Grammar a
  27   Satisfy :: Hask.Haskell (Char -> Bool) -> Grammar Char
  28   Item :: Grammar Char
  29   Try :: Grammar a -> Grammar a
  30   Look :: Grammar a -> Grammar a
  31   NegLook :: Grammar a -> Grammar ()
  32   (:<*>) :: Grammar (a -> b) -> Grammar a -> Grammar b
  33   (:<|>) :: Grammar a -> Grammar a -> Grammar a
  34   Empty :: Grammar a
  35   Branch :: Grammar (Either a b) -> Grammar (a -> c) -> Grammar (b -> c) -> Grammar c
  36   Match :: Eq a => [Hask.Haskell (a -> Bool)] -> [Grammar b] -> Grammar a -> Grammar b -> Grammar b
  37   ChainPre :: Grammar (a -> a) -> Grammar a -> Grammar a
  38   ChainPost :: Grammar a -> Grammar (a -> a) -> Grammar a
  39   Def :: TH.Name -> Grammar a -> Grammar a
  40   Ref :: Bool -> TH.Name -> Grammar a
  41
  42 pattern (:<$>) :: Hask.Haskell (a -> b) -> Grammar a -> Grammar b
  43 pattern (:$>) :: Grammar a -> Hask.Haskell b -> Grammar b
  44 pattern (:<$) :: Hask.Haskell a -> Grammar b -> Grammar a
  45 pattern (:*>) :: Grammar a -> Grammar b -> Grammar b
  46 pattern (:<*) :: Grammar a -> Grammar b -> Grammar a
  47 pattern x :<$> p = Pure x :<*> p
  48 pattern p :$> x = p :*> Pure x
  49 pattern x :<$ p = Pure x :<* p
  50 pattern x :<* p = Hask.Const :<$> x :<*> p
  51 pattern p :*> x = Hask.Id :<$ p :<*> x
  52
  53 infixl 3 :<|>
  54 infixl 4 :<*>, :<*, :*>
  55 infixl 4 :<$>, :<$, :$>
  56
  57 instance Applicable Grammar where
  58   pure = Pure
  59   (<*>) = (:<*>)
  60 instance Alternable Grammar where
  61   (<|>) = (:<|>)
  62   empty = Empty
  63   try = Try
  64 instance Selectable Grammar where
  65   branch = Branch
  66 instance Matchable Grammar where
  67   conditional = Match
  68 instance Foldable Grammar where
  69   chainPre = ChainPre
  70   chainPost = ChainPost
  71 instance Charable Grammar where
  72   satisfy = Satisfy
  73 instance Lookable Grammar where
  74   look = Look
  75   negLook = NegLook
  76 instance Letable TH.Name Grammar where
  77   def = Def
  78   ref = Ref
  79 instance MakeLetName TH.Name where
  80   makeLetName _ = TH.qNewName "let"
  81
  82 instance Letable letName repr =>
  83          Letable letName (Any repr)
  84 instance
  85   ( Applicable repr
  86   , Alternable repr
  87   , Selectable repr
  88   , Foldable repr
  89   , Charable repr
  90   , Lookable repr
  91   , Matchable repr
  92   , Letable TH.Name repr
  93   ) =>
  94   Trans Grammar (Any repr) where
  95   trans = \case
  96     Pure a -> pure a
  97     Satisfy p -> satisfy p
  98     Item -> item
  99     Try x -> try (trans x)
 100     Look x -> look (trans x)
 101     NegLook x -> negLook (trans x)
 102     x :<*> y -> trans x <*> trans y
 103     x :<|> y -> trans x <|> trans y
 104     Empty -> empty
 105     Branch lr l r -> branch (trans lr) (trans l) (trans r)
 106     Match ps bs a b -> conditional ps (trans Functor.<$> bs) (trans a) (trans b)
 107     ChainPre x y -> chainPre (trans x) (trans y)
 108     ChainPost x y -> chainPost (trans x) (trans y)
 109     Def n x -> def n (trans x)
 110     Ref r n -> ref r n
 111
 112 -- * Type 'OptimizeGrammar'
 113 -- Bottom-up application of 'optimizeGrammarNode'.
 114 newtype OptimizeGrammar letName a = OptimizeGrammar { unOptimizeGrammar ::
 115   Grammar a }
 116
 117 optimizeGrammar :: OptimizeGrammar TH.Name a -> Grammar a
 118 optimizeGrammar = unOptimizeGrammar
 119
 120 type instance Output (OptimizeGrammar letName) = Grammar
 121 instance Trans Grammar (OptimizeGrammar letName) where
 122   trans = OptimizeGrammar . optimizeGrammarNode
 123 instance Trans1 Grammar (OptimizeGrammar letName)
 124 instance Trans2 Grammar (OptimizeGrammar letName)
 125 instance Trans3 Grammar (OptimizeGrammar letName)
 126 instance Trans (OptimizeGrammar letName) Grammar where
 127   trans = unOptimizeGrammar
 128
 129 instance
 130   Letable letName Grammar =>
 131   Letable letName (OptimizeGrammar letName) where
 132   -- Disable useless calls to 'optimizeGrammarNode'
 133   -- because 'Def' or 'Ref' have no matching in it.
 134   def n = OptimizeGrammar . def n . unOptimizeGrammar
 135   ref r n = OptimizeGrammar (ref r n)
 136 instance Comb.Applicable (OptimizeGrammar letName)
 137 instance Comb.Alternable (OptimizeGrammar letName)
 138 instance Comb.Charable (OptimizeGrammar letName)
 139 instance Comb.Selectable (OptimizeGrammar letName)
 140 instance Comb.Matchable (OptimizeGrammar letName)
 141 instance Comb.Lookable (OptimizeGrammar letName)
 142 instance Comb.Foldable (OptimizeGrammar letName)
 143
 144 optimizeGrammarNode :: Grammar a -> Grammar a
 145 optimizeGrammarNode = \case
 146   -- Applicable Right Absorption Law
 147   Empty :<*> _ -> Empty
 148   Empty  :*> _ -> Empty
 149   Empty :<*  _ -> Empty
 150   -- Applicable Failure Weakening Law
 151   u :<*> Empty -> optimizeGrammarNode (u :*> Empty)
 152   u :<*  Empty -> optimizeGrammarNode (u :*> Empty)
 153   -- Branch Absorption Law
 154   Branch Empty _ _ -> empty
 155   -- Branch Weakening Law
 156   Branch b Empty Empty -> optimizeGrammarNode (b :*> Empty)
 157   -- Match Absorbtion Law
 158   Match _ _ Empty d -> d
 159   -- Match Weakening Law
 160   Match _ bs a Empty
 161     | all (\case {Empty -> True; _ -> False}) bs -> optimizeGrammarNode (a :*> Empty)
 162   -- Pure Match Law
 163   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)
 164
 165   -- Pure merge optimisation
 166   -- TODO: use trace to see why it's already handled by other laws
 167   -- Pure x :<*> Pure y -> Pure (x Hask.:@ y)
 168   -- Applicable Identity Law
 169   Hask.Id :<$> x -> x
 170   -- Flip const optimisation
 171   Hask.Flip Hask.:@ Hask.Const :<$> u -> optimizeGrammarNode (u :*> Pure Hask.Id)
 172   -- Homomorphism Law
 173   f :<$> Pure x -> Pure (f Hask.:@ x)
 174   -- Functor Composition Law
 175   -- (a shortcut that could also have been be caught
 176   -- by the Composition Law and Homomorphism Law)
 177   f :<$> (g :<$> p) -> optimizeGrammarNode ((Hask.:.) Hask.:@ f Hask.:@ g :<$> p)
 178   -- Composition Law
 179   u :<*> (v :<*> w) -> optimizeGrammarNode (optimizeGrammarNode (optimizeGrammarNode ((Hask.:.) :<$> u) :<*> v) :<*> w)
 180   -- Definition of *>
 181   Hask.Flip Hask.:@ Hask.Const :<$> p :<*> q -> p :*> q
 182   -- Definition of <*
 183   Hask.Const :<$> p :<*> q -> p :<* q
 184   -- Reassociation Law 1
 185   (u :*> v) :<*> w -> optimizeGrammarNode (u :*> optimizeGrammarNode (v :<*> w))
 186   -- Interchange Law
 187   u :<*> Pure x -> optimizeGrammarNode (Hask.Flip Hask.:@ (Hask.:$) Hask.:@ x :<$> u)
 188   -- Right Absorption Law
 189   (_ :<$> p) :*> q -> p :*> q
 190   -- Left Absorption Law
 191   p :<* (_ :<$> q) -> p :<* q
 192   -- Reassociation Law 2
 193   u :<*> (v :<* w) -> optimizeGrammarNode (optimizeGrammarNode (u :<*> v) :<* w)
 194   -- Reassociation Law 3
 195   u :<*> (v :$> x) -> optimizeGrammarNode (optimizeGrammarNode (u :<*> Pure x) :<* v)
 196
 197   -- Left Catch Law
 198   p@Pure{} :<|> _ -> p
 199   -- Left Neutral Law
 200   Empty :<|> u -> u
 201   -- Right Neutral Law
 202   u :<|> Empty -> u
 203   -- Associativity Law
 204   (u :<|> v) :<|> w -> u :<|> optimizeGrammarNode (v :<|> w)
 205
 206   -- Pure Left Identity Law
 207   Pure _ :*> u -> u
 208   -- Functor Left Identity Law
 209   (u :$> _) :*> v -> u :*> v
 210   -- Associativity Law
 211   u :*> (v :*> w) -> optimizeGrammarNode (optimizeGrammarNode (u :*> v) :*> w)
 212   -- Pure Right Identity Law
 213   u :<* Pure _ -> u
 214   -- Functor Right Identity Law
 215   u :<* (v :$> _) -> optimizeGrammarNode (u :<* v)
 216   -- Commutativity Law
 217   x :<$ u -> optimizeGrammarNode (u :$> x)
 218   -- Associativity Law
 219   (u :<* v) :<* w -> optimizeGrammarNode (u :<* optimizeGrammarNode (v :<* w))
 220
 221   -- Pure lookahead
 222   Look p@Pure{} -> p
 223   -- Dead lookahead
 224   Look p@Empty -> p
 225   -- Pure negative-lookahead
 226   NegLook Pure{} -> Empty
 227
 228   -- Dead negative-lookahead
 229   NegLook Empty -> Pure Hask.unit
 230   -- Double Negation Law
 231   NegLook (NegLook p) -> optimizeGrammarNode (Look (Try p) :*> Pure Hask.unit)
 232   -- Zero Consumption Law
 233   NegLook (Try p) -> optimizeGrammarNode (NegLook p)
 234   -- Idempotence Law
 235   Look (Look p) -> Look p
 236   -- Right Identity Law
 237   NegLook (Look p) -> optimizeGrammarNode (NegLook p)
 238
 239   -- Left Identity Law
 240   Look (NegLook p) -> NegLook p
 241   -- Transparency Law
 242   NegLook (Try p :<|> q) -> optimizeGrammarNode (optimizeGrammarNode (NegLook p) :*> optimizeGrammarNode (NegLook q))
 243   -- Distributivity Law
 244   Look p :<|> Look q -> optimizeGrammarNode (Look (optimizeGrammarNode (Try p :<|> q)))
 245   -- Interchange Law
 246   Look (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Look p) :$> x)
 247   -- Interchange Law
 248   Look (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Look p))
 249   -- Absorption Law
 250   p :<*> NegLook q -> optimizeGrammarNode (optimizeGrammarNode (p :<*> Pure Hask.unit) :<* NegLook q)
 251   -- Idempotence Law
 252   NegLook (p :$> _) -> optimizeGrammarNode (NegLook p)
 253   -- Idempotence Law
 254   NegLook (_ :<$> p) -> optimizeGrammarNode (NegLook p)
 255   -- Interchange Law
 256   Try (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Try p) :$> x)
 257   -- Interchange Law
 258   Try (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Try p))
 259
 260   -- Pure Left/Right Laws
 261   Branch (Pure (trans -> lr)) l r ->
 262     case getValue lr of
 263      Left v -> optimizeGrammarNode (l :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
 264       where c = Code [|| case $$(getCode lr) of Left x -> x ||]
 265      Right v -> optimizeGrammarNode (r :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
 266       where c = Code [|| case $$(getCode lr) of Right x -> x ||]
 267   -- Generalised Identity Law
 268   Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->
 269     optimizeGrammarNode (Hask.Haskell (ValueCode v c) :<$> b)
 270     where
 271     v = Value (either (getValue l) (getValue r))
 272     c = Code [|| either $$(getCode l) $$(getCode r) ||]
 273   -- Interchange Law
 274   Branch (x :*> y) p q ->
 275     optimizeGrammarNode (x :*> optimizeGrammarNode (Branch y p q))
 276   -- Negated Branch Law
 277   Branch b l Empty ->
 278     Branch (Pure (Hask.Haskell (ValueCode v c)) :<*> b) Empty l
 279     where
 280     v = Value (either Right Left)
 281     c = Code [||either Right Left||]
 282   -- Branch Fusion Law
 283   Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->
 284     optimizeGrammarNode (Branch (optimizeGrammarNode (Pure (Hask.Haskell (ValueCode (Value v) c)) :<*> b)) Empty br)
 285     where
 286     v Left{} = Left ()
 287     v (Right r) = case getValue lr r of
 288                    Left _ -> Left ()
 289                    Right rr -> Right rr
 290     c = Code [|| \case Left{} -> Left ()
 291                        Right r -> case $$(getCode lr) r of
 292                                    Left _ -> Left ()
 293                                    Right rr -> Right rr ||]
 294   -- Branch Distributivity Law
 295   f :<$> Branch b l r -> optimizeGrammarNode (Branch b (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> l))
 296                                            (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> r)))
 297   -- Match Distributivity Law
 298   f :<$> Match ps bs a d -> Match ps (optimizeGrammarNode . (f :<$>) Functor.<$> bs) a (optimizeGrammarNode (f :<$> d))
 299
 300   x -> x