src/Symantic/Univariant/Trans.hs

   1 {-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
   2 {-# LANGUAGE PolyKinds #-}
   3 {-# LANGUAGE DefaultSignatures #-} -- For adding Trans* constraints
   4 module Symantic.Univariant.Trans where
   5
   6 -- TODO: move to symantic-univariant
   7
   8 import Data.Function ((.))
   9 import Data.Kind (Type)
  10
  11 -- * Type family 'Output'
  12 type family Output (repr :: Type -> Type) :: Type -> Type
  13
  14 -- * Class 'Trans'
  15 -- | A 'trans'formation from an interpreter @(from)@ to an interpreter @(to)@.
  16 class Trans from to where
  17   trans :: from a -> to a
  18 class MetaTrans some from to where
  19   meta :: some from a -> some to a
  20 {-
  21 newtype Compo some repr a = Compo { getCompo :: some repr a }
  22 type family UnSome s where
  23   UnSome (some m) =
  24 -}
  25
  26 -- * Class 'BiTrans'
  27 -- | Convenient type class synonym.
  28 -- Note that this is not necessarily a bijective 'trans'lation,
  29 -- a 'trans' being not necessarily injective nor surjective.
  30 type BiTrans from to = (Trans from to, Trans to from)
  31
  32 -- ** Class 'Liftable'
  33 -- | Convenient type class synonym for using 'Output'
  34 type Liftable repr = Trans (Output repr) repr
  35 lift :: forall repr a.
  36   Liftable repr =>
  37   Output repr a -> repr a
  38 lift = trans @(Output repr)
  39 {-# INLINE lift #-}
  40
  41 unlift :: forall repr a.
  42   Trans repr (Output repr) =>
  43   repr a -> Output repr a
  44 unlift = trans @repr
  45 {-# INLINE unlift #-}
  46
  47 -- ** Class 'Unliftable'
  48 -- | Convenient type class synonym for using 'Output'
  49 type Unliftable repr = Trans repr (Output repr)
  50
  51 -- * Class 'Trans1'
  52 class Trans1 from to where
  53   trans1 ::
  54     (from a -> from b) ->
  55     to a -> to b
  56   default trans1 ::
  57     BiTrans from to =>
  58     (from a -> from b) ->
  59     to a -> to b
  60   trans1 f = trans . f . trans
  61   {-# INLINE trans1 #-}
  62
  63 -- ** Class 'Liftable1'
  64 -- | Convenient type class synonym for using 'Output'
  65 type Liftable1 repr = Trans1 (Output repr) repr
  66 lift1 :: forall repr a b.
  67   Liftable1 repr =>
  68   (Output repr a -> Output repr b) ->
  69   repr a -> repr b
  70 lift1 = trans1 @(Output repr)
  71 {-# INLINE lift1 #-}
  72
  73 -- * Class 'Trans2'
  74 class Trans2 from to where
  75   trans2 ::
  76     (from a -> from b -> from c) ->
  77     to a -> to b -> to c
  78   default trans2 ::
  79     BiTrans from to =>
  80     (from a -> from b -> from c) ->
  81     to a -> to b -> to c
  82   trans2 f a b = trans (f (trans a) (trans b))
  83   {-# INLINE trans2 #-}
  84
  85 -- ** Class 'Liftable2'
  86 -- | Convenient type class synonym for using 'Output'
  87 type Liftable2 repr = Trans2 (Output repr) repr
  88 lift2 :: forall repr a b c.
  89   Liftable2 repr =>
  90   (Output repr a -> Output repr b -> Output repr c) ->
  91   repr a -> repr b -> repr c
  92 lift2 = trans2 @(Output repr)
  93 {-# INLINE lift2 #-}
  94
  95 -- * Class 'Trans3'
  96 class Trans3 from to where
  97   trans3 ::
  98     (from a -> from b -> from c -> from d) ->
  99     to a -> to b -> to c -> to d
 100   default trans3 ::
 101     BiTrans from to =>
 102     (from a -> from b -> from c -> from d) ->
 103     to a -> to b -> to c -> to d
 104   trans3 f a b c = trans (f (trans a) (trans b) (trans c))
 105   {-# INLINE trans3 #-}
 106
 107 -- ** Class 'Liftable3'
 108 -- | Convenient type class synonym for using 'Output'
 109 type Liftable3 repr = Trans3 (Output repr) repr
 110 lift3 :: forall repr a b c d.
 111   Liftable3 repr =>
 112   (Output repr a -> Output repr b -> Output repr c -> Output repr d) ->
 113   repr a -> repr b -> repr c -> repr d
 114 lift3 = trans3 @(Output repr)
 115 {-# INLINE lift3 #-}
 116
 117 {-
 118 -- * Type 'Any'
 119 -- | A newtype to disambiguate the 'Trans' instance to any other interpreter when there is also one or more 'Trans's to other interpreters with a different interpretation than the generic one.
 120 newtype Any repr a = Any { unAny :: repr a }
 121 type instance Output (Any repr) = repr
 122 instance Trans (Any repr) repr where
 123   trans = unAny
 124 instance Trans1 (Any repr) repr
 125 instance Trans2 (Any repr) repr
 126 instance Trans3 (Any repr) repr
 127 instance Trans repr (Any repr) where
 128   trans = Any
 129 instance Trans1 repr (Any repr)
 130 instance Trans2 repr (Any repr)
 131 instance Trans3 repr (Any repr)
 132 -}