module Control.Concatenative (
bi, tri, biSp, triSp, biAp, triAp, ifte,
biM, triM, biSpM, triSpM, biApM, triApM,
biM_, triM_, biApM_, triApM_,
(>>@), dup, swap, both,
(>>.), (&&.), (**.), first, second,
Concatenative(..),
cat, (&.), (.&.), (*.), (.*.),
catM, clM, cl, spM, sp,
apN, apM, apM_
) where
import Control.Arrow
import Control.Monad
import Language.Haskell.TH
bi :: (a -> b) -> (a -> c) -> (b -> c -> d) -> a -> d
bi f g c x = c (f x) (g x)
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)
biSp :: (a -> c) -> (b -> d) -> (c -> d -> e) -> a -> b -> e
biSp f g c x y = c (f x) (g y)
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)
biAp :: (t -> t1) -> (t1 -> t1 -> t2) -> t -> t -> t2
biAp f c x y = c (f x) (f y)
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 -> b)
-> (a -> b)
-> a -> b
ifte test ca cb x =
if test x then ca x else cb x
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
biM_ :: Monad m => (a -> m b) -> (a -> m c) -> a -> m ()
biM_ f g a = f a >> g a >> return ()
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
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 ()
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
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
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
biApM_ :: Monad m => (t -> m t1) -> t -> t -> m ()
biApM_ f x y = f x >> f y >> return ()
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
triApM_ :: Monad m => (a -> m b) -> a -> a -> a-> m ()
triApM_ f x y z = f x >> f y >> f z >> return ()
infixl 3 >>@
infixl 3 &&.
infixl 3 **.
infixl 4 >>.
(&&.) :: Arrow a => a b c -> a b c' -> a b (c, c')
(&&.) = (&&&)
(**.) :: Arrow a => a b c -> a b' c' -> a (b,b') (c,c')
(**.) = (***)
(>>.) :: Arrow a => a b c -> a c d -> a b d
(>>.) = (>>>)
(>>@) :: Arrow a => a b (x,y) -> (x -> y -> z) -> a b z
a >>@ f = a >>> arr (\(x,y) -> f x y)
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))
newtype Concatenative a b c d = Concatenative { with :: (b -> c) -> (a -> d) }
cat :: (a -> b) -> Concatenative a b c c
cat f = Concatenative (.f)
(.&.) :: 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
(&.) :: (a -> b) -> (a -> e) -> Concatenative a b (e -> c) c
f &. g = (cat f) .&. g
(.*.) :: 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))
(*.) :: (t -> b) -> (a -> b1) -> Concatenative a b (b1 -> c) (t -> c)
f *. g = (cat f) .*. g
catM :: Monad m => (a -> m b) -> Concatenative a b (m c) (m c)
catM f = Concatenative $ \c a-> f a >>= c
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)
cl :: (Monad m) => (a -> m b) -> (a -> m e) -> Concatenative a b (e -> m d) (m d)
f `cl` g = (catM f) `clM` g
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
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
apN :: Int -> Q Exp
apN n = [| \f-> $(apN' n) f |] where
apN' :: Int -> Q Exp
apN' n | n > 1 = [| \f-> $(apN' (n1)) f .*. f |]
| otherwise = [| cat |]
apM :: Int -> Q Exp
apM n = [| \f-> $(apM' n) f |] where
apM' :: Int -> Q Exp
apM' n | n > 1 = [| \f-> $(apM' (n1)) f `spM` f |]
| otherwise = [| catM |]
apM_ :: Monad m => Int -> m a -> m ()
apM_ = replicateM_