----------------------------------------------------------------------------
--
-- Module	: HXML.Filter
-- Copyright	: (C) 2002 Joe English.  Freely redistributable.
-- License	: "MIT-style"
--
-- Author	: Joe English <jenglish@flightlab.com>
-- Stability	: experimental
-- Portability	: portable
--
-- CVS  	: $Id: Filter.hs,v 1.3 2002/10/12 01:58:57 joe Exp $
--
----------------------------------------------------------------------------
--
-- | Filter arrows: @(a -> [b])@
--
-- @Filter a b@ is essentially the same as the Monadic arrow @MA [] a b@,
-- but it uses a different version of the bind operation at certain
-- points to reduce heap drag.
--

module Filter(Filter, runFilter, makeFilter, apFilter, aEach) where

import Arrow

newtype Filter a b = F (a -> [b])

runFilter :: Filter a b -> a -> [b]
runFilter (F f) = f

makeFilter :: (a -> [b]) -> Filter a b
makeFilter = F

apFilter :: ([a] -> [b]) -> Filter c a -> Filter c b
apFilter func filt = makeFilter (func . runFilter filt)

aEach :: Filter [a] a
aEach = makeFilter id

(!>>=)	:: [a] -> (a -> [b]) -> [b]
[]	!>>= _ = []
[x]	!>>= f = f x
(x:xs)  !>>= f = f x ++ (xs !>>= f)

wrap :: a -> [a]
wrap x = [x]

instance Arrow Filter where
    arr f		= F $ wrap . f
    F f >>> F g 	= F $ concatMap g . f
    F f >&< F g 	= F $ \(b,d) -> f b !>>= \c-> g d !>>= \e-> [(c,e)]
    F f &&& F g 	= F $ \b     -> f b !>>= \c-> g b !>>= \e-> [(c,e)]
    apfst (F f) 	= F $ \(b,d) -> f b !>>= \c-> [(c,d)]
    apsnd (F g) 	= F $ \(b,d) -> g d !>>= \e-> [(b,e)]
    aConst c		= F $ const [c]
    idArrow		= F wrap
    liftA2 h (F f) (F g)= F $ \x -> f x !>>= \l -> map (h l) (g x)

instance ArrowChoice Filter where
    F f ||| F g 	= F $ either f g
    F f >|< F g 	= F $ either (map Left . f) (map Right . g)
    apl (F f) 		= F $ either (map Left . f) (wrap . Right)
    apr (F g)		= F $ either (wrap . Left)  (map Right . g)
    p    ?> (F f :> F g)= F $ \x -> if p x then f x else g x
    F p >?> (F f :> F g)= F $ \x -> p x !>>= \c -> if c then f x else g x

instance ArrowZero Filter where
    aZero   		= F (const [])
    aMaybe  		= F (maybe [] wrap)
    aGuard p 		= F (\x -> if p x then [x] else [])

instance ArrowPlus Filter where
    F f +++ F g		= F (\x -> f x ++ g x)

{- Alternate implementation:
    type Filter a b	= MA [] a b
    runFilter		= runMA
    makeFilter		= reflectMA
    aEach		= aJoin
-}

-- EOF --