2 {-# LANGUAGE AllowAmbiguousTypes #-}
4 {-# LANGUAGE DataKinds #-}
6 {-# LANGUAGE PatternSynonyms #-}
8 {-# LANGUAGE RankNTypes #-}
10 {-# LANGUAGE TypeFamilyDependencies #-}
12 {-# LANGUAGE UndecidableInstances #-}
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
18 import Control.Category qualified as Cat
19 import Data.Bool (Bool (..))
20 import Data.Char (Char)
21 import Data.Either (Either (..))
23 import Data.Function qualified as Fun
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)
34 import Symantic.Syntaxes.CurryN
35 import Symantic.Syntaxes.Derive
36 import Symantic.Syntaxes.EithersOfTuples
39 type Syntax = Semantic -> Constraint
41 -- ** Type family 'Syntaxes'
43 -- | Merge several 'Syntax'es into a single one.
45 -- Useful in 'IfSemantic'.
46 type family Syntaxes (syns :: [Syntax]) (sem :: Semantic) :: Constraint where
48 Syntaxes (syn ': syns) sem = (syn sem, Syntaxes syns sem)
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)
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)
60 lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
61 lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
62 var = liftDerived1 var
64 FromDerived Abstractable sem =>
69 FromDerived Abstractable sem =>
74 FromDerived1 Abstractable sem =>
78 -- ** Class 'Unabstractable'
79 class Unabstractable sem where
80 -- | Application, aka. unabstract.
81 (.@) :: sem (a -> b) -> sem a -> sem b
84 (.@) = liftDerived2 (.@)
86 FromDerived2 Unabstractable sem =>
91 -- ** Class 'Functionable'
92 class Functionable sem where
93 const :: sem (a -> b -> a)
94 flip :: sem ((a -> b -> c) -> b -> a -> c)
96 (.) :: sem ((b -> c) -> (a -> b) -> a -> c)
98 ($) :: sem ((a -> b) -> a -> b)
100 const = liftDerived const
101 flip = liftDerived flip
103 (.) = liftDerived (.)
104 ($) = liftDerived ($)
106 FromDerived Functionable sem =>
109 FromDerived Functionable sem =>
110 sem ((a -> b -> c) -> b -> a -> c)
112 FromDerived Functionable sem =>
115 FromDerived Functionable sem =>
116 sem ((b -> c) -> (a -> b) -> a -> c)
118 FromDerived Functionable sem =>
119 sem ((a -> b) -> a -> b)
121 -- * Class 'Anythingable'
122 class Anythingable sem where
123 anything :: sem a -> sem a
126 -- * Class 'Bottomable'
127 class Bottomable sem where
130 -- * Class 'Constantable'
131 class Constantable c sem where
132 constant :: c -> sem c
133 constant = liftDerived Fun.. constant
135 FromDerived (Constantable c) sem =>
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
148 FromDerived Eitherable sem =>
149 sem ((l -> a) -> (r -> a) -> Either l r -> a)
151 FromDerived Eitherable sem =>
152 sem (l -> Either l r)
154 FromDerived Eitherable sem =>
155 sem (r -> Either l r)
157 -- * Class 'Equalable'
158 class Equalable sem where
159 equal :: Eq a => sem (a -> a -> Bool)
160 equal = liftDerived equal
162 FromDerived Equalable sem =>
174 (==) x y = equal .@ x .@ y
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 =>
187 -- * Class 'Inferable'
188 class Inferable a sem where
190 default infer :: FromDerived (Inferable a) sem => sem a
191 infer = liftDerived infer
193 unit :: Inferable () sem => sem ()
195 bool :: Inferable Bool sem => sem Bool
197 char :: Inferable Char sem => sem Char
199 int :: Inferable Int sem => sem Int
201 natural :: Inferable Natural sem => sem Natural
203 string :: Inferable String sem => sem String
206 -- * Class 'Listable'
207 class Listable sem where
208 cons :: sem (a -> [a] -> [a])
210 cons = liftDerived cons
211 nil = liftDerived nil
213 FromDerived Listable sem =>
214 sem (a -> [a] -> [a])
216 FromDerived Listable sem =>
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
226 FromDerived Maybeable sem =>
229 FromDerived Maybeable sem =>
232 -- * Class 'IsoFunctor'
233 class IsoFunctor sem where
234 (<%>) :: Iso a b -> sem a -> sem b
236 (<%>) iso = liftDerived1 (iso <%>)
238 FromDerived1 IsoFunctor sem =>
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)
249 -- * Class 'ProductFunctor'
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)
257 (<.>) = liftDerived2 (<.>)
259 FromDerived2 ProductFunctor sem =>
263 (<.) :: sem a -> sem () -> sem a
265 ra <. rb = Iso Tuple.fst (,()) <%> (ra <.> rb)
266 default (<.) :: IsoFunctor sem => sem a -> sem () -> sem a
267 (.>) :: sem () -> sem a -> sem a
269 ra .> rb = Iso Tuple.snd ((),) <%> (ra <.> rb)
270 default (.>) :: IsoFunctor sem => sem () -> sem a -> sem a
272 -- * Class 'SumFunctor'
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)
280 (<+>) = liftDerived2 (<+>)
282 FromDerived2 SumFunctor sem =>
287 -- | Like @(,)@ but @infixr@.
288 -- Mostly useful for clarity when using 'SumFunctor'.
289 pattern (:!:) :: a -> b -> (a, b)
297 -- * Class 'AlternativeFunctor'
299 -- | Beware that this is an @infixr@,
300 -- not @infixl@ like 'Control.Applicative.<|>';
301 -- this is to follow what is expected by 'ADT'.
302 class AlternativeFunctor sem where
303 (<|>) :: sem a -> sem a -> sem a
305 (<|>) = liftDerived2 (<|>)
307 FromDerived2 AlternativeFunctor sem =>
312 -- * Class 'Dicurryable'
313 class Dicurryable sem where
317 (args -..-> a) -> -- construction
318 (a -> Tuples args) -> -- destruction
321 dicurry args constr destr = liftDerived1 (dicurry args constr destr)
323 FromDerived1 Dicurryable sem =>
327 (a -> Tuples args) ->
337 Tuples args ~ EoT (ADT a) =>
338 (args ~ Args (args -..-> a)) =>
342 construct f = dicurry (Proxy :: Proxy args) f eotOfadt
344 -- * Class 'Dataable'
346 -- | Enable the contruction or deconstruction
347 -- of a any algebraic data type.
348 class Dataable sem where
349 -- | Unfortunately, 'UnToF' is needed for the 'ToFer' instance.
350 data_ :: Generic a => RepOfEoT a => EoTOfRep a => UnToF a => sem (EoT (ADT a)) -> sem a
358 data_ = (<%>) (Iso adtOfeot eotOfadt)
360 -- | Like 'data_' but with the @(a)@ type parameter first
361 -- for convenience when specifying it.
362 dataType :: forall a sem. Dataable sem => Generic a => RepOfEoT a => EoTOfRep a => UnToF a => sem (EoT (ADT a)) -> sem a
365 -- * Class 'IfSemantic'
367 -- | 'IfSemantic' enables to change the 'Syntax' for a specific 'Semantic'.
369 -- Useful when a 'Semantic' does not implement some 'Syntax'es used by other 'Semantic's.
372 (thenSyntaxes :: [Syntax])
373 (elseSyntaxes :: [Syntax])
378 (Syntaxes thenSyntaxes thenSemantic => thenSemantic a) ->
379 (Syntaxes elseSyntaxes elseSemantic => elseSemantic a) ->
384 Syntaxes thenSyntaxes thenSemantic =>
385 IfSemantic thenSyntaxes elseSyntaxes thenSemantic thenSemantic
387 ifSemantic thenSyntax _elseSyntax = thenSyntax
389 Syntaxes elseSyntaxes elseSemantic =>
390 IfSemantic thenSyntaxes elseSyntaxes thenSemantic elseSemantic
392 ifSemantic _thenSyntax elseSyntax = elseSyntax
394 -- * Class 'Monoidable'
406 -- ** Class 'Emptyable'
407 class Emptyable sem where
409 empty = liftDerived empty
411 FromDerived Emptyable sem =>
414 -- ** Class 'Semigroupable'
415 class Semigroupable sem where
416 concat :: Semigroup a => sem (a -> a -> a)
417 concat = liftDerived concat
419 FromDerived Semigroupable sem =>
423 infixr 6 `concat`, <>
431 (<>) x y = concat .@ x .@ y
433 -- ** Class 'Optionable'
434 class Optionable sem where
435 optional :: sem a -> sem (Maybe a)
436 optional = liftDerived1 optional
438 FromDerived1 Optionable sem =>
442 -- * Class 'Repeatable'
443 class Repeatable sem where
444 many0 :: sem a -> sem [a]
445 many1 :: sem a -> sem [a]
446 many0 = liftDerived1 many0
447 many1 = liftDerived1 many1
449 FromDerived1 Repeatable sem =>
453 FromDerived1 Repeatable sem =>
457 -- | Alias to 'many0'.
458 many :: Repeatable sem => sem a -> sem [a]
461 -- | Alias to 'many1'.
462 some :: Repeatable sem => sem a -> sem [a]
465 -- * Class 'Permutable'
466 class Permutable sem where
467 -- Use @TypeFamilyDependencies@ to help type-inference infer @(sem)@.
468 type Permutation (sem :: Semantic) = (r :: Semantic) | r -> sem
469 type Permutation sem = Permutation (Derived sem)
470 permutable :: Permutation sem a -> sem a
471 perm :: sem a -> Permutation sem a
472 noPerm :: Permutation sem ()
473 permWithDefault :: a -> sem a -> Permutation sem a
479 Permutation sem (Maybe a)
480 optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
484 ProductFunctor (Permutation sem) =>
487 Permutation sem (a, b)
488 x <&> y = perm x <.> y
496 ProductFunctor (Permutation sem) =>
499 Permutation sem (Maybe a, b)
500 x <?&> y = optionalPerm x <.> y
502 {-# INLINE (<?&>) #-}
509 ProductFunctor (Permutation sem) =>
512 Permutation sem ([a], b)
513 x <*&> y = permWithDefault [] (many1 x) <.> y
515 {-# INLINE (<*&>) #-}
522 ProductFunctor (Permutation sem) =>
525 Permutation sem ([a], b)
526 x <+&> y = perm (many1 x) <.> y
528 {-# INLINE (<+&>) #-}
530 -- * Class 'Voidable'
531 class Voidable sem where
532 -- | Useful to supply @(a)@ to a @(sem)@ consuming @(a)@,
533 -- for example in the format of a printing interpreter.
534 void :: a -> sem a -> sem ()
535 void = liftDerived1 Fun.. void
537 FromDerived1 Voidable sem =>
542 -- * Class 'Substractable'
543 class Substractable sem where
544 (<->) :: sem a -> sem b -> sem a
546 (<->) = liftDerived2 (<->)
548 FromDerived2 Substractable sem =>