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