src/Symantic/Base/Univariant.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 module Symantic.Base.Univariant where
   3
   4 import Data.Function (id, (.))
   5 import Data.Functor.Identity (Identity(..))
   6
   7 -- * Type family 'Unlift'
   8 type family Unlift (repr :: * -> *) :: * -> *
   9 -- * Class 'Unliftable'
  10 class Unliftable repr where
  11   unlift :: repr a -> Unlift repr a
  12 -- * Class 'Liftable'
  13 class Liftable repr where
  14   lift :: Unlift repr a -> repr a
  15   lift1 :: (Unlift repr a -> Unlift repr b) ->
  16            repr a -> repr b
  17   lift2 :: (Unlift repr a -> Unlift repr b -> Unlift repr c) ->
  18            repr a -> repr b -> repr c
  19   lift3 :: (Unlift repr a -> Unlift repr b -> Unlift repr c -> Unlift repr d) ->
  20            repr a -> repr b -> repr c -> repr d
  21   default lift1 ::
  22            Unliftable repr =>
  23            (Unlift repr a -> Unlift repr b) ->
  24            repr a -> repr b
  25   default lift2 ::
  26            Unliftable repr =>
  27            (Unlift repr a -> Unlift repr b -> Unlift repr c) ->
  28            repr a -> repr b -> repr c
  29   default lift3 ::
  30            Unliftable repr =>
  31            (Unlift repr a -> Unlift repr b -> Unlift repr c -> Unlift repr d) ->
  32            repr a -> repr b -> repr c -> repr d
  33   lift1 f = lift . f . unlift
  34   lift2 f a b = lift (f (unlift a) (unlift b))
  35   lift3 f a b c = lift (f (unlift a) (unlift b) (unlift c))
  36   {-# INLINE lift1 #-}
  37   {-# INLINE lift2 #-}
  38   {-# INLINE lift3 #-}
  39
  40 type instance Unlift Identity = Identity
  41 instance Unliftable Identity where
  42   unlift = id
  43 instance Liftable Identity where
  44   lift = id