{-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DefaultSignatures #-} -- For adding Transformable constraints
module Symantic.Typed.Transformable where

import Data.Function ((.))
import Data.Kind (Type)

-- * Type family 'Derived'
-- | The representation that @(repr)@ derives to.
type family Derived (repr :: Type -> Type) :: Type -> Type
type FromDerived  sym repr = ( LiftDerived  repr, sym (Derived repr) )
type FromDerived1 sym repr = ( LiftDerived1 repr, sym (Derived repr) )
type FromDerived2 sym repr = ( LiftDerived2 repr, sym (Derived repr) )
type FromDerived3 sym repr = ( LiftDerived3 repr, sym (Derived repr) )

-- * Class '(:->)'
-- | A translation from an interpreter @(from)@ to an interpreter @(to)@.
class LiftDerived repr where
  liftDerived :: Derived repr a -> repr a

-- * Class '(:<-:)'
-- | 'Derive' and 'LiftDerived' are separate classes
-- because a 'Derive' instance is not always needed/possible,
-- and to avoid overlapping instances
-- that a more polymorphic class with a @(from a -> to a)@ method
-- would make possible.
class Derive repr where
  derive :: repr a -> Derived repr a

-- ** Class 'BiDerivable'
-- | Convenient type class synonym.
-- Note that this is not necessarily a bijective toformation,
-- a 'to' being not necessarily injective nor surjective.
type BiDerivable repr =
  ( LiftDerived repr
  , Derive repr
  )

-- * Class 'LiftDerived1'
class LiftDerived1 repr where
  liftDerived1 ::
    (Derived repr a -> Derived repr b) ->
    repr a -> repr b
  liftDerived1 f = liftDerived . f . derive
  default liftDerived1 ::
    BiDerivable repr =>
    (Derived repr a -> Derived repr b) ->
    repr a -> repr b

-- * Class 'LiftDerived2'
class LiftDerived2 repr where
  liftDerived2 ::
    (Derived repr a -> Derived repr b -> Derived repr c) ->
    repr a -> repr b -> repr c
  liftDerived2 f a b = liftDerived (f (derive a) (derive b))
  default liftDerived2 ::
    BiDerivable repr =>
    (Derived repr a -> Derived repr b -> Derived repr c) ->
    repr a -> repr b -> repr c

-- * Class 'LiftDerived3'
class LiftDerived3 repr where
  liftDerived3 ::
    (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
    repr a -> repr b -> repr c -> repr d
  liftDerived3 f a b c = liftDerived (f (derive a) (derive b) (derive c))
  default liftDerived3 ::
    BiDerivable repr =>
    (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
    repr a -> repr b -> repr c -> repr d

{-
-- * Type 'Any'
-- | 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.
newtype Any repr a = Any { unAny :: repr a }
type instance Derived (Any repr) = repr
instance Transformable (Any repr) repr where
  to = unAny
instance Transformable1 (Any repr) repr
instance Transformable2 (Any repr) repr
instance Transformable3 (Any repr) repr
instance Transformable repr (Any repr) where
  to = Any
instance Transformable1 repr (Any repr)
instance Transformable2 repr (Any repr)
instance Transformable3 repr (Any repr)
-}