content: -- ------------------------------------------------------------
  
  {- |
     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
  
  -- ------------------------------------------------------------
  