1 {-# LANGUAGE DataKinds #-} -- For ReprKind
2 {-# LANGUAGE PatternSynonyms #-} -- For (:!:)
3 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
4 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
5 module Symantic.Lang where
7 import Data.Bool (Bool(..))
8 import Data.Char (Char)
9 import Data.Either (Either(..))
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 import qualified Data.Tuple as Tuple
18 import Symantic.Derive
20 import Symantic.CurryN
23 type ReprKind = Type -> Type
25 -- * Class 'Abstractable'
26 class Abstractable repr where
27 -- | Application, aka. unabstract.
28 (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
29 -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
30 lam :: (repr a -> repr b) -> repr (a->b)
31 -- | Like 'lam' but whose argument is used only once,
32 -- hence safe to beta-reduce (inline) without duplicating work.
33 lam1 :: (repr a -> repr b) -> repr (a->b)
34 const :: repr (a -> b -> a)
35 flip :: repr ((a -> b -> c) -> b -> a -> c)
37 (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
38 ($) :: repr ((a->b) -> a -> b); infixr 0 $
39 var :: repr a -> repr a
40 (.@) = liftDerived2 (.@)
41 lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
42 lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
43 const = liftDerived const
44 flip = liftDerived flip
48 var = liftDerived1 var
50 FromDerived2 Abstractable repr =>
51 repr (a->b) -> repr a -> repr b
53 FromDerived Abstractable repr => Derivable repr =>
54 (repr a -> repr b) -> repr (a->b)
56 FromDerived Abstractable repr => Derivable repr =>
57 (repr a -> repr b) -> repr (a->b)
59 FromDerived Abstractable repr =>
62 FromDerived Abstractable repr =>
63 repr ((a -> b -> c) -> b -> a -> c)
65 FromDerived Abstractable repr =>
68 FromDerived Abstractable repr =>
69 repr ((b->c) -> (a->b) -> a -> c)
71 FromDerived Abstractable repr =>
72 repr ((a->b) -> a -> b)
74 FromDerived1 Abstractable repr =>
77 -- * Class 'Anythingable'
78 class Anythingable repr where
79 anything :: repr a -> repr a
82 -- * Class 'Bottomable'
83 class Bottomable repr where
86 -- * Class 'Constantable'
87 class Constantable c repr where
88 constant :: c -> repr c
89 constant = liftDerived Fun.. constant
91 FromDerived (Constantable c) repr =>
94 bool :: Constantable Bool repr => Bool -> repr Bool
96 char :: Constantable Char repr => Char -> repr Char
98 unit :: Constantable () repr => repr ()
99 unit = constant @() ()
101 -- * Class 'Eitherable'
102 class Eitherable repr where
103 left :: repr (l -> Either l r)
104 right :: repr (r -> Either l r)
105 left = liftDerived left
106 right = liftDerived right
108 FromDerived Eitherable repr =>
109 repr (l -> Either l r)
111 FromDerived Eitherable repr =>
112 repr (r -> Either l r)
114 -- * Class 'Equalable'
115 class Equalable repr where
116 equal :: Eq a => repr (a -> a -> Bool)
117 equal = liftDerived equal
119 FromDerived Equalable repr =>
120 Eq a => repr (a -> a -> Bool)
123 (==) :: (Abstractable repr, Equalable repr, Eq a) => repr (a -> a -> Bool)
124 (==) = lam (\x -> lam (\y -> equal .@ x .@ y))
126 -- * Class 'IfThenElseable'
127 class IfThenElseable repr where
128 ifThenElse :: repr Bool -> repr a -> repr a -> repr a
129 ifThenElse = liftDerived3 ifThenElse
130 default ifThenElse ::
131 FromDerived3 IfThenElseable repr =>
132 repr Bool -> repr a -> repr a -> repr a
134 -- * Class 'Listable'
135 class Listable repr where
136 cons :: repr (a -> [a] -> [a])
138 cons = liftDerived cons
139 nil = liftDerived nil
141 FromDerived Listable repr =>
142 repr (a -> [a] -> [a])
144 FromDerived Listable repr =>
147 -- * Class 'Maybeable'
148 class Maybeable repr where
149 nothing :: repr (Maybe a)
150 just :: repr (a -> Maybe a)
151 nothing = liftDerived nothing
152 just = liftDerived just
154 FromDerived Maybeable repr =>
157 FromDerived Maybeable repr =>
160 -- * Class 'IsoFunctor'
161 class IsoFunctor repr where
162 (<%>) :: Iso a b -> repr a -> repr b; infixl 4 <%>
163 (<%>) iso = liftDerived1 (iso <%>)
165 FromDerived1 IsoFunctor repr =>
166 Iso a b -> repr a -> repr b
169 data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
171 -- * Class 'ProductFunctor'
172 -- | Beware that this is an @infixr@,
173 -- not @infixl@ like to 'Control.Applicative.<*>';
174 -- this is to follow what is expected by 'ADT'.
175 class ProductFunctor repr where
176 (<.>) :: repr a -> repr b -> repr (a, b); infixr 4 <.>
177 (<.>) = liftDerived2 (<.>)
179 FromDerived2 ProductFunctor repr =>
180 repr a -> repr b -> repr (a, b)
181 (<.) :: repr a -> repr () -> repr a; infixr 4 <.
182 ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
183 default (<.) :: IsoFunctor repr => repr a -> repr () -> repr a
184 (.>) :: repr () -> repr a -> repr a; infixr 4 .>
185 ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
186 default (.>) :: IsoFunctor repr => repr () -> repr a -> repr a
188 -- * Class 'SumFunctor'
189 -- | Beware that this is an @infixr@,
190 -- not @infixl@ like to 'Control.Applicative.<|>';
191 -- this is to follow what is expected by 'ADT'.
192 class SumFunctor repr where
193 (<+>) :: repr a -> repr b -> repr (Either a b); infixr 3 <+>
194 (<+>) = liftDerived2 (<+>)
196 FromDerived2 SumFunctor repr =>
197 repr a -> repr b -> repr (Either a b)
199 -- * Class 'AlternativeFunctor'
200 -- | Beware that this is an @infixr@,
201 -- not @infixl@ like to 'Control.Applicative.<|>';
202 -- this is to follow what is expected by 'ADT'.
203 class AlternativeFunctor repr where
204 (<|>) :: repr a -> repr a -> repr a; infixr 3 <|>
205 (<|>) = liftDerived2 (<|>)
207 FromDerived2 AlternativeFunctor repr =>
208 repr a -> repr a -> repr a
210 -- * Class 'Dicurryable'
211 class Dicurryable repr where
215 (args-..->a) -> -- construction
216 (a->Tuples args) -> -- destruction
217 repr (Tuples args) ->
219 dicurry args constr destr = liftDerived1 (dicurry args constr destr)
221 FromDerived1 Dicurryable repr =>
226 repr (Tuples args) ->
235 Tuples args ~ EoT (ADT a) =>
236 (args ~ Args (args-..->a)) =>
238 repr (Tuples args) ->
240 construct f = dicurry (Proxy::Proxy args) f eotOfadt
248 repr (EoT (ADT adt)) ->
250 adt = (<%>) (Iso adtOfeot eotOfadt)
252 -- ** Class 'Emptyable'
253 class Emptyable repr where
255 empty = liftDerived empty
257 FromDerived Emptyable repr =>
260 -- ** Class 'Optionable'
261 class Optionable repr where
262 option :: repr a -> repr a
263 optional :: repr a -> repr (Maybe a)
264 option = liftDerived1 option
265 optional = liftDerived1 optional
267 FromDerived1 Optionable repr =>
270 FromDerived1 Optionable repr =>
271 repr a -> repr (Maybe a)
273 -- * Class 'Repeatable'
274 class Repeatable repr where
275 many0 :: repr a -> repr [a]
276 many1 :: repr a -> repr [a]
277 many0 = liftDerived1 many0
278 many1 = liftDerived1 many1
280 FromDerived1 Repeatable repr =>
283 FromDerived1 Repeatable repr =>
286 -- * Class 'Permutable'
287 class Permutable repr where
288 -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
289 type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
290 type Permutation repr = Permutation (Derived repr)
291 permutable :: Permutation repr a -> repr a
292 perm :: repr a -> Permutation repr a
293 noPerm :: Permutation repr ()
294 permWithDefault :: a -> repr a -> Permutation repr a
296 Eitherable repr => IsoFunctor repr => Permutable repr =>
297 repr a -> Permutation repr (Maybe a)
298 optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
302 ProductFunctor (Permutation repr) =>
304 Permutation repr b ->
305 Permutation repr (a, b)
306 x <&> y = perm x <.> y
314 ProductFunctor (Permutation repr) =>
316 Permutation repr b ->
317 Permutation repr (Maybe a, b)
318 x <?&> y = optionalPerm x <.> y
320 {-# INLINE (<?&>) #-}
327 ProductFunctor (Permutation repr) =>
329 Permutation repr b ->
330 Permutation repr ([a],b)
331 x <*&> y = permWithDefault [] (many1 x) <.> y
333 {-# INLINE (<*&>) #-}
340 ProductFunctor (Permutation repr) =>
342 Permutation repr b ->
343 Permutation repr ([a], b)
344 x <+&> y = perm (many1 x) <.> y
346 {-# INLINE (<+&>) #-}
348 -- * Class 'Routable'
349 class Routable repr where
350 (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
351 (<!>) = liftDerived2 (<!>)
353 FromDerived2 Routable repr =>
354 repr a -> repr b -> repr (a, b)
356 -- | Like @(,)@ but @infixr@.
357 -- Mostly useful for clarity when using 'Routable'.
358 pattern (:!:) :: a -> b -> (a, b)
359 pattern a:!:b <- (a, b)
363 -- * Class 'Voidable'
364 -- | FIXME: this class should likely be removed
365 class Voidable repr where
366 void :: a -> repr a -> repr ()
367 void = liftDerived1 Fun.. void
369 FromDerived1 Voidable repr =>
370 a -> repr a -> repr ()
372 -- * Class 'Substractable'
373 class Substractable repr where
374 (<->) :: repr a -> repr b -> repr a; infixr 3 <->
375 (<->) = liftDerived2 (<->)
377 FromDerived2 Substractable repr =>
378 repr a -> repr b -> repr a