src/Symantic/Class.hs

   1 {-# LANGUAGE DataKinds #-} -- For ReprKind
   2 {-# LANGUAGE PatternSynonyms #-} -- For (:!:)
   3 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
   4 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
   5 module Symantic.Class where
   6
   7 import Data.Bool (Bool(..))
   8 import Data.Char (Char)
   9 import Data.Either (Either(..))
  10 import Data.Eq (Eq)
  11 import Data.Kind (Type)
  12 import Data.Maybe (Maybe(..), fromJust)
  13 import Data.Proxy (Proxy(..))
  14 import Data.Semigroup (Semigroup)
  15 import GHC.Generics (Generic)
  16 import qualified Control.Category as Cat
  17 import qualified Data.Function as Fun
  18 import qualified Data.Tuple as Tuple
  19
  20 import Symantic.Derive
  21 import Symantic.ADT
  22 import Symantic.CurryN
  23
  24 -- * Type 'ReprKind'
  25 type ReprKind = Type -> Type
  26
  27 -- * Class 'Abstractable'
  28 class Abstractable repr where
  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   var :: repr a -> repr a
  35   -- | Application, aka. unabstract.
  36   (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
  37   lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
  38   lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
  39   var = liftDerived1 var
  40   (.@) = liftDerived2 (.@)
  41   default lam ::
  42     FromDerived Abstractable repr => Derivable repr =>
  43     (repr a -> repr b) -> repr (a->b)
  44   default lam1 ::
  45     FromDerived Abstractable repr => Derivable repr =>
  46     (repr a -> repr b) -> repr (a->b)
  47   default var ::
  48     FromDerived1 Abstractable repr =>
  49     repr a -> repr a
  50   default (.@) ::
  51     FromDerived2 Abstractable repr =>
  52     repr (a->b) -> repr a -> repr b
  53
  54 -- ** Class 'Functionable'
  55 class Functionable repr where
  56   const :: repr (a -> b -> a)
  57   flip :: repr ((a -> b -> c) -> b -> a -> c)
  58   id :: repr (a->a)
  59   (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
  60   ($) :: repr ((a->b) -> a -> b); infixr 0 $
  61   const = liftDerived const
  62   flip = liftDerived flip
  63   id = liftDerived id
  64   (.) = liftDerived (.)
  65   ($) = liftDerived ($)
  66   default const ::
  67     FromDerived Functionable repr =>
  68     repr (a -> b -> a)
  69   default flip ::
  70     FromDerived Functionable repr =>
  71     repr ((a -> b -> c) -> b -> a -> c)
  72   default id ::
  73     FromDerived Functionable repr =>
  74     repr (a->a)
  75   default (.) ::
  76     FromDerived Functionable repr =>
  77     repr ((b->c) -> (a->b) -> a -> c)
  78   default ($) ::
  79     FromDerived Functionable repr =>
  80     repr ((a->b) -> a -> b)
  81
  82 -- * Class 'Anythingable'
  83 class Anythingable repr where
  84   anything :: repr a -> repr a
  85   anything = Fun.id
  86
  87 -- * Class 'Bottomable'
  88 class Bottomable repr where
  89   bottom :: repr a
  90
  91 -- * Class 'Constantable'
  92 class Constantable c repr where
  93   constant :: c -> repr c
  94   constant = liftDerived Fun.. constant
  95   default constant ::
  96     FromDerived (Constantable c) repr =>
  97     c -> repr c
  98
  99 bool :: Constantable Bool repr => Bool -> repr Bool
 100 bool = constant @Bool
 101 char :: Constantable Char repr => Char -> repr Char
 102 char = constant @Char
 103 unit :: Constantable () repr => repr ()
 104 unit = constant @() ()
 105
 106 -- * Class 'Eitherable'
 107 class Eitherable repr where
 108   left :: repr (l -> Either l r)
 109   right :: repr (r -> Either l r)
 110   left = liftDerived left
 111   right = liftDerived right
 112   default left ::
 113     FromDerived Eitherable repr =>
 114     repr (l -> Either l r)
 115   default right ::
 116     FromDerived Eitherable repr =>
 117     repr (r -> Either l r)
 118
 119 -- * Class 'Equalable'
 120 class Equalable repr where
 121   equal :: Eq a => repr (a -> a -> Bool)
 122   equal = liftDerived equal
 123   default equal ::
 124     FromDerived Equalable repr =>
 125     Eq a => repr (a -> a -> Bool)
 126
 127 infix 4 `equal`, ==
 128 (==) :: (Abstractable repr, Equalable repr, Eq a) => repr (a -> a -> Bool)
 129 (==) = lam (\x -> lam (\y -> equal .@ x .@ y))
 130
 131 -- * Class 'IfThenElseable'
 132 class IfThenElseable repr where
 133   ifThenElse :: repr Bool -> repr a -> repr a -> repr a
 134   ifThenElse = liftDerived3 ifThenElse
 135   default ifThenElse ::
 136     FromDerived3 IfThenElseable repr =>
 137     repr Bool -> repr a -> repr a -> repr a
 138
 139 -- * Class 'Listable'
 140 class Listable repr where
 141   cons :: repr (a -> [a] -> [a])
 142   nil :: repr [a]
 143   cons = liftDerived cons
 144   nil = liftDerived nil
 145   default cons ::
 146     FromDerived Listable repr =>
 147     repr (a -> [a] -> [a])
 148   default nil ::
 149     FromDerived Listable repr =>
 150     repr [a]
 151
 152 -- * Class 'Maybeable'
 153 class Maybeable repr where
 154   nothing :: repr (Maybe a)
 155   just :: repr (a -> Maybe a)
 156   nothing = liftDerived nothing
 157   just = liftDerived just
 158   default nothing ::
 159     FromDerived Maybeable repr =>
 160     repr (Maybe a)
 161   default just ::
 162     FromDerived Maybeable repr =>
 163     repr (a -> Maybe a)
 164
 165 -- * Class 'IsoFunctor'
 166 class IsoFunctor repr where
 167   (<%>) :: Iso a b -> repr a -> repr b; infixl 4 <%>
 168   (<%>) iso = liftDerived1 (iso <%>)
 169   default (<%>) ::
 170     FromDerived1 IsoFunctor repr =>
 171     Iso a b -> repr a -> repr b
 172
 173 -- ** Type 'Iso'
 174 data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
 175 instance Cat.Category Iso where
 176   id = Iso Cat.id Cat.id
 177   f . g = Iso (a2b f Cat.. a2b g) (b2a g Cat.. b2a f)
 178
 179 -- * Class 'ProductFunctor'
 180 -- | Beware that this is an @infixr@,
 181 -- not @infixl@ like to 'Control.Applicative.<*>';
 182 -- this is to follow what is expected by 'ADT'.
 183 class ProductFunctor repr where
 184   (<.>) :: repr a -> repr b -> repr (a, b); infixr 4 <.>
 185   (<.>) = liftDerived2 (<.>)
 186   default (<.>) ::
 187     FromDerived2 ProductFunctor repr =>
 188     repr a -> repr b -> repr (a, b)
 189   (<.) :: repr a -> repr () -> repr a; infixr 4 <.
 190   ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
 191   default (<.) :: IsoFunctor repr => repr a -> repr () -> repr a
 192   (.>) :: repr () -> repr a -> repr a; infixr 4 .>
 193   ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
 194   default (.>) :: IsoFunctor repr => repr () -> repr a -> repr a
 195
 196 -- * Class 'SumFunctor'
 197 -- | Beware that this is an @infixr@,
 198 -- not @infixl@ like to 'Control.Applicative.<|>';
 199 -- this is to follow what is expected by 'ADT'.
 200 class SumFunctor repr where
 201   (<+>) :: repr a -> repr b -> repr (Either a b); infixr 3 <+>
 202   (<+>) = liftDerived2 (<+>)
 203   default (<+>) ::
 204     FromDerived2 SumFunctor repr =>
 205     repr a -> repr b -> repr (Either a b)
 206
 207 -- * Class 'AlternativeFunctor'
 208 -- | Beware that this is an @infixr@,
 209 -- not @infixl@ like to 'Control.Applicative.<|>';
 210 -- this is to follow what is expected by 'ADT'.
 211 class AlternativeFunctor repr where
 212   (<|>) :: repr a -> repr a -> repr a; infixr 3 <|>
 213   (<|>) = liftDerived2 (<|>)
 214   default (<|>) ::
 215     FromDerived2 AlternativeFunctor repr =>
 216     repr a -> repr a -> repr a
 217
 218 -- * Class 'Dicurryable'
 219 class Dicurryable repr where
 220   dicurry ::
 221     CurryN args =>
 222     proxy args ->
 223     (args-..->a) -> -- construction
 224     (a->Tuples args) -> -- destruction
 225     repr (Tuples args) ->
 226     repr a
 227   dicurry args constr destr = liftDerived1 (dicurry args constr destr)
 228   default dicurry ::
 229     FromDerived1 Dicurryable repr =>
 230     CurryN args =>
 231     proxy args ->
 232     (args-..->a) ->
 233     (a->Tuples args) ->
 234     repr (Tuples args) ->
 235     repr a
 236
 237 construct ::
 238   forall args a repr.
 239   Dicurryable repr =>
 240   Generic a =>
 241   EoTOfRep a =>
 242   CurryN args =>
 243   Tuples args ~ EoT (ADT a) =>
 244   (args ~ Args (args-..->a)) =>
 245   (args-..->a) ->
 246   repr (Tuples args) ->
 247   repr a
 248 construct f = dicurry (Proxy::Proxy args) f eotOfadt
 249
 250 adt ::
 251   forall adt repr.
 252   IsoFunctor repr =>
 253   Generic adt =>
 254   RepOfEoT adt =>
 255   EoTOfRep adt =>
 256   repr (EoT (ADT adt)) ->
 257   repr adt
 258 adt = (<%>) (Iso adtOfeot eotOfadt)
 259
 260 -- * Class 'Monoidable'
 261 class
 262   ( Emptyable repr
 263   , Semigroupable repr
 264   ) => Monoidable repr
 265 instance
 266   ( Emptyable repr
 267   , Semigroupable repr
 268   ) => Monoidable repr
 269
 270 -- ** Class 'Emptyable'
 271 class Emptyable repr where
 272   empty :: repr a
 273   empty = liftDerived empty
 274   default empty ::
 275     FromDerived Emptyable repr =>
 276     repr a
 277
 278 -- ** Class 'Semigroupable'
 279 class Semigroupable repr where
 280   concat :: Semigroup a => repr (a -> a -> a)
 281   concat = liftDerived concat
 282   default concat ::
 283     FromDerived Semigroupable repr =>
 284     Semigroup a =>
 285     repr (a -> a -> a)
 286
 287 infixr 6 `concat`, <>
 288 (<>) ::
 289   Abstractable repr => Semigroupable repr => Semigroup a =>
 290   repr a -> repr a -> repr a
 291 (<>) x y = concat .@ x .@ y
 292
 293 -- ** Class 'Optionable'
 294 class Optionable repr where
 295   option :: repr a -> repr a
 296   optional :: repr a -> repr (Maybe a)
 297   option = liftDerived1 option
 298   optional = liftDerived1 optional
 299   default option ::
 300     FromDerived1 Optionable repr =>
 301     repr a -> repr a
 302   default optional ::
 303     FromDerived1 Optionable repr =>
 304     repr a -> repr (Maybe a)
 305
 306 -- * Class 'Repeatable'
 307 class Repeatable repr where
 308   many0 :: repr a -> repr [a]
 309   many1 :: repr a -> repr [a]
 310   many0 = liftDerived1 many0
 311   many1 = liftDerived1 many1
 312   default many0 ::
 313     FromDerived1 Repeatable repr =>
 314     repr a -> repr [a]
 315   default many1 ::
 316     FromDerived1 Repeatable repr =>
 317     repr a -> repr [a]
 318
 319 -- * Class 'Permutable'
 320 class Permutable repr where
 321   -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
 322   type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
 323   type Permutation repr = Permutation (Derived repr)
 324   permutable :: Permutation repr a -> repr a
 325   perm :: repr a -> Permutation repr a
 326   noPerm :: Permutation repr ()
 327   permWithDefault :: a -> repr a -> Permutation repr a
 328   optionalPerm ::
 329     Eitherable repr => IsoFunctor repr => Permutable repr =>
 330     repr a -> Permutation repr (Maybe a)
 331   optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
 332
 333 (<&>) ::
 334   Permutable repr =>
 335   ProductFunctor (Permutation repr) =>
 336   repr a ->
 337   Permutation repr b ->
 338   Permutation repr (a, b)
 339 x <&> y = perm x <.> y
 340 infixr 4 <&>
 341 {-# INLINE (<&>)  #-}
 342
 343 (<?&>) ::
 344   Eitherable repr =>
 345   IsoFunctor repr =>
 346   Permutable repr =>
 347   ProductFunctor (Permutation repr) =>
 348   repr a ->
 349   Permutation repr b ->
 350   Permutation repr (Maybe a, b)
 351 x <?&> y = optionalPerm x <.> y
 352 infixr 4 <?&>
 353 {-# INLINE (<?&>) #-}
 354
 355 (<*&>) ::
 356   Eitherable repr =>
 357   Repeatable repr =>
 358   IsoFunctor repr =>
 359   Permutable repr =>
 360   ProductFunctor (Permutation repr) =>
 361   repr a ->
 362   Permutation repr b ->
 363   Permutation repr ([a],b)
 364 x <*&> y = permWithDefault [] (many1 x) <.> y
 365 infixr 4 <*&>
 366 {-# INLINE (<*&>) #-}
 367
 368 (<+&>) ::
 369   Eitherable repr =>
 370   Repeatable repr =>
 371   IsoFunctor repr =>
 372   Permutable repr =>
 373   ProductFunctor (Permutation repr) =>
 374   repr a ->
 375   Permutation repr b ->
 376   Permutation repr ([a], b)
 377 x <+&> y = perm (many1 x) <.> y
 378 infixr 4 <+&>
 379 {-# INLINE (<+&>) #-}
 380
 381 -- * Class 'Routable'
 382 class Routable repr where
 383   (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
 384   (<!>) = liftDerived2 (<!>)
 385   default (<!>) ::
 386     FromDerived2 Routable repr =>
 387     repr a -> repr b -> repr (a, b)
 388
 389 -- | Like @(,)@ but @infixr@.
 390 -- Mostly useful for clarity when using 'Routable'.
 391 pattern (:!:) :: a -> b -> (a, b)
 392 pattern a:!:b <- (a, b)
 393   where a:!:b = (a, b)
 394 infixr 4 :!:
 395
 396 -- * Class 'Voidable'
 397 -- | FIXME: this class should likely be removed
 398 class Voidable repr where
 399   void :: a -> repr a -> repr ()
 400   void = liftDerived1 Fun.. void
 401   default void ::
 402     FromDerived1 Voidable repr =>
 403     a -> repr a -> repr ()
 404
 405 -- * Class 'Substractable'
 406 class Substractable repr where
 407   (<->) :: repr a -> repr b -> repr a; infixr 3 <->
 408   (<->) = liftDerived2 (<->)
 409   default (<->) ::
 410     FromDerived2 Substractable repr =>
 411     repr a -> repr b -> repr a