-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Sequence
-- Copyright   :  (c) Ross Paterson 2003
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  ross@soi.city.ac.uk
-- Stability   :  experimental
-- Portability :  portable
--
-- This module describes a structure intermediate between a functor and
-- a monad: it provides pure expressions and sequencing, but no binding.
-- (Technically, a lax monoidal premonad with a weak symmetry condition;
-- if anyone knows the Real Name for these things, please let me know.)
--
-- This interface was introduced for parsers by Niklas R&#xD6;jemo, because
-- it admits more sharing than the monadic interface.  The names here are
-- mostly based on recent parsing work by Doaitse Swierstra.

module Control.Sequence(
		Sequence(..),
		-- * Lifting
		lift1, lift3,
		-- * Application of pure functions
		(<$>), (<$),
		-- * Sequencing
		(<*), (*>), (<**>),
		-- * Alternatives
		Alternative(..),
		-- * Instances
		ArrowSequence(..), MonadSequence(..)
	) where

import Control.Arrow
import Control.Monad

infixl 4 <$>, <$
infixl 4 <*>, <*, *>, <**>

-- | A functor with sequencing.
--
-- Minimal definition: 'lift0' and either 'lift2' or '<*>'.
--
--
-- If the functor is also a monad, define 'lift0' = 'return' and
-- 'lift2' = 'liftM2'.
class Functor f => Sequence f where
	-- | Lift a value
	lift0 :: a -> f a

	-- | Lift a binary function.
	-- 'lift0' and 'lift2' should satisfy
	--
	-- > lift2 f (unit x) v = fmap (\y -> f x y) v
	--
	-- > lift2 f u (unit y) = fmap (\x -> f x y) u
	--
	-- > lift2 f u (lift2 g v w) = lift2 ($) (lift2 (\x y z -> f x (g y z))) u v) w)

	lift2 :: (a -> b -> c) -> f a -> f b -> f c
	lift2 f fa fb = f <$> fa <*> fb

	-- | Sequential application.
	-- This function should satisfy
	--
	-- > lift0 f <*> v = fmap f v
	--
	-- > u <*> lift0 y = fmap ($ y) u
	--
	-- > u <*> (v <*> w) = (fmap (.) u <*> v) <*> w

	(<*>) :: f (a -> b) -> f a -> f b
	p <*> q = lift2 ($) p q

-- | Lift a unary function (a synonym for 'fmap')
lift1 :: Sequence f => (a -> b) -> f a -> f b
lift1 = fmap

-- | Lift a ternary function
lift3 :: Sequence f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
lift3 f fa fb fc = f <$> fa <*> fb <*> fc

-- | Apply a unary function (a synonym for 'fmap')
(<$>) :: Functor f => (a -> b) -> f a -> f b
(<$>) = fmap

-- | Replace the value
(<$) :: Functor f => a -> f b -> f a
(<$) = fmap . const

-- | Sequence, discarding the value of the first argument
(*>) :: Sequence f => f a -> f b -> f b
(*>) = lift2 (const id)

-- | Sequence, discarding the value of the second argument
(<*) :: Sequence f => f a -> f b -> f a
(<*) = lift2 const

-- | A variant of '<*>' with the arguments reversed
(<**>) :: Sequence f => f a -> f (a -> b) -> f b
(<**>) = lift2 (flip ($))

instance Sequence Maybe where
	lift0 = Just
	lift2 f (Just x) (Just y) = Just (f x y)
	lift2 _ _ _ = Nothing

instance Sequence [] where
	lift0 x = [x]
	lift2 f xs ys = [f x y | x <- xs, y <- ys]

instance Sequence IO where
	lift0 = return
	lift2 = liftM2

-- | A monoid on sequences
class Sequence f => Alternative f where
	-- | The identity of '<|>'
	empty :: f a
	-- | An associative binary operation
	(<|>) :: f a -> f a -> f a

newtype ArrowSequence a b c = ArrowSequence { runArrowSequence :: a b c }

instance Arrow a => Functor (ArrowSequence a s) where
	fmap k (ArrowSequence f) = ArrowSequence (f >>> arr k)

instance Arrow a => Sequence (ArrowSequence a s) where
	lift0 x = ArrowSequence (arr (const x))
	lift2 f (ArrowSequence u) (ArrowSequence v) =
		ArrowSequence (u &&& v >>> arr (uncurry f))

instance (ArrowZero a, ArrowPlus a) => Alternative (ArrowSequence a s) where
	empty = ArrowSequence zeroArrow
	ArrowSequence p <|> ArrowSequence q = ArrowSequence (p <+> q)

-- A special case of this is monads:

newtype MonadSequence m a = MonadSequence { runMonadSequence :: m a }

instance Monad m => Functor (MonadSequence m) where
	fmap k (MonadSequence f) = MonadSequence (liftM k f)

instance Monad m => Sequence (MonadSequence m) where
	lift0 x = MonadSequence (return x)
	lift2 f (MonadSequence u) (MonadSequence v) =
		MonadSequence (liftM2 f u v)

instance MonadPlus m => Alternative (MonadSequence m) where
	empty = MonadSequence mzero
	MonadSequence p <|> MonadSequence q = MonadSequence (p `mplus` q)
