-- For type class synonyms
{-# LANGUAGE ConstraintKinds #-}
-- For Semantic
{-# LANGUAGE DataKinds #-}
-- For adding LiftDerived* constraints
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE PolyKinds #-}

module Symantic.Syntaxes.Derive where

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

-- * Type 'Semantic'

-- | The kind of @sem@(antics) throughout this library.
type Semantic = Type -> Type

-- * Type family 'Derived'

-- | The next 'Semantic' that @(sem)@ derives to.
type family Derived (sem :: Semantic) :: Semantic

-- * Class 'Derivable'

-- | Derive an interpreter to another interpreter
-- determined by the 'Derived' open type family.
-- This is mostly useful when running the interpreter stack,
-- but also when going back from an initial encoding to a final one.
--
-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.
class Derivable sem where
  derive :: sem a -> Derived sem a

-- * Class 'LiftDerived'

-- | Lift the 'Derived' interpreter of an interpreter, to that interpreter.
-- This is mostly useful to give default values to class methods
-- in order to skip their definition for interpreters
-- where 'liftDerived' can already apply the right semantic.
--
-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.
class LiftDerived sem where
  liftDerived :: Derived sem a -> sem a

-- * Class 'LiftDerived1'

-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with a single argument.
class LiftDerived1 sem where
  liftDerived1 ::
    (Derived sem a -> Derived sem b) ->
    sem a ->
    sem b
  liftDerived1 Derived sem a -> Derived sem b
f = Derived sem b -> sem b
forall (sem :: Semantic) a.
LiftDerived sem =>
Derived sem a -> sem a
liftDerived (Derived sem b -> sem b)
-> (sem a -> Derived sem b) -> sem a -> sem b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Derived sem a -> Derived sem b
f (Derived sem a -> Derived sem b)
-> (sem a -> Derived sem a) -> sem a -> Derived sem b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sem a -> Derived sem a
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive
  default liftDerived1 ::
    LiftDerived sem =>
    Derivable sem =>
    (Derived sem a -> Derived sem b) ->
    sem a ->
    sem b

-- * Class 'LiftDerived2'

-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with two arguments.
-- Note that the default instance relies upon 'LiftDerived', not 'LiftDerived1'.
class LiftDerived2 sem where
  liftDerived2 ::
    (Derived sem a -> Derived sem b -> Derived sem c) ->
    sem a ->
    sem b ->
    sem c
  liftDerived2 Derived sem a -> Derived sem b -> Derived sem c
f sem a
a sem b
b = Derived sem c -> sem c
forall (sem :: Semantic) a.
LiftDerived sem =>
Derived sem a -> sem a
liftDerived (Derived sem a -> Derived sem b -> Derived sem c
f (sem a -> Derived sem a
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem a
a) (sem b -> Derived sem b
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem b
b))
  default liftDerived2 ::
    LiftDerived sem =>
    Derivable sem =>
    (Derived sem a -> Derived sem b -> Derived sem c) ->
    sem a ->
    sem b ->
    sem c

-- * Class 'LiftDerived3'

-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.
-- Note that the default instance relies upon 'LiftDerived', not 'LiftDerived2'.
class LiftDerived3 sem where
  liftDerived3 ::
    (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d) ->
    sem a ->
    sem b ->
    sem c ->
    sem d
  liftDerived3 Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d
f sem a
a sem b
b sem c
c = Derived sem d -> sem d
forall (sem :: Semantic) a.
LiftDerived sem =>
Derived sem a -> sem a
liftDerived (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d
f (sem a -> Derived sem a
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem a
a) (sem b -> Derived sem b
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem b
b) (sem c -> Derived sem c
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem c
c))
  default liftDerived3 ::
    LiftDerived sem =>
    Derivable sem =>
    (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d) ->
    sem a ->
    sem b ->
    sem c ->
    sem d

-- * Class 'LiftDerived4'

-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.
-- Note that the default instance relies upon 'LiftDerived', not 'LiftDerived3'.
class LiftDerived4 sem where
  liftDerived4 ::
    (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d -> Derived sem e) ->
    sem a ->
    sem b ->
    sem c ->
    sem d ->
    sem e
  liftDerived4 Derived sem a
-> Derived sem b -> Derived sem c -> Derived sem d -> Derived sem e
f sem a
a sem b
b sem c
c sem d
d = Derived sem e -> sem e
forall (sem :: Semantic) a.
LiftDerived sem =>
Derived sem a -> sem a
liftDerived (Derived sem a
-> Derived sem b -> Derived sem c -> Derived sem d -> Derived sem e
f (sem a -> Derived sem a
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem a
a) (sem b -> Derived sem b
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem b
b) (sem c -> Derived sem c
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem c
c) (sem d -> Derived sem d
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem d
d))
  default liftDerived4 ::
    LiftDerived sem =>
    Derivable sem =>
    (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d -> Derived sem e) ->
    sem a ->
    sem b ->
    sem c ->
    sem d ->
    sem e

-- * Type synonyms @FromDerived*@

-- | Convenient type synonym for using 'liftDerived' on 'Syntax' @(syn)@.
type FromDerived syn sem = (LiftDerived sem, syn (Derived sem))

type FromDerived1 syn sem = (LiftDerived1 sem, syn (Derived sem))
type FromDerived2 syn sem = (LiftDerived2 sem, syn (Derived sem))
type FromDerived3 syn sem = (LiftDerived3 sem, syn (Derived sem))
type FromDerived4 syn sem = (LiftDerived4 sem, syn (Derived sem))