src/Symantic/Classes.hs

   1 {-# LANGUAGE DataKinds #-} -- For ReprKind
   2 {-# LANGUAGE PatternSynonyms #-} -- For (:!:)
   3 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
   4 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
   5 -- | Combinators 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   optional :: repr a -> repr (Maybe a)
 316   optional = liftDerived1 optional
 317   default optional ::
 318     FromDerived1 Optionable repr =>
 319     repr a -> repr (Maybe a)
 320
 321 -- * Class 'Repeatable'
 322 class Repeatable repr where
 323   many0 :: repr a -> repr [a]
 324   many1 :: repr a -> repr [a]
 325   many0 = liftDerived1 many0
 326   many1 = liftDerived1 many1
 327   default many0 ::
 328     FromDerived1 Repeatable repr =>
 329     repr a -> repr [a]
 330   default many1 ::
 331     FromDerived1 Repeatable repr =>
 332     repr a -> repr [a]
 333
 334 -- | Alias to 'many0'.
 335 many :: Repeatable repr => repr a -> repr [a]
 336 many = many0
 337
 338 -- | Alias to 'many1'.
 339 some :: Repeatable repr => repr a -> repr [a]
 340 some = many1
 341
 342 -- * Class 'Permutable'
 343 class Permutable repr where
 344   -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
 345   type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
 346   type Permutation repr = Permutation (Derived repr)
 347   permutable :: Permutation repr a -> repr a
 348   perm :: repr a -> Permutation repr a
 349   noPerm :: Permutation repr ()
 350   permWithDefault :: a -> repr a -> Permutation repr a
 351   optionalPerm ::
 352     Eitherable repr => IsoFunctor repr => Permutable repr =>
 353     repr a -> Permutation repr (Maybe a)
 354   optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
 355
 356 (<&>) ::
 357   Permutable repr =>
 358   ProductFunctor (Permutation repr) =>
 359   repr a ->
 360   Permutation repr b ->
 361   Permutation repr (a, b)
 362 x <&> y = perm x <.> y
 363 infixr 4 <&>
 364 {-# INLINE (<&>)  #-}
 365
 366 (<?&>) ::
 367   Eitherable repr =>
 368   IsoFunctor repr =>
 369   Permutable repr =>
 370   ProductFunctor (Permutation repr) =>
 371   repr a ->
 372   Permutation repr b ->
 373   Permutation repr (Maybe a, b)
 374 x <?&> y = optionalPerm x <.> y
 375 infixr 4 <?&>
 376 {-# INLINE (<?&>) #-}
 377
 378 (<*&>) ::
 379   Eitherable repr =>
 380   Repeatable repr =>
 381   IsoFunctor repr =>
 382   Permutable repr =>
 383   ProductFunctor (Permutation repr) =>
 384   repr a ->
 385   Permutation repr b ->
 386   Permutation repr ([a],b)
 387 x <*&> y = permWithDefault [] (many1 x) <.> y
 388 infixr 4 <*&>
 389 {-# INLINE (<*&>) #-}
 390
 391 (<+&>) ::
 392   Eitherable repr =>
 393   Repeatable repr =>
 394   IsoFunctor repr =>
 395   Permutable repr =>
 396   ProductFunctor (Permutation repr) =>
 397   repr a ->
 398   Permutation repr b ->
 399   Permutation repr ([a], b)
 400 x <+&> y = perm (many1 x) <.> y
 401 infixr 4 <+&>
 402 {-# INLINE (<+&>) #-}
 403
 404 -- * Class 'Routable'
 405 class Routable repr where
 406   (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
 407   (<!>) = liftDerived2 (<!>)
 408   default (<!>) ::
 409     FromDerived2 Routable repr =>
 410     repr a -> repr b -> repr (a, b)
 411
 412 -- | Like @(,)@ but @infixr@.
 413 -- Mostly useful for clarity when using 'Routable'.
 414 pattern (:!:) :: a -> b -> (a, b)
 415 pattern a:!:b <- (a, b)
 416   where a:!:b = (a, b)
 417 infixr 4 :!:
 418
 419 -- * Class 'Voidable'
 420 class Voidable repr where
 421   -- | Useful to supply @(a)@ to a @(repr)@ consuming @(a)@,
 422   -- for example in the format of a printing interpreter.
 423   void :: a -> repr a -> repr ()
 424   void = liftDerived1 Fun.. void
 425   default void ::
 426     FromDerived1 Voidable repr =>
 427     a -> repr a -> repr ()
 428
 429 -- * Class 'Substractable'
 430 class Substractable repr where
 431   (<->) :: repr a -> repr b -> repr a; infixr 3 <->
 432   (<->) = liftDerived2 (<->)
 433   default (<->) ::
 434     FromDerived2 Substractable repr =>
 435     repr a -> repr b -> repr a