src/Symantic/Derive.hs

   1 {-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
   2 {-# LANGUAGE PolyKinds #-}
   3 {-# LANGUAGE DefaultSignatures #-} -- For adding LiftDerived* constraints
   4 module Symantic.Derive 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
  13 -- * Class 'Derivable'
  14 -- | Derivable an interpreter to a another interpreter
  15 -- determined by the 'Derived' open type family.
  16 -- This is mostly useful when running the interpreter stack,
  17 -- but also when going back from an initial encoding to a final one.
  18 --
  19 -- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.
  20 class Derivable repr where
  21   derive :: repr a -> Derived repr a
  22
  23 -- * Class 'LiftDerived'
  24 -- | Lift the 'Derived' interpreter of an interpreter, to that interpreter.
  25 -- This is mostly useful to give default values to class methods
  26 -- in order to skip their definition for interpreters
  27 -- where 'liftDerived' can already apply the right semantic.
  28 --
  29 -- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.
  30 class LiftDerived repr where
  31   liftDerived :: Derived repr a -> repr a
  32
  33 -- * Class 'LiftDerived1'
  34 -- | Convenient wrapper of 'derive' and 'liftDerived' for functions with a single argument.
  35 class LiftDerived1 repr where
  36   liftDerived1 ::
  37     (Derived repr a -> Derived repr b) ->
  38     repr a -> repr b
  39   liftDerived1 f = liftDerived . f . derive
  40   default liftDerived1 ::
  41     LiftDerived repr => Derivable repr =>
  42     (Derived repr a -> Derived repr b) ->
  43     repr a -> repr b
  44
  45 -- * Class 'LiftDerived2'
  46 -- | Convenient wrapper of 'derive' and 'liftDerived' for functions with two arguments.
  47 class LiftDerived2 repr where
  48   liftDerived2 ::
  49     (Derived repr a -> Derived repr b -> Derived repr c) ->
  50     repr a -> repr b -> repr c
  51   liftDerived2 f a b = liftDerived (f (derive a) (derive b))
  52   default liftDerived2 ::
  53     LiftDerived repr => Derivable repr =>
  54     (Derived repr a -> Derived repr b -> Derived repr c) ->
  55     repr a -> repr b -> repr c
  56
  57 -- * Class 'LiftDerived3'
  58 -- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.
  59 class LiftDerived3 repr where
  60   liftDerived3 ::
  61     (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
  62     repr a -> repr b -> repr c -> repr d
  63   liftDerived3 f a b c = liftDerived (f (derive a) (derive b) (derive c))
  64   default liftDerived3 ::
  65     LiftDerived repr => Derivable repr =>
  66     (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
  67     repr a -> repr b -> repr c -> repr d
  68
  69 -- * Class 'LiftDerived4'
  70 -- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.
  71 class LiftDerived4 repr where
  72   liftDerived4 ::
  73     (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d -> Derived repr e) ->
  74     repr a -> repr b -> repr c -> repr d -> repr e
  75   liftDerived4 f a b c d = liftDerived (f (derive a) (derive b) (derive c) (derive d))
  76   default liftDerived4 ::
  77     LiftDerived repr => Derivable repr =>
  78     (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d -> Derived repr e) ->
  79     repr a -> repr b -> repr c -> repr d -> repr e
  80
  81 -- * Type synonyms @FromDerived*@
  82 -- | Convenient type synonym for using 'liftDerived' on symantic class @(sym)@.
  83 type FromDerived  sym repr = ( LiftDerived  repr, sym (Derived repr) )
  84 type FromDerived1 sym repr = ( LiftDerived1 repr, sym (Derived repr) )
  85 type FromDerived2 sym repr = ( LiftDerived2 repr, sym (Derived repr) )
  86 type FromDerived3 sym repr = ( LiftDerived3 repr, sym (Derived repr) )
  87 type FromDerived4 sym repr = ( LiftDerived4 repr, sym (Derived repr) )