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