{-# LANGUAGE ConstraintKinds #-} -- For type class synonyms {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DefaultSignatures #-} -- For adding LiftDerived* constraints module Symantic.Derive where import Data.Function ((.)) import Data.Kind (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 f = liftDerived . f . 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 f a b = liftDerived (f (derive a) (derive 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 f a b c = liftDerived (f (derive a) (derive b) (derive 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 f a b c d = liftDerived (f (derive a) (derive b) (derive c) (derive 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) )