{-# LANGUAGE ExistentialQuantification, FlexibleContexts #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.WithCont
-- Copyright   :  (c) Conal Elliott 2009
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Add continuation
----------------------------------------------------------------------

module Data.WithCont (WithCont(..)) where


import Prelude hiding (zip)

import Control.Arrow
import Control.Applicative

import Data.Zip



-- | Add a continuation.
data WithCont z c = forall a. WC (z a) (a -> c)

-- TODO: generalize the continuation to an arbitrary arrow.

instance Functor (WithCont z) where
  fmap g (WC f k) = WC f (arr k >>> g)

instance Zip z => Zip (WithCont z) where
  WC fa ka `zip` WC fb kb =
    WC (fa `zip` fb) (ka *** kb)

-- TODO: merge unit into Zip

--- Another interface:

class (Functor f, Zip f) => Monoidal f where
  unit :: f ()

instance Monoidal ((->) a) where unit = const ()

instance Zip z => Monoidal (WithCont z) where
  unit = WC (error "unneeded pre-cont") unit


-- Standard Applicative instance for |Monoidal|
instance Zip z => Applicative (WithCont z) where
  pure a    = fmap (const a) unit
  wf <*> wx = app <$> (wf `zip` wx)


--------------------


--   A lazy (~) pattern cannot bind existential type variables
--
-- instance Functor (WithCont z) where
--   fmap g ~(WC f k) = WC f (fmap g k)

--   My brain just exploded.
--   I can't handle pattern bindings for existentially-quantified constructors.
--   Instead, use a case-expression, or do-notation, to unpack the constructor.

-- instance Zip (z) => Applicative (WithCont z) where
--   pure a = WC (error "unneeded pre-cont") (pure a)
--   WC hf hk <*> WC xf xk =
--     WC (hf `zip` xf) (\ (a,a') -> (hk a) (xk a'))

-- instance Functor (WithCont z) where
--   fmap g = \ (WC f k) -> WC f (fmap g k)


-- instance Zip (z) => Applicative (WithCont z) where
--   pure a = WC (error "unneeded pre-cont") (pure a)
--   ~(WC hf hk) <*> ~(WC xf xk) =
--     WC (hf `zip` xf) (\ (a,a') -> (hk a) (xk a'))

-- instance Zip (z) => Applicative (WithCont z) where
--   pure a = WC (error "unneeded pre-cont") (pure a)
--   (<*>) = \ (WC hf hk) (WC xf xk) ->
--     WC (hf `zip` xf) (\ (a,a') -> (hk a) (xk a'))