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 (==) ::
 129   Abstractable repr => Equalable repr => Eq a =>
 130   repr a -> repr a -> repr Bool
 131 (==) x y = equal .@ x .@ y
 132
 133 -- * Class 'IfThenElseable'
 134 class IfThenElseable repr where
 135   ifThenElse :: repr Bool -> repr a -> repr a -> repr a
 136   ifThenElse = liftDerived3 ifThenElse
 137   default ifThenElse ::
 138     FromDerived3 IfThenElseable repr =>
 139     repr Bool -> repr a -> repr a -> repr a
 140
 141 -- * Class 'Listable'
 142 class Listable repr where
 143   cons :: repr (a -> [a] -> [a])
 144   nil :: repr [a]
 145   cons = liftDerived cons
 146   nil = liftDerived nil
 147   default cons ::
 148     FromDerived Listable repr =>
 149     repr (a -> [a] -> [a])
 150   default nil ::
 151     FromDerived Listable repr =>
 152     repr [a]
 153
 154 -- * Class 'Maybeable'
 155 class Maybeable repr where
 156   nothing :: repr (Maybe a)
 157   just :: repr (a -> Maybe a)
 158   nothing = liftDerived nothing
 159   just = liftDerived just
 160   default nothing ::
 161     FromDerived Maybeable repr =>
 162     repr (Maybe a)
 163   default just ::
 164     FromDerived Maybeable repr =>
 165     repr (a -> Maybe a)
 166
 167 -- * Class 'IsoFunctor'
 168 class IsoFunctor repr where
 169   (<%>) :: Iso a b -> repr a -> repr b; infixl 4 <%>
 170   (<%>) iso = liftDerived1 (iso <%>)
 171   default (<%>) ::
 172     FromDerived1 IsoFunctor repr =>
 173     Iso a b -> repr a -> repr b
 174
 175 -- ** Type 'Iso'
 176 data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
 177 instance Cat.Category Iso where
 178   id = Iso Cat.id Cat.id
 179   f . g = Iso (a2b f Cat.. a2b g) (b2a g Cat.. b2a f)
 180
 181 -- * Class 'ProductFunctor'
 182 -- | Beware that this is an @infixr@,
 183 -- not @infixl@ like to 'Control.Applicative.<*>';
 184 -- this is to follow what is expected by 'ADT'.
 185 class ProductFunctor repr where
 186   (<.>) :: repr a -> repr b -> repr (a, b); infixr 4 <.>
 187   (<.>) = liftDerived2 (<.>)
 188   default (<.>) ::
 189     FromDerived2 ProductFunctor repr =>
 190     repr a -> repr b -> repr (a, b)
 191   (<.) :: repr a -> repr () -> repr a; infixr 4 <.
 192   ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
 193   default (<.) :: IsoFunctor repr => repr a -> repr () -> repr a
 194   (.>) :: repr () -> repr a -> repr a; infixr 4 .>
 195   ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
 196   default (.>) :: IsoFunctor repr => repr () -> repr a -> repr a
 197
 198 -- * Class 'SumFunctor'
 199 -- | Beware that this is an @infixr@,
 200 -- not @infixl@ like to 'Control.Applicative.<|>';
 201 -- this is to follow what is expected by 'ADT'.
 202 class SumFunctor repr where
 203   (<+>) :: repr a -> repr b -> repr (Either a b); infixr 3 <+>
 204   (<+>) = liftDerived2 (<+>)
 205   default (<+>) ::
 206     FromDerived2 SumFunctor repr =>
 207     repr a -> repr b -> repr (Either a b)
 208
 209 -- * Class 'AlternativeFunctor'
 210 -- | Beware that this is an @infixr@,
 211 -- not @infixl@ like to 'Control.Applicative.<|>';
 212 -- this is to follow what is expected by 'ADT'.
 213 class AlternativeFunctor repr where
 214   (<|>) :: repr a -> repr a -> repr a; infixr 3 <|>
 215   (<|>) = liftDerived2 (<|>)
 216   default (<|>) ::
 217     FromDerived2 AlternativeFunctor repr =>
 218     repr a -> repr a -> repr a
 219
 220 -- * Class 'Dicurryable'
 221 class Dicurryable repr where
 222   dicurry ::
 223     CurryN args =>
 224     proxy args ->
 225     (args-..->a) -> -- construction
 226     (a->Tuples args) -> -- destruction
 227     repr (Tuples args) ->
 228     repr a
 229   dicurry args constr destr = liftDerived1 (dicurry args constr destr)
 230   default dicurry ::
 231     FromDerived1 Dicurryable repr =>
 232     CurryN args =>
 233     proxy args ->
 234     (args-..->a) ->
 235     (a->Tuples args) ->
 236     repr (Tuples args) ->
 237     repr a
 238
 239 construct ::
 240   forall args a repr.
 241   Dicurryable repr =>
 242   Generic a =>
 243   EoTOfRep a =>
 244   CurryN args =>
 245   Tuples args ~ EoT (ADT a) =>
 246   (args ~ Args (args-..->a)) =>
 247   (args-..->a) ->
 248   repr (Tuples args) ->
 249   repr a
 250 construct f = dicurry (Proxy::Proxy args) f eotOfadt
 251
 252 adt ::
 253   forall adt repr.
 254   IsoFunctor repr =>
 255   Generic adt =>
 256   RepOfEoT adt =>
 257   EoTOfRep adt =>
 258   repr (EoT (ADT adt)) ->
 259   repr adt
 260 adt = (<%>) (Iso adtOfeot eotOfadt)
 261
 262 -- * Class 'Monoidable'
 263 class
 264   ( Emptyable repr
 265   , Semigroupable repr
 266   ) => Monoidable repr
 267 instance
 268   ( Emptyable repr
 269   , Semigroupable repr
 270   ) => Monoidable repr
 271
 272 -- ** Class 'Emptyable'
 273 class Emptyable repr where
 274   empty :: repr a
 275   empty = liftDerived empty
 276   default empty ::
 277     FromDerived Emptyable repr =>
 278     repr a
 279
 280 -- ** Class 'Semigroupable'
 281 class Semigroupable repr where
 282   concat :: Semigroup a => repr (a -> a -> a)
 283   concat = liftDerived concat
 284   default concat ::
 285     FromDerived Semigroupable repr =>
 286     Semigroup a =>
 287     repr (a -> a -> a)
 288
 289 infixr 6 `concat`, <>
 290 (<>) ::
 291   Abstractable repr => Semigroupable repr => Semigroup a =>
 292   repr a -> repr a -> repr a
 293 (<>) x y = concat .@ x .@ y
 294
 295 -- ** Class 'Optionable'
 296 class Optionable repr where
 297   option :: repr a -> repr a
 298   optional :: repr a -> repr (Maybe a)
 299   option = liftDerived1 option
 300   optional = liftDerived1 optional
 301   default option ::
 302     FromDerived1 Optionable repr =>
 303     repr a -> repr a
 304   default optional ::
 305     FromDerived1 Optionable repr =>
 306     repr a -> repr (Maybe a)
 307
 308 -- * Class 'Repeatable'
 309 class Repeatable repr where
 310   many0 :: repr a -> repr [a]
 311   many1 :: repr a -> repr [a]
 312   many0 = liftDerived1 many0
 313   many1 = liftDerived1 many1
 314   default many0 ::
 315     FromDerived1 Repeatable repr =>
 316     repr a -> repr [a]
 317   default many1 ::
 318     FromDerived1 Repeatable repr =>
 319     repr a -> repr [a]
 320
 321 -- * Class 'Permutable'
 322 class Permutable repr where
 323   -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
 324   type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
 325   type Permutation repr = Permutation (Derived repr)
 326   permutable :: Permutation repr a -> repr a
 327   perm :: repr a -> Permutation repr a
 328   noPerm :: Permutation repr ()
 329   permWithDefault :: a -> repr a -> Permutation repr a
 330   optionalPerm ::
 331     Eitherable repr => IsoFunctor repr => Permutable repr =>
 332     repr a -> Permutation repr (Maybe a)
 333   optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
 334
 335 (<&>) ::
 336   Permutable repr =>
 337   ProductFunctor (Permutation repr) =>
 338   repr a ->
 339   Permutation repr b ->
 340   Permutation repr (a, b)
 341 x <&> y = perm x <.> y
 342 infixr 4 <&>
 343 {-# INLINE (<&>)  #-}
 344
 345 (<?&>) ::
 346   Eitherable repr =>
 347   IsoFunctor repr =>
 348   Permutable repr =>
 349   ProductFunctor (Permutation repr) =>
 350   repr a ->
 351   Permutation repr b ->
 352   Permutation repr (Maybe a, b)
 353 x <?&> y = optionalPerm x <.> y
 354 infixr 4 <?&>
 355 {-# INLINE (<?&>) #-}
 356
 357 (<*&>) ::
 358   Eitherable repr =>
 359   Repeatable repr =>
 360   IsoFunctor repr =>
 361   Permutable repr =>
 362   ProductFunctor (Permutation repr) =>
 363   repr a ->
 364   Permutation repr b ->
 365   Permutation repr ([a],b)
 366 x <*&> y = permWithDefault [] (many1 x) <.> y
 367 infixr 4 <*&>
 368 {-# INLINE (<*&>) #-}
 369
 370 (<+&>) ::
 371   Eitherable repr =>
 372   Repeatable repr =>
 373   IsoFunctor repr =>
 374   Permutable repr =>
 375   ProductFunctor (Permutation repr) =>
 376   repr a ->
 377   Permutation repr b ->
 378   Permutation repr ([a], b)
 379 x <+&> y = perm (many1 x) <.> y
 380 infixr 4 <+&>
 381 {-# INLINE (<+&>) #-}
 382
 383 -- * Class 'Routable'
 384 class Routable repr where
 385   (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
 386   (<!>) = liftDerived2 (<!>)
 387   default (<!>) ::
 388     FromDerived2 Routable repr =>
 389     repr a -> repr b -> repr (a, b)
 390
 391 -- | Like @(,)@ but @infixr@.
 392 -- Mostly useful for clarity when using 'Routable'.
 393 pattern (:!:) :: a -> b -> (a, b)
 394 pattern a:!:b <- (a, b)
 395   where a:!:b = (a, b)
 396 infixr 4 :!:
 397
 398 -- * Class 'Voidable'
 399 -- | FIXME: this class should likely be removed
 400 class Voidable repr where
 401   void :: a -> repr a -> repr ()
 402   void = liftDerived1 Fun.. void
 403   default void ::
 404     FromDerived1 Voidable repr =>
 405     a -> repr a -> repr ()
 406
 407 -- * Class 'Substractable'
 408 class Substractable repr where
 409   (<->) :: repr a -> repr b -> repr a; infixr 3 <->
 410   (<->) = liftDerived2 (<->)
 411   default (<->) ::
 412     FromDerived2 Substractable repr =>
 413     repr a -> repr b -> repr a