src/Symantic/Dityped/Transformable.hs

   1 {-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
   2 module Symantic.Dityped.Transformable where
   3
   4 import Data.Function ((.))
   5 import Data.Kind (Type)
   6
   7 -- * Class 'Transformable'
   8 -- | Used with @DefaultSignatures@ and default methods,
   9 -- in the symantics class definition,
  10 -- it then avoids on an interpreter instance
  11 -- to define unused methods.
  12 class Transformable from to where
  13   trans :: from a k -> to a k
  14
  15 -- ** Class 'BiTransformable'
  16 -- | Convenient type class synonym.
  17 -- Note that this is not necessarily a bijective 'trans'lation,
  18 -- a 'trans' being not necessarily injective nor surjective.
  19 type BiTransformable from to =
  20   ( Transformable from to
  21   , Transformable to from
  22   )
  23
  24 -- * Class 'Transformable1'
  25 class Transformable1 from to where
  26   -- | Convenient helper lifing an unary operator,
  27   -- but also enables to identify unary operators.
  28   trans1 ::
  29     (from a b -> from c d) ->
  30     to a b -> to c d
  31   trans1 f = trans . f . trans
  32   default trans1 ::
  33     BiTransformable from to =>
  34     (from a b -> from c d) ->
  35     to a b -> to c d
  36
  37 -- * Class 'Transformable2'
  38 class Transformable2 from to where
  39   -- | Convenient helper lifting a binary operator,
  40   -- but also enables to identify binary operators.
  41   trans2 ::
  42     (from a b -> from c d -> from e f) ->
  43     to a b -> to c d -> to e f
  44   trans2 f x y = trans (f (trans x) (trans y))
  45   default trans2 ::
  46     BiTransformable from to =>
  47     (from a b -> from c d -> from e f) ->
  48     to a b -> to c d -> to e f
  49
  50 -- * Class 'Transformable3'
  51 class Transformable3 from to where
  52   trans3 ::
  53     (from a ak -> from b bk -> from c ck -> from d dk) ->
  54     to a ak -> to b bk -> to c ck -> to d dk
  55   trans3 f a b c = trans (f (trans a) (trans b) (trans c))
  56   default trans3 ::
  57     BiTransformable from to =>
  58     (from a ak -> from b bk -> from c ck -> from d dk) ->
  59     to a ak -> to b bk -> to c ck -> to d dk
  60   {-# INLINE trans3 #-}
  61
  62 -- * Type family 'Unlifted'
  63 -- | The underlying representation that @(repr)@ transforms to.
  64 type family Unlifted (repr :: Type -> Type -> Type) :: Type -> Type -> Type
  65
  66 -- ** Class 'Liftable'
  67 -- | Convenient type class synonym for using 'Unlifted'
  68 type Liftable repr = Transformable (Unlifted repr) repr
  69 lift :: forall repr a k. Liftable repr => Unlifted repr a k -> repr a k
  70 lift = trans @(Unlifted repr)
  71 {-# INLINE lift #-}
  72
  73 unlift :: forall repr a k.
  74   Transformable repr (Unlifted repr) =>
  75   repr a k -> Unlifted repr a k
  76 unlift = trans @repr
  77 {-# INLINE unlift #-}
  78
  79 -- ** Class 'Liftable1'
  80 -- | Convenient type class synonym for using 'Unlifted'
  81 type Liftable1 repr = Transformable1 (Unlifted repr) repr
  82 lift1 :: forall repr a ak b bk.
  83   Liftable1 repr =>
  84   (Unlifted repr a ak -> Unlifted repr b bk) ->
  85   repr a ak -> repr b bk
  86 lift1 = trans1 @(Unlifted repr)
  87 {-# INLINE lift1 #-}
  88
  89 -- ** Class 'Liftable2'
  90 -- | Convenient type class synonym for using 'Unlifted'
  91 type Liftable2 repr = Transformable2 (Unlifted repr) repr
  92 lift2 :: forall repr a ak b bk c ck.
  93   Liftable2 repr =>
  94   (Unlifted repr a ak -> Unlifted repr b bk -> Unlifted repr c ck) ->
  95   repr a ak -> repr b bk -> repr c ck
  96 lift2 = trans2 @(Unlifted repr)
  97 {-# INLINE lift2 #-}
  98
  99 -- ** Class 'Liftable3'
 100 -- | Convenient type class synonym for using 'Unlifted'
 101 type Liftable3 repr = Transformable3 (Unlifted repr) repr
 102 lift3 :: forall repr a ak b bk c ck d dk.
 103   Liftable3 repr =>
 104   (Unlifted repr a ak -> Unlifted repr b bk -> Unlifted repr c ck -> Unlifted repr d dk) ->
 105   repr a ak -> repr b bk -> repr c ck -> repr d dk
 106 lift3 = trans3 @(Unlifted repr)
 107 {-# INLINE lift3 #-}