-- ------------------------------------------------------------

{- |
   Module     : Control.Arrow.IOListArrow
   Copyright  : Copyright (C) 2005 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   Implementation of pure list arrows with IO

-}

-- ------------------------------------------------------------

module Control.Arrow.IOListArrow
    ( IOLA(..)
    )
where
import Prelude hiding (id, (.))

import Control.Category

import Control.Arrow
import Control.Arrow.ArrowExc
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Control.Arrow.ArrowNF
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowNavigatableTree

import Control.DeepSeq
import Control.Exception                ( SomeException
                                        , try
                                        )

-- ------------------------------------------------------------

-- | list arrow combined with IO monad

newtype IOLA a b = IOLA { IOLA a b -> a -> IO [b]
runIOLA :: a -> IO [b] }

instance Category IOLA where
    id :: IOLA a a
id                  = (a -> IO [a]) -> IOLA a a
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((a -> IO [a]) -> IOLA a a) -> (a -> IO [a]) -> IOLA a a
forall a b. (a -> b) -> a -> b
$ [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> IO [a]) -> (a -> [a]) -> a -> IO [a]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])

    IOLA b -> IO [c]
g . :: IOLA b c -> IOLA a b -> IOLA a c
. IOLA a -> IO [b]
f     = (a -> IO [c]) -> IOLA a c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((a -> IO [c]) -> IOLA a c) -> (a -> IO [c]) -> IOLA a c
forall a b. (a -> b) -> a -> b
$ \ a
x -> do
                                        [b]
ys <- a -> IO [b]
f a
x
                                        [[c]]
zs <- [IO [c]] -> IO [[c]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO [c]] -> IO [[c]]) -> ([b] -> [IO [c]]) -> [b] -> IO [[c]]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (b -> IO [c]) -> [b] -> [IO [c]]
forall a b. (a -> b) -> [a] -> [b]
map b -> IO [c]
g ([b] -> IO [[c]]) -> [b] -> IO [[c]]
forall a b. (a -> b) -> a -> b
$ [b]
ys
                                        [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[c]] -> [c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[c]]
zs)

instance Arrow IOLA where
    arr :: (b -> c) -> IOLA b c
arr b -> c
f               = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return [b -> c
f b
x]

    first :: IOLA b c -> IOLA (b, d) (c, d)
first (IOLA b -> IO [c]
f)      = ((b, d) -> IO [(c, d)]) -> IOLA (b, d) (c, d)
forall a b. (a -> IO [b]) -> IOLA a b
IOLA (((b, d) -> IO [(c, d)]) -> IOLA (b, d) (c, d))
-> ((b, d) -> IO [(c, d)]) -> IOLA (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \ ~(b
x1, d
x2) -> do
                                                [c]
ys1 <- b -> IO [c]
f b
x1
                                                [(c, d)] -> IO [(c, d)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (c
y1, d
x2) | c
y1 <- [c]
ys1 ]

    -- just for efficiency
    second :: IOLA b c -> IOLA (d, b) (d, c)
second (IOLA b -> IO [c]
g)     = ((d, b) -> IO [(d, c)]) -> IOLA (d, b) (d, c)
forall a b. (a -> IO [b]) -> IOLA a b
IOLA (((d, b) -> IO [(d, c)]) -> IOLA (d, b) (d, c))
-> ((d, b) -> IO [(d, c)]) -> IOLA (d, b) (d, c)
forall a b. (a -> b) -> a -> b
$ \ ~(d
x1, b
x2) -> do
                                                [c]
ys2 <- b -> IO [c]
g b
x2
                                                [(d, c)] -> IO [(d, c)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (d
x1, c
y2) | c
y2 <- [c]
ys2 ]

    -- just for efficiency
    IOLA b -> IO [c]
f *** :: IOLA b c -> IOLA b' c' -> IOLA (b, b') (c, c')
*** IOLA b' -> IO [c']
g   = ((b, b') -> IO [(c, c')]) -> IOLA (b, b') (c, c')
forall a b. (a -> IO [b]) -> IOLA a b
IOLA (((b, b') -> IO [(c, c')]) -> IOLA (b, b') (c, c'))
-> ((b, b') -> IO [(c, c')]) -> IOLA (b, b') (c, c')
forall a b. (a -> b) -> a -> b
$ \ ~(b
x1, b'
x2) -> do
                                                [c]
ys1 <- b -> IO [c]
f b
x1
                                                [c']
ys2 <- b' -> IO [c']
g b'
x2
                                                [(c, c')] -> IO [(c, c')]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (c
y1, c'
y2) | c
y1 <- [c]
ys1, c'
y2 <- [c']
ys2 ]

    -- just for efficiency
    IOLA b -> IO [c]
f &&& :: IOLA b c -> IOLA b c' -> IOLA b (c, c')
&&& IOLA b -> IO [c']
g   = (b -> IO [(c, c')]) -> IOLA b (c, c')
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [(c, c')]) -> IOLA b (c, c'))
-> (b -> IO [(c, c')]) -> IOLA b (c, c')
forall a b. (a -> b) -> a -> b
$ \ b
x -> do
                                        [c]
ys1 <- b -> IO [c]
f b
x
                                        [c']
ys2 <- b -> IO [c']
g b
x
                                        [(c, c')] -> IO [(c, c')]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (c
y1, c'
y2) | c
y1 <- [c]
ys1, c'
y2 <- [c']
ys2 ]


instance ArrowZero IOLA where
    zeroArrow :: IOLA b c
zeroArrow           = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ IO [c] -> b -> IO [c]
forall a b. a -> b -> a
const ([c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return [])


instance ArrowPlus IOLA where
    IOLA b -> IO [c]
f <+> :: IOLA b c -> IOLA b c -> IOLA b c
<+> IOLA b -> IO [c]
g   = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> do
                                        [c]
rs1 <- b -> IO [c]
f b
x
                                        [c]
rs2 <- b -> IO [c]
g b
x
                                        [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
rs1 [c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
++ [c]
rs2)


instance ArrowChoice IOLA where
    left :: IOLA b c -> IOLA (Either b d) (Either c d)
left (IOLA b -> IO [c]
f)       = (Either b d -> IO [Either c d]) -> IOLA (Either b d) (Either c d)
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((Either b d -> IO [Either c d]) -> IOLA (Either b d) (Either c d))
-> (Either b d -> IO [Either c d])
-> IOLA (Either b d) (Either c d)
forall a b. (a -> b) -> a -> b
$ (b -> IO [Either c d])
-> (d -> IO [Either c d]) -> Either b d -> IO [Either c d]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                                   (\ b
x -> b -> IO [c]
f b
x IO [c] -> ([c] -> IO [Either c d]) -> IO [Either c d]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\ [c]
y -> [Either c d] -> IO [Either c d]
forall (m :: * -> *) a. Monad m => a -> m a
return ((c -> Either c d) -> [c] -> [Either c d]
forall a b. (a -> b) -> [a] -> [b]
map c -> Either c d
forall a b. a -> Either a b
Left [c]
y)))
                                   ([Either c d] -> IO [Either c d]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either c d] -> IO [Either c d])
-> (d -> [Either c d]) -> d -> IO [Either c d]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Either c d -> [Either c d] -> [Either c d]
forall a. a -> [a] -> [a]
:[]) (Either c d -> [Either c d])
-> (d -> Either c d) -> d -> [Either c d]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. d -> Either c d
forall a b. b -> Either a b
Right)
    right :: IOLA b c -> IOLA (Either d b) (Either d c)
right (IOLA b -> IO [c]
f)      = (Either d b -> IO [Either d c]) -> IOLA (Either d b) (Either d c)
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((Either d b -> IO [Either d c]) -> IOLA (Either d b) (Either d c))
-> (Either d b -> IO [Either d c])
-> IOLA (Either d b) (Either d c)
forall a b. (a -> b) -> a -> b
$ (d -> IO [Either d c])
-> (b -> IO [Either d c]) -> Either d b -> IO [Either d c]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                                   ([Either d c] -> IO [Either d c]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either d c] -> IO [Either d c])
-> (d -> [Either d c]) -> d -> IO [Either d c]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Either d c -> [Either d c] -> [Either d c]
forall a. a -> [a] -> [a]
:[]) (Either d c -> [Either d c])
-> (d -> Either d c) -> d -> [Either d c]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. d -> Either d c
forall a b. a -> Either a b
Left)
                                   (\ b
x -> b -> IO [c]
f b
x IO [c] -> ([c] -> IO [Either d c]) -> IO [Either d c]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\ [c]
y -> [Either d c] -> IO [Either d c]
forall (m :: * -> *) a. Monad m => a -> m a
return ((c -> Either d c) -> [c] -> [Either d c]
forall a b. (a -> b) -> [a] -> [b]
map c -> Either d c
forall a b. b -> Either a b
Right [c]
y)))

instance ArrowApply IOLA where
    app :: IOLA (IOLA b c, b) c
app                 = ((IOLA b c, b) -> IO [c]) -> IOLA (IOLA b c, b) c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA (((IOLA b c, b) -> IO [c]) -> IOLA (IOLA b c, b) c)
-> ((IOLA b c, b) -> IO [c]) -> IOLA (IOLA b c, b) c
forall a b. (a -> b) -> a -> b
$ \ (IOLA b -> IO [c]
f, b
x) -> b -> IO [c]
f b
x

instance ArrowList IOLA where
    arrL :: (b -> [c]) -> IOLA b c
arrL b -> [c]
f              = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> [c]
f b
x)
    arr2A :: (b -> IOLA c d) -> IOLA (b, c) d
arr2A b -> IOLA c d
f             = ((b, c) -> IO [d]) -> IOLA (b, c) d
forall a b. (a -> IO [b]) -> IOLA a b
IOLA (((b, c) -> IO [d]) -> IOLA (b, c) d)
-> ((b, c) -> IO [d]) -> IOLA (b, c) d
forall a b. (a -> b) -> a -> b
$ \ ~(b
x, c
y) -> IOLA c d -> c -> IO [d]
forall a b. IOLA a b -> a -> IO [b]
runIOLA (b -> IOLA c d
f b
x) c
y
    constA :: c -> IOLA b c
constA c
c            = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ IO [c] -> b -> IO [c]
forall a b. a -> b -> a
const ([c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return [c
c])
    isA :: (b -> Bool) -> IOLA b b
isA b -> Bool
p               = (b -> IO [b]) -> IOLA b b
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [b]) -> IOLA b b) -> (b -> IO [b]) -> IOLA b b
forall a b. (a -> b) -> a -> b
$ \b
x -> [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return (if b -> Bool
p b
x then [b
x] else [])
    IOLA b -> IO [c]
f >>. :: IOLA b c -> ([c] -> [d]) -> IOLA b d
>>. [c] -> [d]
g        = (b -> IO [d]) -> IOLA b d
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [d]) -> IOLA b d) -> (b -> IO [d]) -> IOLA b d
forall a b. (a -> b) -> a -> b
$ \b
x -> do
                                       [c]
ys <- b -> IO [c]
f b
x
                                       [d] -> IO [d]
forall (m :: * -> *) a. Monad m => a -> m a
return ([c] -> [d]
g [c]
ys)


instance ArrowIf IOLA where
    ifA :: IOLA b c -> IOLA b d -> IOLA b d -> IOLA b d
ifA (IOLA b -> IO [c]
p) IOLA b d
ta IOLA b d
ea  = (b -> IO [d]) -> IOLA b d
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [d]) -> IOLA b d) -> (b -> IO [d]) -> IOLA b d
forall a b. (a -> b) -> a -> b
$ \b
x -> do
                                       [c]
res <- b -> IO [c]
p b
x
                                       IOLA b d -> b -> IO [d]
forall a b. IOLA a b -> a -> IO [b]
runIOLA (if [c] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
res then IOLA b d
ea else IOLA b d
ta) b
x
    (IOLA b -> IO [c]
f) orElse :: IOLA b c -> IOLA b c -> IOLA b c
`orElse` IOLA b c
g
                        = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ \b
x -> do
                                       [c]
res <- b -> IO [c]
f b
x
                                       if [c] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
res then IOLA b c -> b -> IO [c]
forall a b. IOLA a b -> a -> IO [b]
runIOLA IOLA b c
g b
x else [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return [c]
res

instance ArrowIO IOLA where
    arrIO :: (b -> IO c) -> IOLA b c
arrIO b -> IO c
cmd           = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ \b
x -> do
                                       c
res <- b -> IO c
cmd b
x
                                       [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return [c
res]

instance ArrowExc IOLA where
    tryA :: IOLA b c -> IOLA b (Either SomeException c)
tryA IOLA b c
f              = (b -> IO [Either SomeException c])
-> IOLA b (Either SomeException c)
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [Either SomeException c])
 -> IOLA b (Either SomeException c))
-> (b -> IO [Either SomeException c])
-> IOLA b (Either SomeException c)
forall a b. (a -> b) -> a -> b
$ \ b
x -> do
                                        Either SomeException [c]
res <- IO [c] -> IO (Either SomeException [c])
forall a. IO a -> IO (Either SomeException a)
try' (IO [c] -> IO (Either SomeException [c]))
-> IO [c] -> IO (Either SomeException [c])
forall a b. (a -> b) -> a -> b
$ IOLA b c -> b -> IO [c]
forall a b. IOLA a b -> a -> IO [b]
runIOLA IOLA b c
f b
x
                                        [Either SomeException c] -> IO [Either SomeException c]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either SomeException c] -> IO [Either SomeException c])
-> [Either SomeException c] -> IO [Either SomeException c]
forall a b. (a -> b) -> a -> b
$
                                          case Either SomeException [c]
res of
                                          Left  SomeException
er -> [SomeException -> Either SomeException c
forall a b. a -> Either a b
Left SomeException
er]
                                          Right [c]
ys -> [c -> Either SomeException c
forall a b. b -> Either a b
Right c
x' | c
x' <- [c]
ys]
        where
        try'            :: IO a -> IO (Either SomeException a)
        try' :: IO a -> IO (Either SomeException a)
try'            = IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try

instance ArrowIOIf IOLA where
    isIOA :: (b -> IO Bool) -> IOLA b b
isIOA b -> IO Bool
p             = (b -> IO [b]) -> IOLA b b
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [b]) -> IOLA b b) -> (b -> IO [b]) -> IOLA b b
forall a b. (a -> b) -> a -> b
$ \b
x -> do
                                       Bool
res <- b -> IO Bool
p b
x
                                       [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
res then [b
x] else [])

instance ArrowTree IOLA

instance ArrowNavigatableTree IOLA

instance ArrowNF IOLA where
    rnfA :: IOLA b c -> IOLA b c
rnfA (IOLA b -> IO [c]
f)       = (b -> IO [c]) -> IOLA b c
forall a b. (a -> IO [b]) -> IOLA a b
IOLA ((b -> IO [c]) -> IOLA b c) -> (b -> IO [c]) -> IOLA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> do
                                        [c]
res <- b -> IO [c]
f b
x
                                        [c]
res [c] -> IO [c] -> IO [c]
forall a b. NFData a => a -> b -> b
`deepseq` [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return [c]
res


instance ArrowWNF IOLA

-- ------------------------------------------------------------