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