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