2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[MainMonad]{I/O monad used in @Main@ module of the compiler}
7 #include "HsVersions.h"
11 #ifndef __GLASGOW_HASKELL__
18 -- foldlMn, INLINEd at its two (important) uses...
24 #if __GLASGOW_HASKELL__ >= 23
25 fopen, fclose, fwrite, _FILE(..),
29 IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO)
30 IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO)
31 IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO)
32 IF_ATTACK_PRAGMAS(COMMA readChanPrimIO)
33 IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really
36 #ifdef __GLASGOW_HASKELL__
38 # if __GLASGOW_HASKELL__ < 26
49 infixr 9 `thenMn` -- right-associative, please
53 For Glasgow Haskell, we'll eventually be able to use the underlying
54 Glasgow I/O {\em directly}. However, for now we do the business
55 through regular a @Dialogue@.
57 A value of type @MainIO a@ represents an I/O-performing computation
58 returning a value of type @a@. It is a function from the whole list
59 of responses-to-the-rest-of-the-program, to a triple consisting of:
62 the value of type @a@;
64 a function which prefixes the requests for the computation to
65 the front of a supplied list of requests; using a function here
66 avoids an expensive append operation in @thenMn@;
68 the depleted list of responses.
72 returnMn :: a -> MainIO a
73 thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
74 thenMn_ :: MainIO a -> MainIO b -> MainIO b
75 --foldlMn :: (a -> b -> MainIO a) -> a -> [b] -> MainIO a
77 readMn :: String{-channel-} -> MainIO String
78 writeMn :: String{-channel-} -> String -> MainIO ()
79 #ifndef __GLASGOW_HASKELL__
80 appendFileMn:: String{-filename-} -> String -> MainIO ()
82 getArgsMn :: MainIO [String]
83 getSplitUniqSupplyMn :: Char -> MainIO SplitUniqSupply
84 exitMn :: Int -> MainIO ()
86 #ifdef __GLASGOW_HASKELL__
87 {-# INLINE returnMn #-}
89 {-# INLINE thenMn_ #-}
92 {- INLINEd at its uses
93 foldlMn f z [] = returnMn z
94 foldlMn f z (x:xs) = f z x `thenMn` \ zz ->
99 = -- trace ("exitMn:"++(show val)) (
101 then error "Compilation had errors\n"
105 #ifdef __GLASGOW_HASKELL__
107 type MainIO a = PrimIO a
109 returnMn = returnPrimIO
113 readMn chan = readChanPrimIO chan
114 writeMn chan str = appendChanPrimIO chan str
115 getArgsMn = getArgsPrimIO
117 getSplitUniqSupplyMn char = mkSplitUniqSupply char
121 #else {- ! __GLASGOW_HASKELL -}
123 type MainIO a = (a -> Dialogue) -> Dialogue
125 -- returnMn :: x -> MainIO x
126 returnMn x cont = cont x
128 -- thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
129 thenMn m k cont = m (\ a -> k a cont)
131 -- thenMn_ :: MainIO a -> MainIO b -> MainIO b
132 thenMn_ m k cont = m (\ _ -> k cont)
136 mainIOtoDialogue :: MainIO () -> Dialogue
138 mainIOtoDialogue io = io (\ _ _ -> [])
140 readMn chan = readChanIO chan
141 writeMn chan str = appendChanIO chan str
142 appendFileMn fname str = appendFileIO fname str
143 getArgsMn = getArgsIO
145 getSplitUniqSupplyMn char = returnMn (mkSplitUniqSupply char)
149 processRequestIO :: Request -> MainIO Response
150 processRequestIO req cont ~(resp:resps) = req : cont resp resps
153 doneIO cont = \ _ -> []
155 data IoResult a = IoSucc a
158 type IOE a = MainIO (IoResult a)
160 processRequestIOUnit :: Request -> IOE ()
161 processRequestIOUnit req =
162 processRequestIO req `thenMn` \ resp ->
164 Success -> returnMn (IoSucc ())
165 Str str -> error "funny Response, expected a Success"
166 StrList strl -> error "funny Response, expected a Success"
167 Failure ioerr -> returnMn (IoFail ioerr)
169 processRequestIOString :: Request -> IOE String
170 processRequestIOString req =
171 processRequestIO req `thenMn` \ resp ->
173 Success -> error "funny Response, expected a String"
174 Str str -> returnMn (IoSucc str)
175 StrList strl -> error "funny Response, expected a String"
176 Failure ioerr -> returnMn (IoFail ioerr)
178 processRequestIOStringList :: Request -> IOE [String]
179 processRequestIOStringList req =
180 processRequestIO req `thenMn` \ resp ->
182 Success -> error "funny Response, expected a [String]"
183 Str str -> error "funny Response, expected a [String]"
184 StrList strl -> returnMn (IoSucc strl)
185 Failure ioerr -> returnMn (IoFail ioerr)
187 readFileIOE :: String -> IOE String
188 writeFileIOE :: String -> String -> IOE ()
189 appendFileIOE :: String -> String -> IOE ()
190 deleteFileIOE :: String -> IOE ()
191 statusFileIOE :: String -> IOE String
192 readChanIOE :: String -> IOE String
193 appendChanIOE :: String -> String -> IOE ()
194 statusChanIOE :: String -> IOE String
195 echoIOE :: Bool -> IOE ()
196 getArgsIOE :: IOE [String]
197 getEnvIOE :: String -> IOE String
198 setEnvIOE :: String -> String -> IOE ()
199 sigActionIOE :: Int -> SigAct -> IOE ()
201 readFileIOE file = processRequestIOString ( ReadFile file )
202 writeFileIOE file str = processRequestIOUnit ( WriteFile file str )
203 appendFileIOE file str = processRequestIOUnit ( AppendFile file str )
204 deleteFileIOE file = processRequestIOUnit ( DeleteFile file )
205 statusFileIOE file = processRequestIOString ( StatusFile file )
206 readChanIOE chan = processRequestIOString ( ReadChan chan )
207 appendChanIOE chan str = processRequestIOUnit ( AppendChan chan str )
208 statusChanIOE chan = processRequestIOString ( StatusChan chan )
209 echoIOE bool = processRequestIOUnit ( Echo bool )
210 getArgsIOE = processRequestIOStringList ( GetArgs )
211 getEnvIOE var = processRequestIOString ( GetEnv var )
212 setEnvIOE var obj = processRequestIOUnit ( SetEnv var obj )
213 sigActionIOE sig act = processRequestIOUnit ( SigAction sig act )
215 handleErrIO :: IoResult a -> MainIO a
216 handleErrIO (IoSucc a) = returnMn a
217 handleErrIO (IoFail ioerr) = exitIO ioerr
219 readFileIO :: String -> MainIO String
220 writeFileIO :: String -> String -> MainIO ()
221 appendFileIO :: String -> String -> MainIO ()
222 deleteFileIO :: String -> MainIO ()
223 statusFileIO :: String -> MainIO String
224 readChanIO :: String -> MainIO String
225 appendChanIO :: String -> String -> MainIO ()
226 statusChanIO :: String -> MainIO String
227 echoIO :: Bool -> MainIO ()
228 getArgsIO :: MainIO [String]
229 getEnvIO :: String -> MainIO String
230 setEnvIO :: String -> String -> MainIO ()
231 sigActionIO :: Int -> SigAct -> MainIO ()
233 readFileIO file = readFileIOE file `thenMn` handleErrIO
234 writeFileIO file str = writeFileIOE file str `thenMn` handleErrIO
235 appendFileIO file str = appendFileIOE file str `thenMn` handleErrIO
236 deleteFileIO file = deleteFileIOE file `thenMn` handleErrIO
237 statusFileIO file = statusFileIOE file `thenMn` handleErrIO
238 readChanIO chan = readChanIOE chan `thenMn` handleErrIO
239 appendChanIO chan str = appendChanIOE chan str `thenMn` handleErrIO
240 statusChanIO chan = statusChanIOE chan `thenMn` handleErrIO
241 echoIO bool = echoIOE bool `thenMn` handleErrIO
242 getArgsIO = getArgsIOE `thenMn` handleErrIO
243 getEnvIO var = getEnvIOE var `thenMn` handleErrIO
244 setEnvIO var obj = setEnvIOE var obj `thenMn` handleErrIO
245 sigActionIO sig act = sigActionIOE sig act `thenMn` handleErrIO
247 exitIO :: IOError -> MainIO a
249 exitIO (ReadError s) = error s
250 exitIO (WriteError s) = error s
251 exitIO (SearchError s) = error s
252 exitIO (FormatError s) = error s
253 exitIO (OtherError s) = error s
257 #endif {- ! __GLASGOW_HASKELL -}