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
17 import Symantic.Derive
19 import Symantic.CurryN
22 type ReprKind = Type -> Type
24 -- * Class 'Abstractable'
25 class Abstractable repr where
26 -- | Application, aka. unabstract.
27 (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
28 -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
29 lam :: (repr a -> repr b) -> repr (a->b)
30 -- | Like 'lam' but whose argument is used only once,
31 -- hence safe to beta-reduce (inline) without duplicating work.
32 lam1 :: (repr a -> repr b) -> repr (a->b)
33 const :: repr (a -> b -> a)
34 flip :: repr ((a -> b -> c) -> b -> a -> c)
36 (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
37 ($) :: repr ((a->b) -> a -> b); infixr 0 $
38 var :: repr a -> repr a
39 (.@) = liftDerived2 (.@)
40 lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
41 lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
42 const = liftDerived const
43 flip = liftDerived flip
47 var = liftDerived1 var
49 FromDerived2 Abstractable repr =>
50 repr (a->b) -> repr a -> repr b
52 FromDerived Abstractable repr => Derivable repr =>
53 (repr a -> repr b) -> repr (a->b)
55 FromDerived Abstractable repr => Derivable repr =>
56 (repr a -> repr b) -> repr (a->b)
58 FromDerived Abstractable repr =>
61 FromDerived Abstractable repr =>
62 repr ((a -> b -> c) -> b -> a -> c)
64 FromDerived Abstractable repr =>
67 FromDerived Abstractable repr =>
68 repr ((b->c) -> (a->b) -> a -> c)
70 FromDerived Abstractable repr =>
71 repr ((a->b) -> a -> b)
73 FromDerived1 Abstractable repr =>
76 -- * Class 'Anythingable'
77 class Anythingable repr where
78 anything :: repr a -> repr a
81 -- * Class 'Bottomable'
82 class Bottomable repr where
85 -- * Class 'Constantable'
86 class Constantable c repr where
87 constant :: c -> repr c
88 constant = liftDerived Fun.. constant
90 FromDerived (Constantable c) repr =>
93 bool :: Constantable Bool repr => Bool -> repr Bool
95 char :: Constantable Char repr => Char -> repr Char
97 unit :: Constantable () repr => repr ()
98 unit = constant @() ()
100 -- * Class 'Eitherable'
101 class Eitherable repr where
102 left :: repr (l -> Either l r)
103 right :: repr (r -> Either l r)
104 left = liftDerived left
105 right = liftDerived right
107 FromDerived Eitherable repr =>
108 repr (l -> Either l r)
110 FromDerived Eitherable repr =>
111 repr (r -> Either l r)
113 -- * Class 'Equalable'
114 class Equalable repr where
115 equal :: Eq a => repr (a -> a -> Bool)
116 equal = liftDerived equal
118 FromDerived Equalable repr =>
119 Eq a => repr (a -> a -> Bool)
122 (==) :: (Abstractable repr, Equalable repr, Eq a) => repr (a -> a -> Bool)
123 (==) = lam (\x -> lam (\y -> equal .@ x .@ y))
125 -- * Class 'IfThenElseable'
126 class IfThenElseable repr where
127 ifThenElse :: repr Bool -> repr a -> repr a -> repr a
128 ifThenElse = liftDerived3 ifThenElse
129 default ifThenElse ::
130 FromDerived3 IfThenElseable repr =>
131 repr Bool -> repr a -> repr a -> repr a
133 -- * Class 'Listable'
134 class Listable repr where
135 cons :: repr (a -> [a] -> [a])
137 cons = liftDerived cons
138 nil = liftDerived nil
140 FromDerived Listable repr =>
141 repr (a -> [a] -> [a])
143 FromDerived Listable repr =>
146 -- * Class 'Maybeable'
147 class Maybeable repr where
148 nothing :: repr (Maybe a)
149 just :: repr (a -> Maybe a)
150 nothing = liftDerived nothing
151 just = liftDerived just
153 FromDerived Maybeable repr =>
156 FromDerived Maybeable repr =>
159 -- * Class 'IsoFunctor'
160 class IsoFunctor repr where
161 (<%>) :: Iso a b -> repr a -> repr b
162 (<%>) iso = liftDerived1 (iso <%>)
164 FromDerived1 IsoFunctor repr =>
165 Iso a b -> repr a -> repr b
168 data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
170 -- * Class 'ProductFunctor'
171 class ProductFunctor repr where
172 (<.>) :: repr a -> repr b -> repr (a, b)
173 (<.>) = liftDerived2 (<.>)
175 FromDerived2 ProductFunctor repr =>
176 repr a -> repr b -> repr (a, b)
178 -- * Class 'AlternativeFunctor'
179 class AlternativeFunctor repr where
180 (<+>) :: repr a -> repr a -> repr a
181 (<+>) = liftDerived2 (<+>)
183 FromDerived2 AlternativeFunctor repr =>
184 repr a -> repr a -> repr a
186 -- * Class 'Dicurryable'
187 class Dicurryable repr where
191 (args-..->r) -> -- construction
192 (r->Tuples args) -> -- destruction
195 dicurry args constr destr = liftDerived1 (dicurry args constr destr)
197 FromDerived1 Dicurryable repr =>
206 forall args a k repr.
211 Tuples args ~ EoT (ADT a) =>
212 (args ~ Args (args-..->a)) =>
216 construct f = dicurry (Proxy::Proxy args) f eotOfadt
224 repr (EoT (ADT adt)) ->
226 adt = (<%>) (Iso adtOfeot eotOfadt)
228 -- ** Class 'Emptyable'
229 class Emptyable repr where
231 empty = liftDerived empty
233 FromDerived Emptyable repr =>
236 -- ** Class 'Optionable'
237 class Optionable repr where
238 option :: repr a -> repr a
239 optional :: repr a -> repr (Maybe a)
240 option = liftDerived1 option
241 optional = liftDerived1 optional
243 FromDerived1 Optionable repr =>
246 FromDerived1 Optionable repr =>
247 repr a -> repr (Maybe a)
249 -- * Class 'Repeatable'
250 class Repeatable repr where
251 many0 :: repr a -> repr [a]
252 many1 :: repr a -> repr [a]
253 many0 = liftDerived1 many0
254 many1 = liftDerived1 many1
256 FromDerived1 Repeatable repr =>
259 FromDerived1 Repeatable repr =>
262 -- * Class 'Permutable'
263 class Permutable repr where
264 -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
265 type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
266 type Permutation repr = Permutation (Derived repr)
267 permutable :: Permutation repr a -> repr a
268 perm :: repr a -> Permutation repr a
269 noPerm :: Permutation repr ()
270 permWithDefault :: a -> repr a -> Permutation repr a
272 Eitherable repr => IsoFunctor repr => Permutable repr =>
273 repr a -> Permutation repr (Maybe a)
274 optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
278 ProductFunctor (Permutation repr) =>
280 Permutation repr b ->
281 Permutation repr (a, b)
282 x <&> y = perm x <.> y
288 ProductFunctor (Permutation repr) =>
290 Permutation repr b ->
291 Permutation repr (Maybe a, b)
292 x <?&> y = optionalPerm x <.> y
299 ProductFunctor (Permutation repr) =>
301 Permutation repr b ->
302 Permutation repr ([a],b)
303 x <*&> y = permWithDefault [] (many1 x) <.> y
310 ProductFunctor (Permutation repr) =>
312 Permutation repr b ->
313 Permutation repr ([a],b)
314 x <+&> y = perm (many1 x) <.> y
322 {-# INLINE (<?&>) #-}
323 {-# INLINE (<*&>) #-}
324 {-# INLINE (<+&>) #-}
326 -- * Class 'Routable'
327 class Routable repr where
328 (<!>) :: repr a -> repr b -> repr (a, b)
329 (<!>) = liftDerived2 (<!>)
331 FromDerived2 Routable repr =>
332 repr a -> repr b -> repr (a,b)
334 -- | Like @(,)@ but @infixr@.
335 -- Mostly useful for clarity when using 'Routable'.
336 pattern (:!:) :: a -> b -> (a,b)
337 pattern a:!:b <- (a,b)
341 -- * Class 'Voidable'
342 -- | FIXME: this class should likely be removed
343 class Voidable repr where
344 void :: a -> repr a -> repr ()
345 void = liftDerived1 Fun.. void
347 FromDerived1 Voidable repr =>
348 a -> repr a -> repr ()
350 -- * Class 'Substractable'
351 class Substractable repr where
352 (<->) :: repr a -> repr b -> repr a
353 (<->) = liftDerived2 (<->)
355 FromDerived2 Substractable repr =>
356 repr a -> repr b -> repr a