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