{-# LANGUAGE CPP #-}

#ifndef MIN_VERSION_GLASGOW_HASKELL
#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0
#endif
  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10

#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
#else
{-# LANGUAGE OverlappingInstances #-}
#endif

-- | This module provides a generalized implementation of data types à la carte
-- [1]. It supports (higher-order) functors with 0 or more functorial parameters
-- and additional non-functorial parameters, all with a uniform interface.
--
-- \[1\] W. Swierstra. Data Types à la Carte.
--       /Journal of Functional Programming/, 18(4):423-436, 2008,
--       <http://dx.doi.org/10.1017/S0956796808006758>.
--
-- (This module is preferably used with the GHC extensions @DataKinds@ and
-- @PolyKinds@.)
--
-- = Usage
--
-- Compared to traditional data types à la carte, an extra poly-kinded parameter
-- has been added to ':+:' and to the parameters of ':<:'. Standard data types à
-- la carte is obtained by setting this parameter to @()@. That gives us the
-- following type for 'Inl':
--
-- @`Inl` :: h1 () a -> (h1 `:+:` h2) () a@
--
-- Here, @h1 ()@ and @(h1 `:+:` h2) ()@ are functors.
--
-- By setting the extra parameter to a functor @f :: * -> *@, we obtain this
-- type:
--
-- @`Inl` :: h1 f a -> (h1 `:+:` h2) f a@
--
-- This makes @h1@ and @(h1 `:+:` h2)@ higher-order functors.
--
-- Finally, by setting the parameter to a type-level pair of functors
-- @'(f,g) :: (* -> *, * -> *)@, we obtain this type:
--
-- @`Inl` :: h1 '(f,g) a -> (h1 `:+:` h2) '(f,g) a@
--
-- This makes @h1@ and @(h1 `:+:` h2)@ higher-order bi-functors.
--
-- Alternatively, we can represent all three cases above using heterogeneous
-- lists of functors constructed using @'(,)@ and terminated by @()@:
--
-- @
-- `Inl` :: h1 ()           a -> (h1 `:+:` h2) ()           a  -- functor
-- `Inl` :: h1 '(f,())      a -> (h1 `:+:` h2) '(f,())      a  -- higher-order functor
-- `Inl` :: h1 '(f,'(g,())) a -> (h1 `:+:` h2) '(f,'(g,())) a  -- higher-order bi-functor
-- @
--
-- This view is taken by the classes 'HFunctor' and 'HBifunctor'. An 'HFunctor'
-- takes a parameter of kind @(* -> *, k)@; i.e. it has /at least/ one
-- functorial parameter. A 'HBiFunctor' takes a parameter of kind
-- @(* -> *, (* -> *, k))@; i.e. it has /at least/ two functorial parameters.
--
-- = Aliases for parameter lists
--
-- To avoid ugly types such as @'(f,'(g,()))@, this module exports the synonyms
-- 'Param0', 'Param1', 'Param2', etc. for parameter lists up to size 4. These
-- synonyms allow the module to be used without the @DataKinds@ extension.
--
-- = Extra type parameters
--
-- Recall that an 'HFunctor' takes a parameter of kind @(* -> *, k)@, and an
-- 'HBifunctor' takes a parameter of kind @(* -> *, (* -> *, k))@. Since @k@ is
-- polymorphic, it means that it is possible to add extra parameters in place of
-- @k@.
--
-- For example, a user can define the following type representing addition in
-- some language:
--
-- @
-- data Add fs a where
--   Add :: (`Num` a, pred a) => f a -> f a -> Add (`Param2` f pred) a
--
-- instance `HFunctor` Add where
--   `hfmap` f (Add a b) = Add (f a) (f b)
-- @
--
-- Here, @Add@ has a functorial parameter @f@, and an extra non-functorial
-- parameter @pred@ that provides a constraint for the type @a@.
--
-- An obvious alternative would have been to just make @pred@ a separate
-- parameter to @Add@:
--
-- @
-- data Add pred fs a where
--   Add :: (`Num` a, pred a) => f a -> f a -> Add pred (`Param1` f) a
--
-- instance `HFunctor` (Add pred) where
--   `hfmap` f (Add a b) = Add (f a) (f b)
-- @
--
-- However, this has the disadvantage of being hard to use together with the
-- ':<:' class. For example, we might want to define the following \"smart
-- constructor\" for @Add@:
--
-- @
-- mkAdd :: (`Num` a, pred a, Add pred `:<:` h) => f a -> f a -> h (`Param1` f) a
-- mkAdd a b = `inj` (Add a b)
-- @
--
-- Unfortunately, the above type is ambiguous, because @pred@ is completely
-- free. Assuming that @h@ is a type of the form @(... `:+:` Add `Show` `:+:` ...)@,
-- we would like to infer @(pred ~ `Show`)@, but this would require extra
-- machinery, such as a type family that computes @pred@ from @h@.
--
-- By putting @pred@ in the parameter list, we avoid the above problem. We also
-- get the advantage that the same @pred@ parameter is distributed to all types
-- in a sum constructed using ':+:'. This makes it easier to, for example,
-- change the @pred@ parameter uniformly throughout an expression.

module Data.ALaCarte where



-- | Coproducts
data (h1 :+: h2) fs a
    = Inl (h1 fs a)
    | Inr (h2 fs a)
#if  __GLASGOW_HASKELL__>=708
  deriving (Functor)
#endif

infixr :+:

-- | A constraint @f `:<:` g@ expresses that the signature @f@ is subsumed by
-- @g@, i.e. @f@ can be used to construct elements in @g@.
class sub :<: sup
  where
    inj :: sub fs a -> sup fs a
    prj :: sup fs a -> Maybe (sub fs a)

instance {-# OVERLAPPING #-} (f :<: f)
  where
    inj = id
    prj = Just

instance {-# OVERLAPPING #-} (f :<: (f :+: g))
  where
    inj = Inl
    prj (Inl f) = Just f
    prj _       = Nothing

instance {-# OVERLAPPING #-} (f :<: h) => (f :<: (g :+: h))
  where
    inj = Inr . inj
    prj (Inr h) = prj h
    prj _       = Nothing

-- | Higher-order functors
class HFunctor h
  where
    -- | Higher-order 'fmap'
    hfmap :: (forall b . f b -> g b) -> h '(f,fs) a -> h '(g,fs) a

instance (HFunctor h1, HFunctor h2) => HFunctor (h1 :+: h2)
  where
    hfmap f (Inl i) = Inl (hfmap f i)
    hfmap f (Inr i) = Inr (hfmap f i)

-- | Higher-order bi-functors
class HFunctor h => HBifunctor h
  where
    -- | Higher-order \"bimap\"
    hbimap :: (Functor f, Functor g)
        => (forall b . f b -> g b)
        -> (forall b . i b -> j b)
        -> h '(f,'(i,fs)) a
        -> h '(g,'(j,fs)) a

instance (HBifunctor h1, HBifunctor h2) => HBifunctor (h1 :+: h2)
  where
    hbimap f g (Inl i) = Inl (hbimap f g i)
    hbimap f g (Inr i) = Inr (hbimap f g i)



--------------------------------------------------------------------------------
-- * Parameter lists
--------------------------------------------------------------------------------

-- | Empty parameter list
type Param0 = ()

-- | Singleton parameter list
type Param1 a = '(a,Param0)

-- | Two-element parameter list
type Param2 a b = '(a, Param1 b)

-- | Three-element parameter list
type Param3 a b c = '(a, Param2 b c)

-- | Four-element parameter list
type Param4 a b c d = '(a, Param3 b c d)