]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Classes.hs
iface: rename `Symantic.{View => Viewer}`
[haskell/symantic-base.git] / src / Symantic / Classes.hs
1 {-# LANGUAGE DataKinds #-} -- For ReprKind
2 {-# LANGUAGE PatternSynonyms #-} -- For (:!:)
3 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
4 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
5 -- | Comibnators 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 option :: repr a -> repr a
316 optional :: repr a -> repr (Maybe a)
317 option = liftDerived1 option
318 optional = liftDerived1 optional
319 default option ::
320 FromDerived1 Optionable repr =>
321 repr a -> repr a
322 default optional ::
323 FromDerived1 Optionable repr =>
324 repr a -> repr (Maybe a)
325
326 -- * Class 'Repeatable'
327 class Repeatable repr where
328 many0 :: repr a -> repr [a]
329 many1 :: repr a -> repr [a]
330 many0 = liftDerived1 many0
331 many1 = liftDerived1 many1
332 default many0 ::
333 FromDerived1 Repeatable repr =>
334 repr a -> repr [a]
335 default many1 ::
336 FromDerived1 Repeatable repr =>
337 repr a -> repr [a]
338
339 -- | Alias to 'many0'.
340 many :: Repeatable repr => repr a -> repr [a]
341 many = many0
342
343 -- | Alias to 'many1'.
344 some :: Repeatable repr => repr a -> repr [a]
345 some = many1
346
347 -- * Class 'Permutable'
348 class Permutable repr where
349 -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
350 type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
351 type Permutation repr = Permutation (Derived repr)
352 permutable :: Permutation repr a -> repr a
353 perm :: repr a -> Permutation repr a
354 noPerm :: Permutation repr ()
355 permWithDefault :: a -> repr a -> Permutation repr a
356 optionalPerm ::
357 Eitherable repr => IsoFunctor repr => Permutable repr =>
358 repr a -> Permutation repr (Maybe a)
359 optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
360
361 (<&>) ::
362 Permutable repr =>
363 ProductFunctor (Permutation repr) =>
364 repr a ->
365 Permutation repr b ->
366 Permutation repr (a, b)
367 x <&> y = perm x <.> y
368 infixr 4 <&>
369 {-# INLINE (<&>) #-}
370
371 (<?&>) ::
372 Eitherable repr =>
373 IsoFunctor repr =>
374 Permutable repr =>
375 ProductFunctor (Permutation repr) =>
376 repr a ->
377 Permutation repr b ->
378 Permutation repr (Maybe a, b)
379 x <?&> y = optionalPerm x <.> y
380 infixr 4 <?&>
381 {-# INLINE (<?&>) #-}
382
383 (<*&>) ::
384 Eitherable repr =>
385 Repeatable repr =>
386 IsoFunctor repr =>
387 Permutable repr =>
388 ProductFunctor (Permutation repr) =>
389 repr a ->
390 Permutation repr b ->
391 Permutation repr ([a],b)
392 x <*&> y = permWithDefault [] (many1 x) <.> y
393 infixr 4 <*&>
394 {-# INLINE (<*&>) #-}
395
396 (<+&>) ::
397 Eitherable repr =>
398 Repeatable repr =>
399 IsoFunctor repr =>
400 Permutable repr =>
401 ProductFunctor (Permutation repr) =>
402 repr a ->
403 Permutation repr b ->
404 Permutation repr ([a], b)
405 x <+&> y = perm (many1 x) <.> y
406 infixr 4 <+&>
407 {-# INLINE (<+&>) #-}
408
409 -- * Class 'Routable'
410 class Routable repr where
411 (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
412 (<!>) = liftDerived2 (<!>)
413 default (<!>) ::
414 FromDerived2 Routable repr =>
415 repr a -> repr b -> repr (a, b)
416
417 -- | Like @(,)@ but @infixr@.
418 -- Mostly useful for clarity when using 'Routable'.
419 pattern (:!:) :: a -> b -> (a, b)
420 pattern a:!:b <- (a, b)
421 where a:!:b = (a, b)
422 infixr 4 :!:
423
424 -- * Class 'Voidable'
425 class Voidable repr where
426 -- | Useful to supply @(a)@ to a @(repr)@ consuming @(a)@,
427 -- for example in the format of a printing interpreter.
428 void :: a -> repr a -> repr ()
429 void = liftDerived1 Fun.. void
430 default void ::
431 FromDerived1 Voidable repr =>
432 a -> repr a -> repr ()
433
434 -- * Class 'Substractable'
435 class Substractable repr where
436 (<->) :: repr a -> repr b -> repr a; infixr 3 <->
437 (<->) = liftDerived2 (<->)
438 default (<->) ::
439 FromDerived2 Substractable repr =>
440 repr a -> repr b -> repr a