]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Syntaxes/Classes.hs
impl: gather in submodules
[haskell/symantic-base.git] / src / Symantic / Syntaxes / Classes.hs
1 {-# LANGUAGE DataKinds #-} -- For ReprKind
2 {-# LANGUAGE PatternSynonyms #-} -- For (:!:)
3 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
4 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
5 -- | Combinators in this module conflict with usual ones from the @Prelude@
6 -- hence they are meant to be imported either explicitely or qualified.
7 module Symantic.Classes where
8
9 import Data.Bool (Bool(..))
10 import Data.Char (Char)
11 import Data.Either (Either(..))
12 import Data.Eq (Eq)
13 import Data.Int (Int)
14 import Data.Kind (Type)
15 import Data.Maybe (Maybe(..), fromJust)
16 import Data.Proxy (Proxy(..))
17 import Data.Semigroup (Semigroup)
18 import Data.String (String)
19 import GHC.Generics (Generic)
20 import Numeric.Natural (Natural)
21 import qualified Control.Category as Cat
22 import qualified Data.Function as Fun
23 import qualified Data.Tuple as Tuple
24
25 import Symantic.Derive
26 import Symantic.ADT
27 import Symantic.CurryN
28
29 -- * Type 'ReprKind'
30 -- | The kind of @repr@(esentations) throughout this library.
31 type ReprKind = Type -> Type
32
33 -- * Class 'Abstractable'
34 class Abstractable repr where
35 -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
36 lam :: (repr a -> repr b) -> repr (a->b)
37 -- | Like 'lam' but whose argument must be used only once,
38 -- hence safe to beta-reduce (inline) without duplicating work.
39 lam1 :: (repr a -> repr b) -> repr (a->b)
40 var :: repr a -> repr a
41 -- | Application, aka. unabstract.
42 (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
43 lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
44 lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
45 var = liftDerived1 var
46 (.@) = liftDerived2 (.@)
47 default lam ::
48 FromDerived Abstractable repr => Derivable repr =>
49 (repr a -> repr b) -> repr (a->b)
50 default lam1 ::
51 FromDerived Abstractable repr => Derivable repr =>
52 (repr a -> repr b) -> repr (a->b)
53 default var ::
54 FromDerived1 Abstractable repr =>
55 repr a -> repr a
56 default (.@) ::
57 FromDerived2 Abstractable repr =>
58 repr (a->b) -> repr a -> repr b
59
60 -- ** Class 'Functionable'
61 class Functionable repr where
62 const :: repr (a -> b -> a)
63 flip :: repr ((a -> b -> c) -> b -> a -> c)
64 id :: repr (a->a)
65 (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
66 ($) :: repr ((a->b) -> a -> b); infixr 0 $
67 const = liftDerived const
68 flip = liftDerived flip
69 id = liftDerived id
70 (.) = liftDerived (.)
71 ($) = liftDerived ($)
72 default const ::
73 FromDerived Functionable repr =>
74 repr (a -> b -> a)
75 default flip ::
76 FromDerived Functionable repr =>
77 repr ((a -> b -> c) -> b -> a -> c)
78 default id ::
79 FromDerived Functionable repr =>
80 repr (a->a)
81 default (.) ::
82 FromDerived Functionable repr =>
83 repr ((b->c) -> (a->b) -> a -> c)
84 default ($) ::
85 FromDerived Functionable repr =>
86 repr ((a->b) -> a -> b)
87
88 -- * Class 'Anythingable'
89 class Anythingable repr where
90 anything :: repr a -> repr a
91 anything = Fun.id
92
93 -- * Class 'Bottomable'
94 class Bottomable repr where
95 bottom :: repr a
96
97 -- * Class 'Constantable'
98 class Constantable c repr where
99 constant :: c -> repr c
100 constant = liftDerived Fun.. constant
101 default constant ::
102 FromDerived (Constantable c) repr =>
103 c -> repr c
104
105 -- * Class 'Eitherable'
106 class Eitherable repr where
107 left :: repr (l -> Either l r)
108 right :: repr (r -> Either l r)
109 left = liftDerived left
110 right = liftDerived right
111 default left ::
112 FromDerived Eitherable repr =>
113 repr (l -> Either l r)
114 default right ::
115 FromDerived Eitherable repr =>
116 repr (r -> Either l r)
117
118 -- * Class 'Equalable'
119 class Equalable repr where
120 equal :: Eq a => repr (a -> a -> Bool)
121 equal = liftDerived equal
122 default equal ::
123 FromDerived Equalable repr =>
124 Eq a => repr (a -> a -> Bool)
125
126 infix 4 `equal`, ==
127 (==) ::
128 Abstractable repr => Equalable repr => Eq a =>
129 repr a -> repr a -> repr Bool
130 (==) x y = equal .@ x .@ y
131
132 -- * Class 'IfThenElseable'
133 class IfThenElseable repr where
134 ifThenElse :: repr Bool -> repr a -> repr a -> repr a
135 ifThenElse = liftDerived3 ifThenElse
136 default ifThenElse ::
137 FromDerived3 IfThenElseable repr =>
138 repr Bool -> repr a -> repr a -> repr a
139
140 -- * Class 'Inferable'
141 class Inferable a repr where
142 infer :: repr a
143 default infer :: FromDerived (Inferable a) repr => repr a
144 infer = liftDerived infer
145
146 unit :: Inferable () repr => repr ()
147 unit = infer
148 bool :: Inferable Bool repr => repr Bool
149 bool = infer
150 char :: Inferable Char repr => repr Char
151 char = infer
152 int :: Inferable Int repr => repr Int
153 int = infer
154 natural :: Inferable Natural repr => repr Natural
155 natural = infer
156 string :: Inferable String repr => repr String
157 string = infer
158
159 -- * Class 'Listable'
160 class Listable repr where
161 cons :: repr (a -> [a] -> [a])
162 nil :: repr [a]
163 cons = liftDerived cons
164 nil = liftDerived nil
165 default cons ::
166 FromDerived Listable repr =>
167 repr (a -> [a] -> [a])
168 default nil ::
169 FromDerived Listable repr =>
170 repr [a]
171
172 -- * Class 'Maybeable'
173 class Maybeable repr where
174 nothing :: repr (Maybe a)
175 just :: repr (a -> Maybe a)
176 nothing = liftDerived nothing
177 just = liftDerived just
178 default nothing ::
179 FromDerived Maybeable repr =>
180 repr (Maybe a)
181 default just ::
182 FromDerived Maybeable repr =>
183 repr (a -> Maybe a)
184
185 -- * Class 'IsoFunctor'
186 class IsoFunctor repr where
187 (<%>) :: Iso a b -> repr a -> repr b; infixl 4 <%>
188 (<%>) iso = liftDerived1 (iso <%>)
189 default (<%>) ::
190 FromDerived1 IsoFunctor repr =>
191 Iso a b -> repr a -> repr b
192
193 -- ** Type 'Iso'
194 data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
195 instance Cat.Category Iso where
196 id = Iso Cat.id Cat.id
197 f . g = Iso (a2b f Cat.. a2b g) (b2a g Cat.. b2a f)
198
199 -- * Class 'ProductFunctor'
200 -- | Beware that this is an @infixr@,
201 -- not @infixl@ like 'Control.Applicative.<*>';
202 -- this is to follow what is expected by 'ADT'.
203 class ProductFunctor repr where
204 (<.>) :: repr a -> repr b -> repr (a, b); infixr 4 <.>
205 (<.>) = liftDerived2 (<.>)
206 default (<.>) ::
207 FromDerived2 ProductFunctor repr =>
208 repr a -> repr b -> repr (a, b)
209 (<.) :: repr a -> repr () -> repr a; infixr 4 <.
210 ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
211 default (<.) :: IsoFunctor repr => repr a -> repr () -> repr a
212 (.>) :: repr () -> repr a -> repr a; infixr 4 .>
213 ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
214 default (.>) :: IsoFunctor repr => repr () -> repr a -> repr a
215
216 -- * Class 'SumFunctor'
217 -- | Beware that this is an @infixr@,
218 -- not @infixl@ like 'Control.Applicative.<|>';
219 -- this is to follow what is expected by 'ADT'.
220 class SumFunctor repr where
221 (<+>) :: repr a -> repr b -> repr (Either a b); infixr 3 <+>
222 (<+>) = liftDerived2 (<+>)
223 default (<+>) ::
224 FromDerived2 SumFunctor repr =>
225 repr a -> repr b -> repr (Either a b)
226
227 -- * Class 'AlternativeFunctor'
228 -- | Beware that this is an @infixr@,
229 -- not @infixl@ like 'Control.Applicative.<|>';
230 -- this is to follow what is expected by 'ADT'.
231 class AlternativeFunctor repr where
232 (<|>) :: repr a -> repr a -> repr a; infixr 3 <|>
233 (<|>) = liftDerived2 (<|>)
234 default (<|>) ::
235 FromDerived2 AlternativeFunctor repr =>
236 repr a -> repr a -> repr a
237
238 -- * Class 'Dicurryable'
239 class Dicurryable repr where
240 dicurry ::
241 CurryN args =>
242 proxy args ->
243 (args-..->a) -> -- construction
244 (a->Tuples args) -> -- destruction
245 repr (Tuples args) ->
246 repr a
247 dicurry args constr destr = liftDerived1 (dicurry args constr destr)
248 default dicurry ::
249 FromDerived1 Dicurryable repr =>
250 CurryN args =>
251 proxy args ->
252 (args-..->a) ->
253 (a->Tuples args) ->
254 repr (Tuples args) ->
255 repr a
256
257 construct ::
258 forall args a repr.
259 Dicurryable repr =>
260 Generic a =>
261 EoTOfRep a =>
262 CurryN args =>
263 Tuples args ~ EoT (ADT a) =>
264 (args ~ Args (args-..->a)) =>
265 (args-..->a) ->
266 repr (Tuples args) ->
267 repr a
268 construct f = dicurry (Proxy::Proxy args) f eotOfadt
269
270 adt ::
271 forall adt repr.
272 IsoFunctor repr =>
273 Generic adt =>
274 RepOfEoT adt =>
275 EoTOfRep adt =>
276 repr (EoT (ADT adt)) ->
277 repr adt
278 adt = (<%>) (Iso adtOfeot eotOfadt)
279
280 -- * Class 'Monoidable'
281 class
282 ( Emptyable repr
283 , Semigroupable repr
284 ) => Monoidable repr
285 instance
286 ( Emptyable repr
287 , Semigroupable repr
288 ) => Monoidable repr
289
290 -- ** Class 'Emptyable'
291 class Emptyable repr where
292 empty :: repr a
293 empty = liftDerived empty
294 default empty ::
295 FromDerived Emptyable repr =>
296 repr a
297
298 -- ** Class 'Semigroupable'
299 class Semigroupable repr where
300 concat :: Semigroup a => repr (a -> a -> a)
301 concat = liftDerived concat
302 default concat ::
303 FromDerived Semigroupable repr =>
304 Semigroup a =>
305 repr (a -> a -> a)
306
307 infixr 6 `concat`, <>
308 (<>) ::
309 Abstractable repr => Semigroupable repr => Semigroup a =>
310 repr a -> repr a -> repr a
311 (<>) x y = concat .@ x .@ y
312
313 -- ** Class 'Optionable'
314 class Optionable repr where
315 optional :: repr a -> repr (Maybe a)
316 optional = liftDerived1 optional
317 default optional ::
318 FromDerived1 Optionable repr =>
319 repr a -> repr (Maybe a)
320
321 -- * Class 'Repeatable'
322 class Repeatable repr where
323 many0 :: repr a -> repr [a]
324 many1 :: repr a -> repr [a]
325 many0 = liftDerived1 many0
326 many1 = liftDerived1 many1
327 default many0 ::
328 FromDerived1 Repeatable repr =>
329 repr a -> repr [a]
330 default many1 ::
331 FromDerived1 Repeatable repr =>
332 repr a -> repr [a]
333
334 -- | Alias to 'many0'.
335 many :: Repeatable repr => repr a -> repr [a]
336 many = many0
337
338 -- | Alias to 'many1'.
339 some :: Repeatable repr => repr a -> repr [a]
340 some = many1
341
342 -- * Class 'Permutable'
343 class Permutable repr where
344 -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
345 type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
346 type Permutation repr = Permutation (Derived repr)
347 permutable :: Permutation repr a -> repr a
348 perm :: repr a -> Permutation repr a
349 noPerm :: Permutation repr ()
350 permWithDefault :: a -> repr a -> Permutation repr a
351 optionalPerm ::
352 Eitherable repr => IsoFunctor repr => Permutable repr =>
353 repr a -> Permutation repr (Maybe a)
354 optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
355
356 (<&>) ::
357 Permutable repr =>
358 ProductFunctor (Permutation repr) =>
359 repr a ->
360 Permutation repr b ->
361 Permutation repr (a, b)
362 x <&> y = perm x <.> y
363 infixr 4 <&>
364 {-# INLINE (<&>) #-}
365
366 (<?&>) ::
367 Eitherable repr =>
368 IsoFunctor repr =>
369 Permutable repr =>
370 ProductFunctor (Permutation repr) =>
371 repr a ->
372 Permutation repr b ->
373 Permutation repr (Maybe a, b)
374 x <?&> y = optionalPerm x <.> y
375 infixr 4 <?&>
376 {-# INLINE (<?&>) #-}
377
378 (<*&>) ::
379 Eitherable repr =>
380 Repeatable repr =>
381 IsoFunctor repr =>
382 Permutable repr =>
383 ProductFunctor (Permutation repr) =>
384 repr a ->
385 Permutation repr b ->
386 Permutation repr ([a],b)
387 x <*&> y = permWithDefault [] (many1 x) <.> y
388 infixr 4 <*&>
389 {-# INLINE (<*&>) #-}
390
391 (<+&>) ::
392 Eitherable repr =>
393 Repeatable repr =>
394 IsoFunctor repr =>
395 Permutable repr =>
396 ProductFunctor (Permutation repr) =>
397 repr a ->
398 Permutation repr b ->
399 Permutation repr ([a], b)
400 x <+&> y = perm (many1 x) <.> y
401 infixr 4 <+&>
402 {-# INLINE (<+&>) #-}
403
404 -- * Class 'Routable'
405 class Routable repr where
406 (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
407 (<!>) = liftDerived2 (<!>)
408 default (<!>) ::
409 FromDerived2 Routable repr =>
410 repr a -> repr b -> repr (a, b)
411
412 -- | Like @(,)@ but @infixr@.
413 -- Mostly useful for clarity when using 'Routable'.
414 pattern (:!:) :: a -> b -> (a, b)
415 pattern a:!:b <- (a, b)
416 where a:!:b = (a, b)
417 infixr 4 :!:
418
419 -- * Class 'Voidable'
420 class Voidable repr where
421 -- | Useful to supply @(a)@ to a @(repr)@ consuming @(a)@,
422 -- for example in the format of a printing interpreter.
423 void :: a -> repr a -> repr ()
424 void = liftDerived1 Fun.. void
425 default void ::
426 FromDerived1 Voidable repr =>
427 a -> repr a -> repr ()
428
429 -- * Class 'Substractable'
430 class Substractable repr where
431 (<->) :: repr a -> repr b -> repr a; infixr 3 <->
432 (<->) = liftDerived2 (<->)
433 default (<->) ::
434 FromDerived2 Substractable repr =>
435 repr a -> repr b -> repr a