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

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

instance Category IOLA where
    id                  = IOLA $ return . (:[])

    IOLA g . IOLA f     = IOLA $ \ x -> do
                                        ys <- f x
                                        zs <- sequence . map g $ ys
                                        return (concat zs)

instance Arrow IOLA where
    arr f               = IOLA $ \ x -> return [f x]

    first (IOLA f)      = IOLA $ \ ~(x1, x2) -> do
                                                ys1 <- f x1
                                                return [ (y1, x2) | y1 <- ys1 ]

    -- just for efficiency
    second (IOLA g)     = IOLA $ \ ~(x1, x2) -> do
                                                ys2 <- g x2
                                                return [ (x1, y2) | y2 <- ys2 ]

    -- just for efficiency
    IOLA f *** IOLA g   = IOLA $ \ ~(x1, x2) -> do
                                                ys1 <- f x1
                                                ys2 <- g x2
                                                return [ (y1, y2) | y1 <- ys1, y2 <- ys2 ]

    -- just for efficiency
    IOLA f &&& IOLA g   = IOLA $ \ x -> do
                                        ys1 <- f x
                                        ys2 <- g x
                                        return [ (y1, y2) | y1 <- ys1, y2 <- ys2 ]


instance ArrowZero IOLA where
    zeroArrow           = IOLA $ const (return [])


instance ArrowPlus IOLA where
    IOLA f <+> IOLA g   = IOLA $ \ x -> do
                                        rs1 <- f x
                                        rs2 <- g x
                                        return (rs1 ++ rs2)


instance ArrowChoice IOLA where
    left (IOLA f)       = IOLA $ either
                                   (\ x -> f x >>= (\ y -> return (map Left y)))
                                   (return . (:[]) . Right)
    right (IOLA f)      = IOLA $ either
                                   (return . (:[]) . Left)
                                   (\ x -> f x >>= (\ y -> return (map Right y)))

instance ArrowApply IOLA where
    app                 = IOLA $ \ (IOLA f, x) -> f x

instance ArrowList IOLA where
    arrL f              = IOLA $ \ x -> return (f x)
    arr2A f             = IOLA $ \ ~(x, y) -> runIOLA (f x) y
    constA c            = IOLA $ const (return [c])
    isA p               = IOLA $ \x -> return (if p x then [x] else [])
    IOLA f >>. g        = IOLA $ \x -> do
                                       ys <- f x
                                       return (g ys)


instance ArrowIf IOLA where
    ifA (IOLA p) ta ea  = IOLA $ \x -> do
                                       res <- p x
                                       runIOLA (if null res then ea else ta) x
    (IOLA f) `orElse` g
                        = IOLA $ \x -> do
                                       res <- f x
                                       if null res then runIOLA g x else return res

instance ArrowIO IOLA where
    arrIO cmd           = IOLA $ \x -> do
                                       res <- cmd x
                                       return [res]

instance ArrowExc IOLA where
    tryA f              = IOLA $ \ x -> do
                                        res <- try' $ runIOLA f x
                                        return $
                                          case res of
                                          Left  er -> [Left er]
                                          Right ys -> [Right x' | x' <- ys]
        where
        try'            :: IO a -> IO (Either SomeException a)
        try'            = try

instance ArrowIOIf IOLA where
    isIOA p             = IOLA $ \x -> do
                                       res <- p x
                                       return (if res then [x] else [])

instance ArrowTree IOLA

instance ArrowNavigatableTree IOLA

instance ArrowNF IOLA where
    rnfA (IOLA f)       = IOLA $ \ x -> do
                                        res <- f x
                                        res `deepseq` return res


instance ArrowWNF IOLA

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