src/Symantic/Base/Univariant.hs

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