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