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
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
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
24 Pure :: Hask.Haskell a -> Grammar a
25 Satisfy :: Hask.Haskell (Char -> Bool) -> 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
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
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
52 infixl 4 :<*>, :<*, :*>
53 infixl 4 :<$>, :<$, :$>
55 instance Applicable Grammar where
58 instance Alternable Grammar where
62 instance Selectable Grammar where
64 instance Matchable Grammar where
66 instance Foldable Grammar where
69 instance Charable Grammar where
71 instance Lookable Grammar where
74 instance Letable TH.Name Grammar where
77 instance MakeLetName TH.Name where
78 makeLetName _ = TH.qNewName "let"
80 instance Letable letName repr =>
81 Letable letName (Any repr)
90 , Letable TH.Name repr
92 Trans Grammar (Any repr) where
95 Satisfy p -> satisfy p
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
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)
110 -- * Type 'OptimizeGrammar'
111 -- Bottom-up application of 'optimizeGrammarNode'.
112 newtype OptimizeGrammar letName a = OptimizeGrammar { unOptimizeGrammar ::
115 optimizeGrammar :: OptimizeGrammar TH.Name a -> Grammar a
116 optimizeGrammar = unOptimizeGrammar
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
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)
142 optimizeGrammarNode :: Grammar a -> Grammar a
143 optimizeGrammarNode = \case
144 -- Applicable Right Absorption Law
145 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)
156 -- Applicable Identity Law
158 -- Flip const optimisation
159 Hask.Flip Hask.:@ Hask.Const :<$> u -> optimizeGrammarNode (u :*> Pure Hask.Id)
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)
167 u :<*> (v :<*> w) -> optimizeGrammarNode (optimizeGrammarNode (optimizeGrammarNode ((Hask.:.) :<$> u) :<*> v) :<*> w)
169 Hask.Flip Hask.:@ Hask.Const :<$> p :<*> q -> p :*> q
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)
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)
194 (u :<|> v) :<|> w -> u :<|> optimizeGrammarNode (v :<|> w)
199 (u :$> _) :*> v -> u :*> v
201 u :*> (v :*> w) -> optimizeGrammarNode (optimizeGrammarNode (u :*> v) :*> w)
205 u :<* (v :$> _) -> optimizeGrammarNode (u :<* v)
207 x :<$ u -> optimizeGrammarNode (u :$> x)
209 (u :<* v) :<* w -> optimizeGrammarNode (u :<* optimizeGrammarNode (v :<* w))
215 -- Pure negative-lookahead
216 NegLook Pure{} -> Empty
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)
225 Look (Look p) -> Look p
226 -- Right Identity Law
227 NegLook (Look p) -> optimizeGrammarNode (NegLook p)
230 Look (NegLook p) -> NegLook p
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)))
236 Look (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Look p) :$> x)
238 Look (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Look p))
240 p :<*> NegLook q -> optimizeGrammarNode (optimizeGrammarNode (p :<*> Pure Hask.unit) :<* NegLook q)
242 NegLook (p :$> _) -> optimizeGrammarNode (NegLook p)
244 NegLook (_ :<$> p) -> optimizeGrammarNode (NegLook p)
246 Try (p :$> x) -> optimizeGrammarNode (optimizeGrammarNode (Try p) :$> x)
248 Try (f :<$> p) -> optimizeGrammarNode (f :<$> optimizeGrammarNode (Try p))
250 -- pure Left/Right laws
251 Branch (Pure (trans -> lr)) l r ->
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)
261 v = Value (either (getValue l) (getValue r))
262 c = Code [|| either $$(getCode l) $$(getCode r) ||]
264 Branch (x :*> y) p q ->
265 optimizeGrammarNode (x :*> optimizeGrammarNode (Branch y p q))
266 -- Negated Branch law
268 Branch (Pure (Hask.Haskell (ValueCode v c)) :<*> b) Empty l
270 v = Value (either Right Left)
271 c = Code [||either Right Left||]
273 Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->
274 optimizeGrammarNode (Branch (optimizeGrammarNode (Pure (Hask.Haskell (ValueCode (Value v) c)) :<*> b)) Empty br)
277 v (Right r) = case getValue lr r of
280 c = Code [|| \case Left{} -> Left ()
281 Right r -> case $$(getCode lr) r of
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)))