]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Lang.hs
iface: fix class `Voidable`
[haskell/symantic-base.git] / src / Symantic / Lang.hs
1 {-# LANGUAGE DataKinds #-} -- For ReprKind
2 {-# LANGUAGE PatternSynonyms #-} -- For (:!:)
3 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
4 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
5 module Symantic.Lang where
6
7 import Data.Bool (Bool(..))
8 import Data.Char (Char)
9 import Data.Either (Either(..))
10 import Data.Eq (Eq)
11 import Data.Kind (Type)
12 import Data.Maybe (Maybe(..), fromJust)
13 import Data.Proxy (Proxy(..))
14 import GHC.Generics (Generic)
15 import qualified Data.Function as Fun
16
17 import Symantic.Derive
18 import Symantic.ADT
19 import Symantic.CurryN
20
21 -- * Type 'ReprKind'
22 type ReprKind = Type -> Type
23
24 -- * Class 'Abstractable'
25 class Abstractable repr where
26 -- | Application, aka. unabstract.
27 (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
28 -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
29 lam :: (repr a -> repr b) -> repr (a->b)
30 -- | Like 'lam' but whose argument is used only once,
31 -- hence safe to beta-reduce (inline) without duplicating work.
32 lam1 :: (repr a -> repr b) -> repr (a->b)
33 const :: repr (a -> b -> a)
34 flip :: repr ((a -> b -> c) -> b -> a -> c)
35 id :: repr (a->a)
36 (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
37 ($) :: repr ((a->b) -> a -> b); infixr 0 $
38 var :: repr a -> repr a
39 (.@) = liftDerived2 (.@)
40 lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
41 lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
42 const = liftDerived const
43 flip = liftDerived flip
44 id = liftDerived id
45 (.) = liftDerived (.)
46 ($) = liftDerived ($)
47 var = liftDerived1 var
48 default (.@) ::
49 FromDerived2 Abstractable repr =>
50 repr (a->b) -> repr a -> repr b
51 default lam ::
52 FromDerived Abstractable repr => Derivable repr =>
53 (repr a -> repr b) -> repr (a->b)
54 default lam1 ::
55 FromDerived Abstractable repr => Derivable repr =>
56 (repr a -> repr b) -> repr (a->b)
57 default const ::
58 FromDerived Abstractable repr =>
59 repr (a -> b -> a)
60 default flip ::
61 FromDerived Abstractable repr =>
62 repr ((a -> b -> c) -> b -> a -> c)
63 default id ::
64 FromDerived Abstractable repr =>
65 repr (a->a)
66 default (.) ::
67 FromDerived Abstractable repr =>
68 repr ((b->c) -> (a->b) -> a -> c)
69 default ($) ::
70 FromDerived Abstractable repr =>
71 repr ((a->b) -> a -> b)
72 default var ::
73 FromDerived1 Abstractable repr =>
74 repr a -> repr a
75
76 -- * Class 'Anythingable'
77 class Anythingable repr where
78 anything :: repr a -> repr a
79 anything = Fun.id
80
81 -- * Class 'Bottomable'
82 class Bottomable repr where
83 bottom :: repr a
84
85 -- * Class 'Constantable'
86 class Constantable c repr where
87 constant :: c -> repr c
88 constant = liftDerived Fun.. constant
89 default constant ::
90 FromDerived (Constantable c) repr =>
91 c -> repr c
92
93 bool :: Constantable Bool repr => Bool -> repr Bool
94 bool = constant @Bool
95 char :: Constantable Char repr => Char -> repr Char
96 char = constant @Char
97 unit :: Constantable () repr => repr ()
98 unit = constant @() ()
99
100 -- * Class 'Eitherable'
101 class Eitherable repr where
102 left :: repr (l -> Either l r)
103 right :: repr (r -> Either l r)
104 left = liftDerived left
105 right = liftDerived right
106 default left ::
107 FromDerived Eitherable repr =>
108 repr (l -> Either l r)
109 default right ::
110 FromDerived Eitherable repr =>
111 repr (r -> Either l r)
112
113 -- * Class 'Equalable'
114 class Equalable repr where
115 equal :: Eq a => repr (a -> a -> Bool)
116 equal = liftDerived equal
117 default equal ::
118 FromDerived Equalable repr =>
119 Eq a => repr (a -> a -> Bool)
120
121 infix 4 `equal`, ==
122 (==) :: (Abstractable repr, Equalable repr, Eq a) => repr (a -> a -> Bool)
123 (==) = lam (\x -> lam (\y -> equal .@ x .@ y))
124
125 -- * Class 'IfThenElseable'
126 class IfThenElseable repr where
127 ifThenElse :: repr Bool -> repr a -> repr a -> repr a
128 ifThenElse = liftDerived3 ifThenElse
129 default ifThenElse ::
130 FromDerived3 IfThenElseable repr =>
131 repr Bool -> repr a -> repr a -> repr a
132
133 -- * Class 'Listable'
134 class Listable repr where
135 cons :: repr (a -> [a] -> [a])
136 nil :: repr [a]
137 cons = liftDerived cons
138 nil = liftDerived nil
139 default cons ::
140 FromDerived Listable repr =>
141 repr (a -> [a] -> [a])
142 default nil ::
143 FromDerived Listable repr =>
144 repr [a]
145
146 -- * Class 'Maybeable'
147 class Maybeable repr where
148 nothing :: repr (Maybe a)
149 just :: repr (a -> Maybe a)
150 nothing = liftDerived nothing
151 just = liftDerived just
152 default nothing ::
153 FromDerived Maybeable repr =>
154 repr (Maybe a)
155 default just ::
156 FromDerived Maybeable repr =>
157 repr (a -> Maybe a)
158
159 -- * Class 'IsoFunctor'
160 class IsoFunctor repr where
161 (<%>) :: Iso a b -> repr a -> repr b
162 (<%>) iso = liftDerived1 (iso <%>)
163 default (<%>) ::
164 FromDerived1 IsoFunctor repr =>
165 Iso a b -> repr a -> repr b
166
167 -- ** Type 'Iso'
168 data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
169
170 -- * Class 'ProductFunctor'
171 class ProductFunctor repr where
172 (<.>) :: repr a -> repr b -> repr (a, b)
173 (<.>) = liftDerived2 (<.>)
174 default (<.>) ::
175 FromDerived2 ProductFunctor repr =>
176 repr a -> repr b -> repr (a, b)
177
178 -- * Class 'AlternativeFunctor'
179 class AlternativeFunctor repr where
180 (<+>) :: repr a -> repr a -> repr a
181 (<+>) = liftDerived2 (<+>)
182 default (<+>) ::
183 FromDerived2 AlternativeFunctor repr =>
184 repr a -> repr a -> repr a
185
186 -- * Class 'Dicurryable'
187 class Dicurryable repr where
188 dicurry ::
189 CurryN args =>
190 proxy args ->
191 (args-..->r) -> -- construction
192 (r->Tuples args) -> -- destruction
193 repr (args-..->k) ->
194 repr (r->k)
195 dicurry args constr destr = liftDerived1 (dicurry args constr destr)
196 default dicurry ::
197 FromDerived1 Dicurryable repr =>
198 CurryN args =>
199 proxy args ->
200 (args-..->r) ->
201 (r->Tuples args) ->
202 repr (args-..->k) ->
203 repr (r->k)
204
205 construct ::
206 forall args a k repr.
207 Dicurryable repr =>
208 Generic a =>
209 EoTOfRep a =>
210 CurryN args =>
211 Tuples args ~ EoT (ADT a) =>
212 (args ~ Args (args-..->a)) =>
213 (args-..->a) ->
214 repr (args-..->k) ->
215 repr (a -> k)
216 construct f = dicurry (Proxy::Proxy args) f eotOfadt
217
218 adt ::
219 forall adt repr.
220 IsoFunctor repr =>
221 Generic adt =>
222 RepOfEoT adt =>
223 EoTOfRep adt =>
224 repr (EoT (ADT adt)) ->
225 repr adt
226 adt = (<%>) (Iso adtOfeot eotOfadt)
227
228 -- ** Class 'Emptyable'
229 class Emptyable repr where
230 empty :: repr a
231 empty = liftDerived empty
232 default empty ::
233 FromDerived Emptyable repr =>
234 repr a
235
236 -- ** Class 'Optionable'
237 class Optionable repr where
238 option :: repr a -> repr a
239 optional :: repr a -> repr (Maybe a)
240 option = liftDerived1 option
241 optional = liftDerived1 optional
242 default option ::
243 FromDerived1 Optionable repr =>
244 repr a -> repr a
245 default optional ::
246 FromDerived1 Optionable repr =>
247 repr a -> repr (Maybe a)
248
249 -- * Class 'Repeatable'
250 class Repeatable repr where
251 many0 :: repr a -> repr [a]
252 many1 :: repr a -> repr [a]
253 many0 = liftDerived1 many0
254 many1 = liftDerived1 many1
255 default many0 ::
256 FromDerived1 Repeatable repr =>
257 repr a -> repr [a]
258 default many1 ::
259 FromDerived1 Repeatable repr =>
260 repr a -> repr [a]
261
262 -- * Class 'Permutable'
263 class Permutable repr where
264 -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
265 type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
266 type Permutation repr = Permutation (Derived repr)
267 permutable :: Permutation repr a -> repr a
268 perm :: repr a -> Permutation repr a
269 noPerm :: Permutation repr ()
270 permWithDefault :: a -> repr a -> Permutation repr a
271 optionalPerm ::
272 Eitherable repr => IsoFunctor repr => Permutable repr =>
273 repr a -> Permutation repr (Maybe a)
274 optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
275
276 (<&>) ::
277 Permutable repr =>
278 ProductFunctor (Permutation repr) =>
279 repr a ->
280 Permutation repr b ->
281 Permutation repr (a, b)
282 x <&> y = perm x <.> y
283
284 (<?&>) ::
285 Eitherable repr =>
286 IsoFunctor repr =>
287 Permutable repr =>
288 ProductFunctor (Permutation repr) =>
289 repr a ->
290 Permutation repr b ->
291 Permutation repr (Maybe a, b)
292 x <?&> y = optionalPerm x <.> y
293
294 (<*&>) ::
295 Eitherable repr =>
296 Repeatable repr =>
297 IsoFunctor repr =>
298 Permutable repr =>
299 ProductFunctor (Permutation repr) =>
300 repr a ->
301 Permutation repr b ->
302 Permutation repr ([a],b)
303 x <*&> y = permWithDefault [] (many1 x) <.> y
304
305 (<+&>) ::
306 Eitherable repr =>
307 Repeatable repr =>
308 IsoFunctor repr =>
309 Permutable repr =>
310 ProductFunctor (Permutation repr) =>
311 repr a ->
312 Permutation repr b ->
313 Permutation repr ([a],b)
314 x <+&> y = perm (many1 x) <.> y
315
316 infixr 4 <&>
317 infixr 4 <?&>
318 infixr 4 <*&>
319 infixr 4 <+&>
320
321 {-# INLINE (<&>) #-}
322 {-# INLINE (<?&>) #-}
323 {-# INLINE (<*&>) #-}
324 {-# INLINE (<+&>) #-}
325
326 -- * Class 'Routable'
327 class Routable repr where
328 (<!>) :: repr a -> repr b -> repr (a, b)
329 (<!>) = liftDerived2 (<!>)
330 default (<!>) ::
331 FromDerived2 Routable repr =>
332 repr a -> repr b -> repr (a,b)
333
334 -- | Like @(,)@ but @infixr@.
335 -- Mostly useful for clarity when using 'Routable'.
336 pattern (:!:) :: a -> b -> (a,b)
337 pattern a:!:b <- (a,b)
338 where a:!:b = (a,b)
339 infixr 3 :!:
340
341 -- * Class 'Voidable'
342 -- | FIXME: this class should likely be removed
343 class Voidable repr where
344 void :: a -> repr a -> repr ()
345 void = liftDerived1 Fun.. void
346 default void ::
347 FromDerived1 Voidable repr =>
348 a -> repr a -> repr ()
349
350 -- * Class 'Substractable'
351 class Substractable repr where
352 (<->) :: repr a -> repr b -> repr a
353 (<->) = liftDerived2 (<->)
354 default (<->) ::
355 FromDerived2 Substractable repr =>
356 repr a -> repr b -> repr a
357 infixr 3 <->