src/Symantic/Base/Univariant.hs

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