{-# LANGUAGE TemplateHaskell #-}
{-| Control.Concatenative brings concatenative combinators in the style of factor
    (see <http://docs.factorcode.org/content/article-dataflow-combinators.html>)
    to haskell in a variety of interfaces, allowing a terse, pointfree style. 
-}
module Control.Concatenative (
    -- * Postfix combinators
    
    -- | These concatenative combinators essentially apply multiple functions to
    --   one or more values before combining all the results using another
    --   function.
    --   Without concatenative combinators:
    --
    -- > \x-> (x+1) + (subtract 1 x)
    --
    --   With concatenative combinators:
    --
    -- > bi (+1) (subtract 1) (+)
    
    bi, tri, biSp, triSp, biAp, triAp, ifte,
    biM, triM, biSpM, triSpM, biApM, triApM,
    biM_, triM_, biApM_, triApM_,
    
    -- * Postfix arrows
    
    -- | The arrow functions '&&.' and '**.' are equivalent to 'bi' and 'biSp'.
    -- Combining here must be done seperately, through the '>>@' function.
    
    (>>@), dup, swap, both,
    (>>.), (&&.), (**.), first, second,
    
    -- * Generalized Datatypes
    
    -- | The Concatenative datatype can be used to cleave, spread, or
    --   apply any number of functions and values. 
    --   Using the 'bi' combinator:
    --
    -- > bi (+1) (subtract 1) (+)
    --
    --   is equivalent to using the '&.' function:
    --
    -- > with ((+1) &. (subtract 1)) (+)
    --
    --   and may be generalized to any number of functions:
    --
    -- > with ((subtract 10) &. (+1) .&. (*50)) enumFromThenTo
    --
    --   '*.' similarly generalizes 'biSp', and 'cl' and 'sp' generalize
    --   their monadic variants. Generic application presents a problem for the
    --   type system, however, and the library resorts to template haskell:
    --
    -- > biAp (+1)
    --
    --   translates to
    --
    -- > $(apN 2) (+1)
    
    Concatenative(..),
    cat, (&.), (.&.), (*.), (.*.),
    catM, clM, cl, spM, sp,
    apN, apM, apM_
    ) where
import Control.Arrow
import Control.Monad
import Language.Haskell.TH

-- Function Interface

-- | Apply both arguments to a and combine the results
bi :: (a -> b) -> (a -> c) -> (b -> c -> d) -> a -> d
bi f g c x = c (f x) (g x)

-- | Apply each of three arguments to a and combine the results
tri :: (a -> b) -> (a -> c) -> (a -> d) -> (b -> c -> d -> e) -> a -> e
tri f g h c x = c (f x) (g x) (h x)

-- | Apply the first argument to a, the second to b, and combine the results
biSp :: (a -> c) -> (b -> d) -> (c -> d -> e) -> a -> b -> e
biSp f g c x y = c (f x) (g y)

-- | Apply the first argument to a, the second to b, and the third to c, combining the results
triSp :: (a -> d) -> (b -> e) -> (c -> f) -> (d -> e -> f -> g) -> a -> b -> c -> g
triSp f g h c x y z = c (f x) (g y) (h z)

-- | Apply a function to two values and combine the results
biAp :: (t -> t1) -> (t1 -> t1 -> t2) -> t -> t -> t2
biAp f c x y = c (f x) (f y)

-- | Apply a function to three values and combine the results
triAp :: (a -> b) -> (b -> b -> b -> c) -> a -> a -> a -> c
triAp f c x y z = c (f x) (f y) (f z)

ifte :: (a -> Bool) -- ^ A predicate
     -> (a -> b)    -- ^ Applied if the predicate yields True
     -> (a -> b)    -- ^ Applied if the predicate yields False
     -> a -> b
ifte test ca cb x =
    if test x then ca x else cb x

-- Monad Utilities

-- | Like 'bi', but functions can return monadic values
biM :: Monad m => (a -> m b) -> (a -> m c) -> (b -> c -> m d) -> a -> m d
biM f g c a = do
    x <- f a
    y <- g a
    c x y

-- | Like 'biM', but throws away the end result
biM_ :: Monad m => (a -> m b) -> (a -> m c) -> a -> m ()
biM_ f g a = f a >> g a >> return ()

-- | Like 'tri', but functions can return monadic values
triM :: Monad m => (a -> m b) -> (a -> m c) -> (a -> m d) -> (b -> c -> d -> m e) -> a -> m e
triM f g l c a = do
    x <- f a
    y <- g a
    z <- l a
    c x y z

-- | Like 'triM', but throws away the end result
triM_ :: Monad m => (a -> m b) -> (a -> m c) -> (a -> m d) -> a -> m ()
triM_ f g l a = f a >> g a >> l a >> return ()

-- | Like 'biSp', but functions can return monadic values
biSpM :: Monad m => (a -> m c) -> (b -> m d) -> (c -> d -> m e) -> a -> b -> m e
biSpM f g c x y = do
    a <- f x
    b <- g y
    c a b

-- | Like 'triSp', but functions can return monadic values
triSpM :: Monad m => (a -> m d) -> (b -> m e) -> (c -> m f) -> (d -> e -> f -> m g) -> a -> b -> c -> m g
triSpM f g h c x y z = do
    a <- f x
    b <- g y
    n <- h z
    c a b n

-- | Like 'biAp', but functions can return monadic values
biApM :: Monad m => (t -> m t1) -> (t1 -> t1 -> m t2) -> t -> t -> m t2
biApM f c x y = do
    a <- f x
    b <- f y
    c a b

-- | Like 'biApM', but throws away the end result
biApM_ :: Monad m => (t -> m t1) -> t -> t -> m ()
biApM_ f x y = f x >> f y >> return ()

-- | Like 'triAp', but functions can return monadic values
triApM :: Monad m => (a -> m b) -> (b -> b -> b -> m c) -> a -> a -> a -> m c
triApM f c x y z = do
    a <- f x
    b <- f y
    n <- f z
    c a b n

-- | Like 'triApM', but throws away the end result
triApM_ :: Monad m => (a -> m b) -> a -> a -> a-> m ()
triApM_ f x y z = f x >> f y >> f z >> return ()

-- Arrow Interface

infixl 3 >>@
infixl 3 &&.
infixl 3 **.
infixl 4 >>.

-- |Left associative version of '&&&'
(&&.) :: Arrow a => a b c -> a b c' -> a b (c, c')
(&&.) = (&&&)

-- |Left associative version of '***'
(**.) :: Arrow a => a b c -> a b' c' -> a (b,b') (c,c')
(**.) = (***)

-- |Left associative version of '>>>'
(>>.) :: Arrow a => a b c -> a c d -> a b d
(>>.) = (>>>)

-- | Combine with a binary function
(>>@) :: Arrow a => a b (x,y) -> (x -> y -> z) -> a b z
a >>@ f = a >>> arr (\(x,y) -> f x y)

-- | Arrow version of 'biAp'
both :: Arrow a => a b c -> a (b,b) (c,c)
both a = first a >>> second a

dup :: Arrow a => a b (b,b)
dup = arr (\x-> (x,x))

swap :: Arrow a => a (x,y) (y,x)
swap = arr (\(x,y) -> (y,x))

-- Datatypes

-- | Concatenative continuation
newtype Concatenative a b c d = Concatenative { with :: (b -> c) -> (a -> d) }

-- | Lifts a function into 'Concatenative'
cat :: (a -> b) -> Concatenative a b c c
cat f = Concatenative (.f)

-- | Construct a 'Concatenative' for cleaving
(.&.) :: Concatenative a b c d -> (a -> e) -> Concatenative a b (e -> c) d
(Concatenative l) .&. f = Concatenative $ \c a-> l (flip c (f a)) a

-- | Lift a function and add it to a 'Concatenative' for cleaving
(&.) :: (a -> b) -> (a -> e) -> Concatenative a b (e -> c) c
f &. g = (cat f) .&. g

-- | Construct a 'Concatenative' for spreading
(.*.) :: Concatenative a b c d -> (e -> f) -> Concatenative e b (f -> c) (a -> d)
(Concatenative l) .*. f = Concatenative $ \c e-> l (flip c (f e))

-- | Lift a function and add it to a 'Concatenative' for spreading
(*.) :: (t -> b) -> (a -> b1) -> Concatenative a b (b1 -> c) (t -> c)
f *. g = (cat f) .*. g

-- | Lift a monadic function to a 'Concatenative'
catM :: Monad m => (a -> m b) -> Concatenative a b (m c) (m c)
catM f = Concatenative $ \c a-> f a >>= c

-- | Construct a 'Concatenative' for spreading monadic functions
clM :: Monad m => Concatenative a b c (m d) -> (a -> m e) -> Concatenative a b (e -> c) (m d)
(Concatenative l) `clM ` f = Concatenative $ \c a-> f a >>= (\x-> l (flip c x) a)

-- | Lift a monadic function and add it to a 'Concatenative' for cleaving
cl :: (Monad m) => (a -> m b) -> (a -> m e) -> Concatenative a b (e -> m d) (m d)
f `cl` g = (catM f) `clM` g

-- | Construct a 'Concatenative' for spreading monadic functions
spM :: Monad m => Concatenative a b c (m d) -> (e -> m f) -> Concatenative e b (f -> c) (a -> m d)
(Concatenative l) `spM` f = Concatenative $ \c e a-> f e >>= \x-> l (flip c x) a 

-- | Lift a monadic function and add it to a 'Concatenative' for spreading
sp :: (Monad m) => (a -> m b) -> (e -> m f) -> Concatenative e b (f -> m d) (a -> m d)
f `sp` g = (catM f) `spM` g

-- | Create a 'Concatenative' for applying a function n times
--
-- > biAp (+1)
--
--   translates to
--
-- > $(apN 2) (+1)
apN :: Int -> Q Exp
apN n = [| \f-> $(apN' n) f |] where
    apN' :: Int -> Q Exp
    apN' n | n > 1 = [| \f-> $(apN' (n-1)) f .*. f |]
           | otherwise = [| cat |]

-- | Create a 'Concatenative' for applying a monadic function n times
--
-- > biApM (+1)
--
--   translates to
--
-- > $(apM 2) (+1)
apM :: Int -> Q Exp
apM n = [| \f-> $(apM' n) f |] where
    apM' :: Int -> Q Exp
    apM' n | n > 1 = [| \f-> $(apM' (n-1)) f `spM` f |]
           | otherwise = [| catM |]

-- | Convenience synonym for 'replicateM_'
apM_ :: Monad m => Int -> m a -> m ()
apM_ = replicateM_