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

{- |
   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 { forall a b. IOLA a b -> a -> IO [b]
runIOLA :: a -> IO [b] }

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

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

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

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

    -- just for efficiency
    second :: forall b c d. IOLA b c -> IOLA (d, b) (d, c)
second (IOLA b -> IO [c]
g)     = forall a b. (a -> IO [b]) -> IOLA a b
IOLA forall a b. (a -> b) -> a -> b
$ \ ~(d
x1, b
x2) -> do
                                                [c]
ys2 <- b -> IO [c]
g b
x2
                                                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 *** :: forall b c b' c'. IOLA b c -> IOLA b' c' -> IOLA (b, b') (c, c')
*** IOLA b' -> IO [c']
g   = forall a b. (a -> IO [b]) -> IOLA a b
IOLA 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
                                                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 &&& :: forall b c c'. IOLA b c -> IOLA b c' -> IOLA b (c, c')
&&& IOLA b -> IO [c']
g   = forall a b. (a -> IO [b]) -> IOLA a b
IOLA 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
                                        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 :: forall b c. IOLA b c
zeroArrow           = forall a b. (a -> IO [b]) -> IOLA a b
IOLA forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return [])


instance ArrowPlus IOLA where
    IOLA b -> IO [c]
f <+> :: forall b c. IOLA b c -> IOLA b c -> IOLA b c
<+> IOLA b -> IO [c]
g   = forall a b. (a -> IO [b]) -> IOLA a b
IOLA 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
                                        forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
rs1 forall a. [a] -> [a] -> [a]
++ [c]
rs2)


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

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


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

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

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

instance ArrowIOIf IOLA where
    isIOA :: forall b. (b -> IO Bool) -> IOLA b b
isIOA b -> IO Bool
p             = forall a b. (a -> IO [b]) -> IOLA a b
IOLA forall a b. (a -> b) -> a -> b
$ \b
x -> do
                                       Bool
res <- b -> IO Bool
p b
x
                                       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 :: forall c b. NFData c => IOLA b c -> IOLA b c
rnfA (IOLA b -> IO [c]
f)       = forall a b. (a -> IO [b]) -> IOLA a b
IOLA forall a b. (a -> b) -> a -> b
$ \ b
x -> do
                                        [c]
res <- b -> IO [c]
f b
x
                                        [c]
res forall a b. NFData a => a -> b -> b
`deepseq` forall (m :: * -> *) a. Monad m => a -> m a
return [c]
res


instance ArrowWNF IOLA

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