1 {-# LANGUAGE MagicHash #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 module Symantic.Parser.Staging where
5 import Data.Bool (Bool)
6 import Data.Char (Char)
7 import qualified Data.Function as Fun
8 import Data.Either (Either(..))
10 import Data.Ord (Ord(..))
11 import Data.Functor (Functor(..))
12 import Data.Hashable (Hashable, hashWithSalt, hash)
13 import Data.Maybe (Maybe(..))
14 import GHC.Exts (Int(..))
15 import GHC.Prim (StableName#, unsafeCoerce#)
16 import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
17 import Language.Haskell.TH (TExpQ)
19 import Text.Show (Show(..), showParen, showString)
20 import qualified Data.Eq as Eq
21 import qualified Data.Function as Function
23 import Symantic.Base.Univariant
26 -- | Compile-time 'value' and corresponding 'code' (that can produce that value at runtime).
27 data ValueCode a = ValueCode
31 getValue :: ValueCode a -> a
32 getValue = unValue Function.. value
33 getCode :: ValueCode a -> TExpQ a
34 getCode = unCode Function.. code
35 type instance Unlift ValueCode = ValueCode
36 instance Liftable ValueCode where
39 instance Unliftable ValueCode where
44 newtype Value a = Value { unValue :: a }
45 type instance Unlift Value = Value
46 instance Liftable Value where
49 instance Unliftable Value where
54 newtype Code a = Code { unCode :: TExpQ a }
55 type instance Unlift Code = Code
56 instance Liftable Code where
59 instance Unliftable Code where
63 -- * Class 'Haskellable'
64 -- | Final encoding of some Haskellable functions
65 -- useful for some optimizations in 'optGram'.
66 class Haskellable (repr :: * -> *) where
67 haskell :: Unlift repr a -> repr a
68 (.) :: repr ((b->c) -> (a->b) -> a -> c)
69 ($) :: repr ((a->b) -> a -> b)
70 (.@) :: repr (a->b) -> repr a -> repr b
71 bool :: Bool -> repr Bool
72 char :: Char -> repr Char
73 cons :: repr (a -> [a] -> [a])
74 const :: repr (a -> b -> a)
75 eq :: Eq a => repr a -> repr (a -> Bool)
76 flip :: repr ((a -> b -> c) -> b -> a -> c)
80 left :: repr (l -> Either l r)
81 right :: repr (r -> Either l r)
82 nothing :: repr (Maybe a)
83 just :: repr (a -> Maybe a)
84 -- instance Haskellable Identity
86 -- ** Type 'Haskellable'
87 -- | Initial encoding of 'Haskellable'
89 Haskell :: ValueCode a -> Haskell a
90 (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
91 (:$) :: Haskell ((a->b) -> a -> b)
92 (:@) :: Haskell (a->b) -> Haskell a -> Haskell b
93 Const :: Haskell (a -> b -> a)
94 Flip :: Haskell ((a -> b -> c) -> b -> a -> c)
96 instance Show (Haskell a) where
98 Haskell{} -> showString "Haskell"
99 (:.) -> showString "(.)"
100 (:$) -> showString "($)"
103 Fun.$ showString "(@) "
107 Const -> showString "const"
108 Flip -> showString "flip"
109 Id -> showString "id"
110 type instance Unlift Haskell = ValueCode
111 instance Liftable Haskell where
113 instance Unliftable Haskell where
115 Haskell x -> haskell x
118 (:@) f x -> (.@) (unlift f) (unlift x)
126 instance Haskellable Haskell where
136 right = Haskell right
137 nothing = Haskell nothing
139 instance Haskellable ValueCode where
140 haskell = Function.id
141 (.) = ValueCode (.) (.)
142 ($) = ValueCode ($) ($)
143 (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
144 bool b = ValueCode (bool b) (bool b)
145 char c = ValueCode (char c) (char c)
146 cons = ValueCode cons cons
147 const = ValueCode const const
148 eq x = ValueCode (eq (value x)) (eq (code x))
149 flip = ValueCode flip flip
151 nil = ValueCode nil nil
152 unit = ValueCode unit unit
153 left = ValueCode left left
154 right = ValueCode right right
155 nothing = ValueCode nothing nothing
156 just = ValueCode just just
157 instance Haskellable Value where
159 (.) = Value (Function..)
160 ($) = Value (Function.$)
161 (.@) f x = Value (unValue f (unValue x))
165 const = Value Function.const
166 eq x = Value (unValue x Eq.==)
167 flip = Value Function.flip
168 id = Value Function.id
173 nothing = Value Nothing
175 instance Haskellable Code where
177 (.) = Code [|| \f g x -> f (g x) ||]
178 ($) = Code [|| \f x -> f x ||]
179 (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
180 bool b = Code [|| b ||]
181 char c = Code [|| c ||]
182 cons = Code [|| \x xs -> x : xs ||]
183 const = Code [|| \x _ -> x ||]
184 eq x = Code [|| \y -> $$(unCode x) Eq.== y ||]
185 flip = Code [|| \f x y -> f y x ||]
186 id = Code [|| \x -> x ||]
187 nil = Code [|| [] ||]
188 unit = Code [|| () ||]
189 left = Code [|| Left ||]
190 right = Code [|| Right ||]
191 nothing = Code [|| Nothing ||]
192 just = Code [|| Just ||]