HXQ-0.1: hxml-0.2/Arrow.hs

----------------------------------------------------------------------------
--
-- Module	: HXML.Arrow
-- Copyright	: (C) 2000-2002 Joe English.  Freely redistributable.
-- License	: "MIT-style"
--
-- Author	: Joe English <jenglish@flightlab.com>
-- Stability	: experimental
-- Portability	: portable
--
-- CVS  	: $Id: Arrow.hs,v 1.8 2002/10/12 01:58:56 joe Exp $
--
----------------------------------------------------------------------------
--
-- [30 Jan 1999]
-- Arrow combinator library; inspired by John Hughes'
-- "Generalizing Monads to Arrows"

module Arrow where

import Monad

infixr 5 +++
infixr 3 >&<, &&&
infixr 2 >|<, |||, ?>, >?>, :>
infixl 1 >>>

class Arrow a where
	arr	:: (b -> c) -> a b c
	(>>>)	:: a b c -> a c d -> a b d
	apfst	:: a b c -> a (b,x) (c,x)
	apsnd	:: a b c -> a (x,b) (x,c)
	(>&<)	:: a b c -> a d e -> a (b,d) (c,e)
	(&&&)	:: a b c -> a b d -> a b (c,d)
	liftA2	:: (b -> c -> d) -> a e b -> a e c -> a e d
	aConst	:: c -> a b c
	idArrow	:: a b b
	-- Minimal implementation: arr, >>>,  apfst or >&<

	apsnd f 	= arr swap >>> apfst f >>> arr swap
			  where swap (x,y) = (y,x)
	f >&< g 	= apfst f >>> apsnd g
			-- OR: (arr fst >>> f) &&& (arr snd >>> g)
	f &&& g 	= arr twin >>> (f >&< g)
			  where twin a = (a,a)
	apfst f 	= f >&< arr id
	liftA2 op f g 	= (f &&& g) >>> arr (uncurry op)
	aConst c	= arr (const c)
	idArrow		= arr id
	-- swap 	:: (a,b) -> (b,a)
	-- twin 	:: a -> (a,a)
	-- uncurry 	:: (a -> b -> c) -> (a,b) -> c

data Choice a = a :> a
class (Arrow a) => ArrowChoice a where
	apl	:: a b c -> a (Either b d) (Either c d)
	apr	:: a b c -> a (Either d b) (Either d c)
	(>|<)	:: a b c -> a d e -> a (Either b d) (Either c e)
	(|||)	:: a b c -> a d c -> a (Either b d) c
	( ?>)	:: (b -> Bool) -> Choice (a b c) -> a b c
	(>?>)	:: a b Bool    -> Choice (a b c) -> a b c

	-- Minimal implementation: >|< or apl

	apl f 		= f >|< idArrow
	apr f   	= arr mirror >>> apl f >>> arr mirror
	                  where mirror = either Right Left
	f >|< g 	= apl f >>> apr g
	f ||| g 	= (f >|< g) >>> arr (either id id)

	p >?> (f :> g)	= liftA2 lrtag p idArrow >>> (f ||| g)
			  where  lrtag c = if c then Left else Right
	p  ?> choice	= arr p >?> choice
	-- mirror	:: Either a b -> Either b a
	-- lrtag	:: Bool -> b -> Either b b


class (Arrow a) => ArrowApply a where
	app :: a (a b c,b) c

class (Arrow a) => ArrowZero a where
	aZero  :: a b c
	aMaybe :: a (Maybe c) c
	aGuard :: (b -> Bool) -> a b b

	aGuard p = arr (\x -> if p x then Just x else Nothing) >>> aMaybe

{- Alternate interfaces:
    aMaybe :: (b -> Maybe c) -> a b c
    aMaybe :: a b (Maybe c)  -> a b c
    aGuard :: a b Bool    -> a b b
-}

class (Arrow a) => ArrowPlus a where
	(+++) :: a b c -> a b c -> a b c

{- ************************************************************ -}

{- NOTE: comment this out if NHC98 1.10 gives you problems -}

instance Arrow (->) where
	arr		= id
	f >>> g 	= \x -> g (f x)	-- (>>>) = flip (.)
	apfst f	(x,y)	= (f x, y)
	apsnd g (x,y)	= (x, g y)
	f >&< g		= \(x,y) -> (f x, g y)
	f &&& g   	= \x -> (f x, g x)
	liftA2 op f g x	= op (f x) (g x)
	aConst  	= const

instance ArrowChoice (->) where
	f ||| g     	= either f g
	f >|< g     	= either (Left . f) (Right . g)
	apl f		= either (Left . f)  Right
	apr f     	= either  Left      (Right . f)
	p ?> (f :> g)	= \x -> if p x then f x else g x

instance ArrowApply (->) where
	app (f,x) 	= f x

{- END -}

{- ************************************************************ -}

-- Reader arrow

newtype R a b c = R (a -> b -> c)
instance Arrow (R a) where
    arr 		= R . const		-- arr f = R (\a b -> f b)
    R f >>> R g 	= R (\a -> g a . f a)	-- R (\a b -> g a (f a b))
    apfst (R f) 	= R (\a (x,y) -> (f a x,y))
    apsnd (R f) 	= R (\a (x,y) -> (x,f a y))
    R f >&< R g 	= R (\a (x,y) -> (f a x,g a y))
    R f &&& R g 	= R (\a x     -> (f a x,g a x))
    liftA2 o (R f) (R g)= R (\a x -> o (f a x) (g a x))
    aConst c		= R (\_a _b -> c)

instance ArrowChoice (R a) where
    R f >|< R g		= R (\a -> either (Left . f a) (Right . g a))
    R f ||| R g		= R (\a -> either (f a) (g a))

readR :: (a -> c) -> R a b c
readR f = R (\a _b -> f a)

runR  :: R a b c -> a -> b ->c
runR (R f) = f

{- ************************************************************ -}

-- Monadic arrows (called "Kleisli" arrows in Hughes)

newtype MA m a b = MA (a -> m b)

runMA :: (Monad m) => (MA m a b) -> a -> m b
runMA (MA f) = f

reflectMA :: (Monad m) => (a -> m b) -> MA m a b
reflectMA = MA

aJoin :: (Monad m) => MA m (m a) a
aJoin = reflectMA id

instance (Monad m, Functor m) => Arrow (MA m) where
    arr f 		= MA (return . f)
    MA f >>> MA g	= MA (\b -> f b >>= g)
    MA f >&< MA g	= MA (\(b,d) -> f b >>= \c-> g d >>= \e-> return (c,e))
    MA f &&& MA g	= MA (\b     -> f b >>= \c-> g b >>= \e-> return (c,e))
    apfst (MA f)	= MA (\(b,d) -> f b >>= \c-> return (c,d))
    apsnd (MA g)	= MA (\(b,d) -> g d >>= \e-> return (b,e))
    aConst c		= MA (\_b    -> return c)
    idArrow		= MA return
    liftA2 op (MA f) (MA g)
    			= MA (\x -> f x >>= \l -> fmap (\r -> op l r) (g x))

instance (Monad m, Functor m) => ArrowChoice (MA m) where
    MA f ||| MA g	= MA (either f g)
    MA f >|< MA g	= MA (either (fmap Left . f) (fmap Right . g))
    p ?> (MA f :> MA g) = MA (\x -> if p x then f x else g x)
    apl (MA f) 		= MA (either (fmap Left . f) (return . Right))
    apr (MA g)		= MA (either (return . Left) (fmap Right . g))

instance (Monad m, Functor m) => ArrowApply (MA m) where
    app = MA (\(MA f,x) -> f x)

instance (MonadPlus m, Functor m) => ArrowZero (MA m) where
    aZero   		= MA (const mzero)
    aMaybe  		= MA (maybe mzero return)
    aGuard p 		= MA (\x -> if p x then return x else mzero)

instance (MonadPlus m, Functor m) => ArrowPlus (MA m) where
    MA f +++ MA g	= MA (\x -> mplus (f x) (g x))

{- ************************************************************ -}