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