src/Symantic/Typed/Transformable.hs

   1 {-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
   2 {-# LANGUAGE PolyKinds #-}
   3 {-# LANGUAGE DefaultSignatures #-} -- For adding Transformable constraints
   4 module Symantic.Typed.Transformable where
   5
   6 import Data.Function ((.))
   7 import Data.Kind (Type)
   8
   9 -- * Type family 'Derived'
  10 -- | The representation that @(repr)@ derives to.
  11 type family Derived (repr :: Type -> Type) :: Type -> Type
  12 type FromDerived  sym repr = ( LiftDerived  repr, sym (Derived repr) )
  13 type FromDerived1 sym repr = ( LiftDerived1 repr, sym (Derived repr) )
  14 type FromDerived2 sym repr = ( LiftDerived2 repr, sym (Derived repr) )
  15 type FromDerived3 sym repr = ( LiftDerived3 repr, sym (Derived repr) )
  16
  17 -- * Class '(:->)'
  18 -- | A translation from an interpreter @(from)@ to an interpreter @(to)@.
  19 class LiftDerived repr where
  20   liftDerived :: Derived repr a -> repr a
  21
  22 -- * Class '(:<-:)'
  23 -- | 'Derive' and 'LiftDerived' are separate classes
  24 -- because a 'Derive' instance is not always needed/possible,
  25 -- and to avoid overlapping instances
  26 -- that a more polymorphic class with a @(from a -> to a)@ method
  27 -- would make possible.
  28 class Derive repr where
  29   derive :: repr a -> Derived repr a
  30
  31 -- ** Class 'BiDerivable'
  32 -- | Convenient type class synonym.
  33 -- Note that this is not necessarily a bijective toformation,
  34 -- a 'to' being not necessarily injective nor surjective.
  35 type BiDerivable repr =
  36   ( LiftDerived repr
  37   , Derive repr
  38   )
  39
  40 -- * Class 'LiftDerived1'
  41 class LiftDerived1 repr where
  42   liftDerived1 ::
  43     (Derived repr a -> Derived repr b) ->
  44     repr a -> repr b
  45   liftDerived1 f = liftDerived . f . derive
  46   default liftDerived1 ::
  47     BiDerivable repr =>
  48     (Derived repr a -> Derived repr b) ->
  49     repr a -> repr b
  50
  51 -- * Class 'LiftDerived2'
  52 class LiftDerived2 repr where
  53   liftDerived2 ::
  54     (Derived repr a -> Derived repr b -> Derived repr c) ->
  55     repr a -> repr b -> repr c
  56   liftDerived2 f a b = liftDerived (f (derive a) (derive b))
  57   default liftDerived2 ::
  58     BiDerivable repr =>
  59     (Derived repr a -> Derived repr b -> Derived repr c) ->
  60     repr a -> repr b -> repr c
  61
  62 -- * Class 'LiftDerived3'
  63 class LiftDerived3 repr where
  64   liftDerived3 ::
  65     (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
  66     repr a -> repr b -> repr c -> repr d
  67   liftDerived3 f a b c = liftDerived (f (derive a) (derive b) (derive c))
  68   default liftDerived3 ::
  69     BiDerivable repr =>
  70     (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
  71     repr a -> repr b -> repr c -> repr d
  72
  73 {-
  74 -- * Type 'Any'
  75 -- | A newtype to disambiguate the 'Transformable' instance to any other interpreter when there is also one or more 'Transformable's to other interpreters with a different interpretation than the generic one.
  76 newtype Any repr a = Any { unAny :: repr a }
  77 type instance Derived (Any repr) = repr
  78 instance Transformable (Any repr) repr where
  79   to = unAny
  80 instance Transformable1 (Any repr) repr
  81 instance Transformable2 (Any repr) repr
  82 instance Transformable3 (Any repr) repr
  83 instance Transformable repr (Any repr) where
  84   to = Any
  85 instance Transformable1 repr (Any repr)
  86 instance Transformable2 repr (Any repr)
  87 instance Transformable3 repr (Any repr)
  88 -}