src/Symantic/Parser/Grammar/Optimize.hs

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