]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Production.hs
machine: optimize ifThenElse on constant
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Production.hs
1 {-# LANGUAGE DefaultSignatures #-}
2 {-# LANGUAGE StandaloneDeriving #-} -- For prodCon
3 {-# LANGUAGE TemplateHaskell #-}
4 {-# LANGUAGE StandaloneDeriving #-}
5 {-# LANGUAGE DeriveLift #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 module Symantic.Parser.Grammar.Production where
9
10 import Control.Monad (Monad(..))
11 import Data.Functor.Identity (Identity(..))
12 import Data.Functor.Product (Product(..))
13 import Data.Ord (Ord(..))
14 import Prelude (Num(..), undefined)
15 import Text.Show (Show(..), showParen, showString)
16 import Type.Reflection (Typeable)
17 import qualified Data.Either as Either
18 import qualified Data.Eq as Eq
19 import qualified Data.Function as Fun
20 import qualified Data.Maybe as Maybe
21 import qualified Language.Haskell.TH as TH
22 import qualified Language.Haskell.TH.Syntax as TH
23 import qualified Language.Haskell.TH.Show as TH
24
25 import Symantic.Typed.Data
26 import Symantic.Typed.Lang
27 import Symantic.Typed.Optim
28 import Symantic.Typed.Trans
29
30 type Production = Product
31 (SomeData Identity)
32 (SomeData TH.CodeQ)
33
34 {-# INLINE prodValue #-}
35 prodValue :: Production a -> SomeData Identity a
36 prodValue (Pair v _) = v
37 {-# INLINE prodCode #-}
38 prodCode :: Production a -> SomeData TH.CodeQ a
39 prodCode (Pair _ c) = c
40
41 {-# INLINE production #-}
42 production :: a -> TH.CodeQ a -> Production a
43 production v c = Pair
44 (SomeData (Var (Identity v)))
45 (SomeData (Var c))
46
47 {-# INLINE prod #-}
48 prod :: TH.Lift a => a -> Production a
49 prod x = production x [||x||]
50
51 {-# INLINE runValue #-}
52 runValue :: Production a -> a
53 runValue x = runIdentity (trans x)
54 {-# INLINE runCode #-}
55 runCode :: Production a -> TH.CodeQ a
56 runCode = trans
57
58 -- Missing instances in 'Language.Haskell.TH',
59 -- needed for 'prodCon'.
60 deriving instance TH.Lift TH.OccName
61 deriving instance TH.Lift TH.NameFlavour
62 deriving instance TH.Lift TH.ModName
63 deriving instance TH.Lift TH.PkgName
64 deriving instance TH.Lift TH.NameSpace
65 deriving instance TH.Lift TH.Name
66
67 -- | @$(prodCon 'SomeConstructor)@ generates the 'Production' for @SomeConstructor@.
68 prodCon :: TH.Name -> TH.Q TH.Exp
69 prodCon name = do
70 info <- TH.reify name
71 case info of
72 TH.DataConI n _ty _pn ->
73 [| production $(return (TH.ConE n))
74 (TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
75
76 instance Trans Production Identity where
77 trans (Pair (SomeData v) _c) = trans v
78 instance Trans Production TH.CodeQ where
79 trans (Pair _v (SomeData c)) = trans c
80
81 instance Show (SomeData TH.CodeQ a) where
82 -- The 'Trans' constraint contained in 'SomeData'
83 -- is 'TH.CodeQ', hence 'Symantic.Typed.View' cannot be used here.
84 -- Fortunately 'TH.showCode' can be implemented.
85 showsPrec p = showString Fun.. TH.showCode Fun.. trans
86
87 instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
88 -- Those 'undefined' are not unreachables by 'f'
89 -- but this is the cost to pay for defining this instance.
90 -- In particular, 'f' must not define the 'TH.CodeQ' part
91 -- using the 'Identity' part.
92 lam f = Pair
93 (lam (\x -> let Pair fx _ = f (Pair x undefined) in fx))
94 (lam (\y -> let Pair _ fy = f (Pair undefined y) in fy))
95 lam1 f = Pair
96 (lam1 (\x -> let Pair fx _ = f (Pair x undefined) in fx))
97 (lam1 (\y -> let Pair _ fy = f (Pair undefined y) in fy))
98 const = Pair const const
99 var = Fun.id
100 id = Pair id id
101 flip = Pair flip flip
102 Pair f1 f2 .@ Pair x1 x2 = Pair (f1 .@x1) (f2 .@x2)
103 (.) = Pair (.) (.)
104 ($) = Pair ($) ($)
105 instance (Num (f a), Num (g a)) => Num (Product f g a) where
106 Pair x1 x2 + Pair y1 y2 = Pair (x1 + y1) (x2 + y2)
107 Pair x1 x2 * Pair y1 y2 = Pair (x1 * y1) (x2 * y2)
108 Pair x1 x2 - Pair y1 y2 = Pair (x1 - y1) (x2 - y2)
109 abs (Pair x1 x2) = Pair (abs x1) (abs x2)
110 fromInteger i = Pair (fromInteger i) (fromInteger i)
111 negate (Pair x1 x2) = Pair (negate x1) (negate x2)
112 signum (Pair x1 x2) = Pair (signum x1) (signum x2)
113 instance (Eitherable f, Eitherable g) => Eitherable (Product f g) where
114 left = Pair left left
115 right = Pair right right
116 instance (TH.Lift c, Typeable c) => Constantable c Production where
117 constant c = Pair (constant c) (constant c)
118 instance Maybeable Production where
119 nothing = Pair nothing nothing
120 just = Pair just just
121 instance Listable Production where
122 nil = Pair nil nil
123 cons = Pair cons cons
124 instance Equalable Production where
125 equal = Pair equal equal
126
127 optimizeProduction :: Production a -> Production a
128 optimizeProduction (Pair v c) = Pair (normalOrderReduction v) (normalOrderReduction c)
129
130 -- Identity
131 instance Anythingable Identity
132 instance Abstractable Identity where
133 f .@ x = Identity (runIdentity f (runIdentity x))
134 lam f = Identity (runIdentity Fun.. f Fun.. Identity)
135 lam1 = lam
136 var = Fun.id
137 const = Identity Fun.const
138 flip = Identity Fun.flip
139 id = Identity Fun.id
140 ($) = Identity (Fun.$)
141 (.) = Identity (Fun..)
142 instance Constantable c Identity where
143 constant = Identity
144 instance Eitherable Identity where
145 left = Identity Either.Left
146 right = Identity Either.Right
147 instance Equalable Identity where
148 equal = Identity (Eq.==)
149 instance IfThenElseable Identity where
150 ifThenElse test ok ko = Identity
151 (if runIdentity test
152 then runIdentity ok
153 else runIdentity ko)
154 instance Listable Identity where
155 cons = Identity (:)
156 nil = Identity []
157 instance Maybeable Identity where
158 nothing = Identity Maybe.Nothing
159 just = Identity Maybe.Just
160
161 -- TH.CodeQ
162 instance Anythingable TH.CodeQ
163 instance Abstractable TH.CodeQ where
164 (.@) f x = [|| $$f $$x ||]
165 lam f = [|| \x -> $$(f [||x||]) ||]
166 lam1 = lam
167 var = Fun.id
168 id = [|| \x -> x ||]
169 const = [|| Fun.const ||]
170 flip = [|| \f x y -> f y x ||]
171 ($) = [|| (Fun.$) ||]
172 (.) = [|| (Fun..) ||]
173 instance TH.Lift c => Constantable c TH.CodeQ where
174 constant c = [|| c ||]
175 instance Eitherable TH.CodeQ where
176 left = [|| Either.Left ||]
177 right = [|| Either.Right ||]
178 instance Equalable TH.CodeQ where
179 equal = [|| (Eq.==) ||]
180 instance IfThenElseable TH.CodeQ where
181 ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
182 instance Listable TH.CodeQ where
183 cons = [|| (:) ||]
184 nil = [|| [] ||]
185 instance Maybeable TH.CodeQ where
186 nothing = [|| Maybe.Nothing ||]
187 just = [|| Maybe.Just ||]
188 instance Num a => Num (TH.CodeQ a) where
189 x + y = [|| $$x + $$y||]
190 x * y = [|| $$x * $$y||]
191 x - y = [|| $$x - $$y||]
192 abs x = [|| abs $$x ||]
193 fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
194 negate x = [|| negate $$x ||]
195 signum x = [|| signum $$x ||]