Composable.hs

module Symantic.Base.Composable where

import Data.Function ((.))

-- * Class 'Composable'
class Composable repr where
  default (<.>) :: Transformable repr => Composable (UnTrans repr) =>
           repr a b -> repr b c -> repr a c
  (<.>) :: repr a b -> repr b c -> repr a c
  (<.>) = trans2 (<.>)
infixr 4 <.>

-- * Class 'Voidable'
class Voidable repr where
  default void :: Transformable repr => Voidable (UnTrans repr) =>
          a -> repr (a -> b) k -> repr b k
  void :: a -> repr (a -> b) k -> repr b k
  void a = trans1 (void a)

-- * Class 'Transformable'
-- | Used with @DefaultSignatures@ and default methods,
-- in the symantics class definition,
-- it then avoids on an interpreter instance
-- to define unused methods.
class Transformable repr where
  -- | The underlying representation that @(repr)@ transforms.
  type UnTrans repr :: * -> * -> *
  -- | Lift the underlying representation to @(repr)@.
  -- Useful to define a combinator that does nothing 
  -- in a transformation.
  noTrans :: UnTrans repr a b -> repr a b
  -- | Unlift a representation. Useful when a transformation
  -- combinator needs to access the 'UnTrans'formed representation,
  -- or at the end to get the underlying 'UnTrans'formed representation
  -- from the inferred @(repr)@ value.
  unTrans :: repr a b -> UnTrans repr a b
  -- | Convenient helper lifing an unary operator,
  -- but also enables to identify unary operators.
  trans1 :: (UnTrans repr a b -> UnTrans repr c d) -> repr a b -> repr c d
  trans1 f = noTrans . f . unTrans
  -- | Convenient helper lifting a binary operator,
  -- but also enables to identify binary operators.
  trans2 :: (UnTrans repr a b -> UnTrans repr c d -> UnTrans repr e f) -> repr a b -> repr c d -> repr e f
  trans2 f x y = noTrans (f (unTrans x) (unTrans y))

-- ** Type 'IdentityTrans'
-- | A 'Transformable' that does nothing.
newtype IdentityTrans repr a k
 =      IdentityTrans
 {    unIdentityTrans :: repr a k }
instance Transformable (IdentityTrans repr) where
  type UnTrans (IdentityTrans repr) = repr
  noTrans = IdentityTrans
  unTrans = unIdentityTrans

-- * Class 'Dimapable'
class Dimapable repr where
  default dimap :: Transformable repr => Dimapable (UnTrans repr) =>
           (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  dimap a2b b2a = trans1 (dimap a2b b2a)