1-- ------------------------------------------------------------ 2 3{- | 4 Module : Control.Arrow.IOListArrow 5 Copyright : Copyright (C) 2005 Uwe Schmidt 6 License : MIT 7 8 Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) 9 Stability : experimental 10 Portability: portable 11 12 Implementation of pure list arrows with IO 13 14-} 15 16-- ------------------------------------------------------------ 17 18module Control.Arrow.IOListArrow 19 ( IOLA(..) 20 ) 21where 22import Prelude hiding (id, (.)) 23 24import Control.Category 25 26import Control.Arrow 27import Control.Arrow.ArrowExc 28import Control.Arrow.ArrowIf 29import Control.Arrow.ArrowIO 30import Control.Arrow.ArrowList 31import Control.Arrow.ArrowNF 32import Control.Arrow.ArrowTree 33import Control.Arrow.ArrowNavigatableTree 34 35import Control.DeepSeq 36import Control.Exception ( SomeException 37 , try 38 ) 39 40-- ------------------------------------------------------------ 41 42-- | list arrow combined with IO monad 43 44newtype IOLA a b = IOLA { runIOLA :: a -> IO [b] } 45 46instance Category IOLA where 47 id = IOLA $ return . (:[]) 48 49 IOLA g . IOLA f = IOLA $ \ x -> do 50 ys <- f x 51 zs <- sequence . map g $ ys 52 return (concat zs) 53 54instance Arrow IOLA where 55 arr f = IOLA $ \ x -> return [f x] 56 57 first (IOLA f) = IOLA $ \ ~(x1, x2) -> do 58 ys1 <- f x1 59 return [ (y1, x2) | y1 <- ys1 ] 60 61 -- just for efficiency 62 second (IOLA g) = IOLA $ \ ~(x1, x2) -> do 63 ys2 <- g x2 64 return [ (x1, y2) | y2 <- ys2 ] 65 66 -- just for efficiency 67 IOLA f *** IOLA g = IOLA $ \ ~(x1, x2) -> do 68 ys1 <- f x1 69 ys2 <- g x2 70 return [ (y1, y2) | y1 <- ys1, y2 <- ys2 ] 71 72 -- just for efficiency 73 IOLA f &&& IOLA g = IOLA $ \ x -> do 74 ys1 <- f x 75 ys2 <- g x 76 return [ (y1, y2) | y1 <- ys1, y2 <- ys2 ] 77 78 79instance ArrowZero IOLA where 80 zeroArrow = IOLA $ const (return []) 81 82 83instance ArrowPlus IOLA where 84 IOLA f <+> IOLA g = IOLA $ \ x -> do 85 rs1 <- f x 86 rs2 <- g x 87 return (rs1 ++ rs2) 88 89 90instance ArrowChoice IOLA where 91 left (IOLA f) = IOLA $ either 92 (\ x -> f x >>= (\ y -> return (map Left y))) 93 (return . (:[]) . Right) 94 right (IOLA f) = IOLA $ either 95 (return . (:[]) . Left) 96 (\ x -> f x >>= (\ y -> return (map Right y))) 97 98instance ArrowApply IOLA where 99 app = IOLA $ \ (IOLA f, x) -> f x 100 101instance ArrowList IOLA where 102 arrL f = IOLA $ \ x -> return (f x) 103 arr2A f = IOLA $ \ ~(x, y) -> runIOLA (f x) y 104 constA c = IOLA $ const (return [c]) 105 isA p = IOLA $ \x -> return (if p x then [x] else []) 106 IOLA f >>. g = IOLA $ \x -> do 107 ys <- f x 108 return (g ys) 109 110 111instance ArrowIf IOLA where 112 ifA (IOLA p) ta ea = IOLA $ \x -> do 113 res <- p x 114 runIOLA (if null res then ea else ta) x 115 (IOLA f) `orElse` g 116 = IOLA $ \x -> do 117 res <- f x 118 if null res then runIOLA g x else return res 119 120instance ArrowIO IOLA where 121 arrIO cmd = IOLA $ \x -> do 122 res <- cmd x 123 return [res] 124 125instance ArrowExc IOLA where 126 tryA f = IOLA $ \ x -> do 127 res <- try' $ runIOLA f x 128 return $ 129 case res of 130 Left er -> [Left er] 131 Right ys -> [Right x' | x' <- ys] 132 where 133 try' :: IO a -> IO (Either SomeException a) 134 try' = try 135 136instance ArrowIOIf IOLA where 137 isIOA p = IOLA $ \x -> do 138 res <- p x 139 return (if res then [x] else []) 140 141instance ArrowTree IOLA 142 143instance ArrowNavigatableTree IOLA 144 145instance ArrowNF IOLA where 146 rnfA (IOLA f) = IOLA $ \ x -> do 147 res <- f x 148 res `deepseq` return res 149 150 151instance ArrowWNF IOLA 152 153-- ------------------------------------------------------------ 154