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