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 call 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   -- Applicable Identity Law
 157   Hask.Id :<$> x -> x
 158   -- Flip const optimisation
 159   Hask.Flip Hask.:@ Hask.Const :<$> u -> optimizeGrammarNode (u :*> Pure Hask.Id)
 160   -- Homomorphism Law
 161   f :<$> Pure x -> Pure (f Hask.:@ x)
 162   -- Functor Composition Law
 163   -- (a shortcut that could also have been be caught
 164   -- by the Composition Law and Homomorphism law)
 165   f :<$> (g :<$> p) -> optimizeGrammarNode ((Hask.:.) Hask.:@ f Hask.:@ g :<$> p)
 166   -- Composition Law
 167   u :<*> (v :<*> w) -> optimizeGrammarNode (optimizeGrammarNode (optimizeGrammarNode ((Hask.:.) :<$> u) :<*> v) :<*> w)
 168   -- Definition of *>
 169   Hask.Flip Hask.:@ Hask.Const :<$> p :<*> q -> p :*> q
 170   -- Definition of <*
 171   Hask.Const :<$> p :<*> q -> p :<* q
 172   -- Reassociation Law 1
 173   (u :*> v) :<*> w -> optimizeGrammarNode (u :*> optimizeGrammarNode (v :<*> w))
 174   -- Pure merge optimisation (useless)
 175   -- Pure x :<*> Pure y -> Pure (x Hask.:@ y)
 176   -- Interchange Law
 177   u :<*> Pure x -> optimizeGrammarNode (Hask.Flip Hask.:@ (Hask.:$) Hask.:@ x :<$> u)
 178   -- Right Absorption Law
 179   (_ :<$> p) :*> q -> p :*> q
 180   -- Left Absorption Law
 181   p :<* (_ :<$> q) -> p :<* q
 182   -- Reassociation Law 2
 183   u :<*> (v :<* w) -> optimizeGrammarNode (optimizeGrammarNode (u :<*> v) :<* w)
 184   -- Reassociation Law 3
 185   u :<*> (v :$> x) -> optimizeGrammarNode (optimizeGrammarNode (u :<*> Pure x) :<* v)
 186
 187   -- Left Catch Law
 188   p@Pure{} :<|> _ -> p
 189   -- Left Neutral Law
 190   Empty :<|> u -> u
 191   -- Right Neutral Law
 192   u :<|> Empty -> u
 193   -- Associativity Law
 194   (u :<|> v) :<|> w -> u :<|> optimizeGrammarNode (v :<|> w)
 195
 196   -- Identity law
 197   Pure _ :*> u -> u
 198   -- Identity law
 199   (u :$> _) :*> v -> u :*> v
 200   -- Associativity Law
 201   u :*> (v :*> w) -> optimizeGrammarNode (optimizeGrammarNode (u :*> v) :*> w)
 202   -- Identity law
 203   u :<* Pure _ -> u
 204   -- Identity law
 205   u :<* (v :$> _) -> optimizeGrammarNode (u :<* v)
 206   -- Commutativity Law
 207   x :<$ u -> optimizeGrammarNode (u :$> x)
 208   -- Associativity Law
 209   (u :<* v) :<* w -> optimizeGrammarNode (u :<* optimizeGrammarNode (v :<* w))
 210
 211   -- Pure lookahead
 212   Look p@Pure{} -> p
 213   -- Dead lookahead
 214   Look p@Empty -> p
 215   -- Pure negative-lookahead
 216   NegLook Pure{} -> Empty
 217
 218   -- Dead negative-lookahead
 219   NegLook Empty -> Pure Hask.unit
 220   -- Double Negation Law
 221   NegLook (NegLook p) -> optimizeGrammarNode (Look (Try p) :*> Pure Hask.unit)
 222   -- Zero Consumption Law
 223   NegLook (Try p) -> optimizeGrammarNode (NegLook p)
 224   -- Idempotence Law
 225   Look (Look p) -> Look p
 226   -- Right Identity Law
 227   NegLook (Look p) -> optimizeGrammarNode (NegLook p)
 228
 229   -- Left Identity Law
 230   Look (NegLook p) -> NegLook p
 231   -- Transparency Law
 232   NegLook (Try p :<|> q) -> optimizeGrammarNode (optimizeGrammarNode (NegLook p) :*> optimizeGrammarNode (NegLook q))
 233   -- Distributivity Law
 234   Look p :<|> Look q -> optimizeGrammarNode (Look (optimizeGrammarNode (Try p :<|> q)))
 235   -- Interchange Law
 236   Look (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Look p) :$> x)
 237   -- Interchange law
 238   Look (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Look p))
 239   -- Absorption Law
 240   p :<*> NegLook q -> optimizeGrammarNode (optimizeGrammarNode (p :<*> Pure Hask.unit) :<* NegLook q)
 241   -- Idempotence Law
 242   NegLook (p :$> _) -> optimizeGrammarNode (NegLook p)
 243   -- Idempotence Law
 244   NegLook (_ :<$> p) -> optimizeGrammarNode (NegLook p)
 245   -- Interchange Law
 246   Try (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Try p) :$> x)
 247   -- Interchange law
 248   Try (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Try p))
 249
 250   -- pure Left/Right laws
 251   Branch (Pure (trans -> lr)) l r ->
 252     case getValue lr of
 253      Left v -> optimizeGrammarNode (l :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
 254       where c = Code [|| case $$(getCode lr) of Left x -> x ||]
 255      Right v -> optimizeGrammarNode (r :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
 256       where c = Code [|| case $$(getCode lr) of Right x -> x ||]
 257   -- Generalised Identity law
 258   Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->
 259     optimizeGrammarNode (Hask.Haskell (ValueCode v c) :<$> b)
 260     where
 261     v = Value (either (getValue l) (getValue r))
 262     c = Code [|| either $$(getCode l) $$(getCode r) ||]
 263   -- Interchange law
 264   Branch (x :*> y) p q ->
 265     optimizeGrammarNode (x :*> optimizeGrammarNode (Branch y p q))
 266   -- Negated Branch law
 267   Branch b l Empty ->
 268     Branch (Pure (Hask.Haskell (ValueCode v c)) :<*> b) Empty l
 269     where
 270     v = Value (either Right Left)
 271     c = Code [||either Right Left||]
 272   -- Branch Fusion law
 273   Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->
 274     optimizeGrammarNode (Branch (optimizeGrammarNode (Pure (Hask.Haskell (ValueCode (Value v) c)) :<*> b)) Empty br)
 275     where
 276     v Left{} = Left ()
 277     v (Right r) = case getValue lr r of
 278                    Left _ -> Left ()
 279                    Right rr -> Right rr
 280     c = Code [|| \case Left{} -> Left ()
 281                        Right r -> case $$(getCode lr) r of
 282                                    Left _ -> Left ()
 283                                    Right rr -> Right rr ||]
 284   -- Distributivity Law
 285   f :<$> Branch b l r -> optimizeGrammarNode (Branch b (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> l))
 286                                            (optimizeGrammarNode ((Hask..@) (Hask..) f :<$> r)))
 287
 288   x -> x