]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Staging.hs
bump to ghc-9.0.1 to get a levity-polymorphic CodeQ
[haskell/symantic-parser.git] / src / Symantic / Parser / Staging.hs
1 {-# LANGUAGE PatternSynonyms #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 module Symantic.Parser.Staging where
4
5 import Data.Bool (Bool(..))
6 import Data.Char (Char)
7 import Data.Either (Either(..))
8 import Data.Eq (Eq)
9 import Data.Maybe (Maybe(..))
10 import Data.Ord (Ord(..))
11 import Data.Kind (Type)
12 import Text.Show (Show(..), showParen, showString)
13 import qualified Data.Eq as Eq
14 import qualified Data.Function as Fun
15 import qualified Data.Function as Function
16 import qualified Language.Haskell.TH as TH
17
18 import Symantic.Univariant.Trans
19
20 -- * Type 'ValueCode'
21 -- | Compile-time 'value' and corresponding 'code'
22 -- (that can produce that value at runtime).
23 data ValueCode a = ValueCode
24 { value :: Value a
25 , code :: TH.CodeQ a
26 }
27 getValue :: ValueCode a -> a
28 getValue = unValue Function.. value
29 getCode :: ValueCode a -> TH.CodeQ a
30 getCode = code
31
32 -- ** Type 'Value'
33 newtype Value a = Value { unValue :: a }
34
35 -- * Class 'Haskellable'
36 -- | Final encoding of some Haskell functions
37 -- useful for some optimizations in 'optimizeComb'.
38 class Haskellable (repr :: Type -> Type) where
39 (.) :: repr ((b->c) -> (a->b) -> a -> c)
40 ($) :: repr ((a->b) -> a -> b)
41 (.@) :: repr (a->b) -> repr a -> repr b
42 bool :: Bool -> repr Bool
43 char :: Char -> repr Char
44 cons :: repr (a -> [a] -> [a])
45 const :: repr (a -> b -> a)
46 eq :: Eq a => repr a -> repr (a -> Bool)
47 flip :: repr ((a -> b -> c) -> b -> a -> c)
48 id :: repr (a->a)
49 nil :: repr [a]
50 unit :: repr ()
51 left :: repr (l -> Either l r)
52 right :: repr (r -> Either l r)
53 nothing :: repr (Maybe a)
54 just :: repr (a -> Maybe a)
55
56 -- ** Type 'Haskellable'
57 -- | Initial encoding of 'Haskellable'.
58 data Haskell a where
59 Haskell :: ValueCode a -> Haskell a
60 (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
61 (:$) :: Haskell ((a->b) -> a -> b)
62 (:@) :: Haskell (a->b) -> Haskell a -> Haskell b
63 Cons :: Haskell (a -> [a] -> [a])
64 Const :: Haskell (a -> b -> a)
65 Eq :: Eq a => Haskell a -> Haskell (a -> Bool)
66 Flip :: Haskell ((a -> b -> c) -> b -> a -> c)
67 Id :: Haskell (a->a)
68 Unit :: Haskell ()
69 infixr 0 $, :$
70 infixr 9 ., :.
71 infixl 9 .@, :@
72
73 {-
74 pattern (:.@) ::
75 -- Dummy constraint to get the following constraint
76 -- in scope when pattern-matching.
77 () =>
78 ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
79 Haskell x -> Haskell y -> Haskell z
80 pattern (:.@) f g = (:.) :@ f :@ g
81 pattern FlipApp ::
82 () =>
83 ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
84 Haskell x -> Haskell y
85 pattern FlipApp f = Flip :@ f
86 pattern FlipConst ::
87 () =>
88 (x ~ (a -> b -> b)) =>
89 Haskell x
90 pattern FlipConst = FlipApp Const
91 -}
92
93 instance Show (Haskell a) where
94 showsPrec p = \case
95 Haskell{} -> showString "Haskell"
96 (:$) -> showString "($)"
97 (:.) :@ f :@ g ->
98 showParen (p >= 9)
99 Fun.$ showsPrec 9 f
100 Fun.. showString " . "
101 Fun.. showsPrec 9 g
102 (:.) -> showString "(.)"
103 Cons :@ x :@ xs ->
104 showParen (p >= 10)
105 Fun.$ showsPrec 10 x
106 Fun.. showString " : "
107 Fun.. showsPrec 10 xs
108 Cons -> showString "cons"
109 Const -> showString "const"
110 Eq x ->
111 showParen True
112 Fun.$ showString "== "
113 Fun.. showsPrec 0 x
114 Flip -> showString "flip"
115 Id -> showString "id"
116 Unit -> showString "()"
117 (:@) f x ->
118 showParen (p >= 10)
119 Fun.$ showsPrec 10 f
120 Fun.. showString " "
121 Fun.. showsPrec 10 x
122 instance Trans Haskell Value where
123 trans = value Fun.. trans
124 instance Trans Haskell TH.CodeQ where
125 trans = code Fun.. trans
126 instance Trans Haskell ValueCode where
127 trans = \case
128 Haskell x -> x
129 (:.) -> (.)
130 (:$) -> ($)
131 (:@) f x -> (.@) (trans f) (trans x)
132 Cons -> cons
133 Const -> const
134 Eq x -> eq (trans x)
135 Flip -> flip
136 Id -> id
137 Unit -> unit
138 instance Trans ValueCode Haskell where
139 trans = Haskell
140 type instance Output Haskell = ValueCode
141
142 instance Haskellable Haskell where
143 (.) = (:.)
144 ($) = (:$)
145 -- Small optimizations, mainly to reduce dump sizes.
146 Id .@ x = x
147 (Const :@ x) .@ _y = x
148 ((Flip :@ Const) :@ _x) .@ y = y
149 --
150 f .@ x = f :@ x
151 cons = Cons
152 const = Const
153 eq = Eq
154 flip = Flip
155 id = Id
156 unit = Unit
157 bool b = Haskell (bool b)
158 char c = Haskell (char c)
159 nil = Haskell nil
160 left = Haskell left
161 right = Haskell right
162 nothing = Haskell nothing
163 just = Haskell just
164 instance Haskellable ValueCode where
165 (.) = ValueCode (.) (.)
166 ($) = ValueCode ($) ($)
167 (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
168 bool b = ValueCode (bool b) (bool b)
169 char c = ValueCode (char c) (char c)
170 cons = ValueCode cons cons
171 const = ValueCode const const
172 eq x = ValueCode (eq (value x)) (eq (code x))
173 flip = ValueCode flip flip
174 id = ValueCode id id
175 nil = ValueCode nil nil
176 unit = ValueCode unit unit
177 left = ValueCode left left
178 right = ValueCode right right
179 nothing = ValueCode nothing nothing
180 just = ValueCode just just
181 instance Haskellable Value where
182 (.) = Value (Function..)
183 ($) = Value (Function.$)
184 (.@) f x = Value (unValue f (unValue x))
185 bool = Value
186 char = Value
187 cons = Value (:)
188 const = Value Function.const
189 eq x = Value (unValue x Eq.==)
190 flip = Value Function.flip
191 id = Value Function.id
192 nil = Value []
193 unit = Value ()
194 left = Value Left
195 right = Value Right
196 nothing = Value Nothing
197 just = Value Just
198 instance Haskellable TH.CodeQ where
199 (.) = [|| \f g x -> f (g x) ||]
200 ($) = [|| \f x -> f x ||]
201 (.@) f x = [|| $$f $$x ||]
202 bool b = [|| b ||]
203 char c = [|| c ||]
204 cons = [|| \x xs -> x : xs ||]
205 const = [|| \x _ -> x ||]
206 eq x = [|| \y -> $$x Eq.== y ||]
207 flip = [|| \f x y -> f y x ||]
208 id = [|| \x -> x ||]
209 nil = [|| [] ||]
210 unit = [|| () ||]
211 left = [|| Left ||]
212 right = [|| Right ||]
213 nothing = [|| Nothing ||]
214 just = [|| Just ||]