src/Symantic/Univariant/Trans.hs

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