2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
4 \section{The @Dialogue@ interface}
7 module PreludeDialogueIO (
8 requestToPrimIO, -- RTS uses this!
10 processIORequest, -- used in PreludeGlaIO
11 appendChan#, -- used elsewhere in prelude
13 unpackProgName -- ditto
16 import PreludeGlaST -- for _ST stuff
17 import PreludeGlaMisc -- for stable pointers
23 import IO ( stdout, stdin )
24 import List ( (++), reverse, foldr, foldl )
25 import PS -- packed strings
26 import Prel ( chr, flip )
27 import Stdio ( fopen, fclose, fflush, _FILE )
29 import TyArray ( Array(..) )
34 %************************************************************************
36 \subsection[requestToIO]{Dialogue-to-IO}
38 %************************************************************************
40 We would like to take existing Haskell programs, written with @main@
41 of type @Dialogue@, and run them on our system. To do this, our
42 system actually evaluates @mainPrimIO@ (rather than @main@ directly).
43 @main@ has type @Dialogue@ then @mainPrimIO@ [separate module] is defined
46 mainPrimIO :: PrimIO ()
47 mainPrimIO s = case (requestToPrimIO main s) of
48 ( (), s2) -> ( (), s2 )
51 So, here's @requestToPrimIO@:
53 requestToPrimIO :: Dialogue -> PrimIO ()
55 requestToPrimIO dialogue
56 = newVar (error "HELP! (Forgot to link with -fhaskell-1.3?)\n")
58 unsafeInterleavePrimIO (readVar rsV) `thenPrimIO` \ rs ->
61 run :: [Request] -> MutableVar _RealWorld [Response] -> PrimIO ()
63 run [] v = returnPrimIO ()
65 = processIORequest req `thenPrimIO` \ r ->
66 newVar (error "GlasgowIO:run:synch") `thenPrimIO` \ rsV ->
67 unsafeInterleavePrimIO (readVar rsV) `thenPrimIO` \ rs ->
68 writeVar v (r:rs) `seqPrimIO`
72 %************************************************************************
74 \subsection[processIORequest]{@processIORequest@}
76 %************************************************************************
78 The guy that really does the business is @processIORequest@. We make
79 this available to the intrepid user.
82 processIORequest :: Request -> PrimIO Response
84 processIORequest (ReadFile name)
85 = fopen name "r" `thenPrimIO` \ file_star ->
86 if (file_star == ``NULL'')
87 then returnPrimIO (Failure (ReadError ("ReadFile: can't read: "++name)))
88 -- ToDo: return SearchErrors when appropriate
90 else readFile# file_star `thenPrimIO` \ str ->
91 returnPrimIO (Str str)
93 processIORequest (WriteFile name string)
94 = fopen name "w" `thenPrimIO` \ file_star ->
95 if (file_star == ``NULL'')
96 then returnPrimIO (Failure (WriteError ("WriteFile: open failed: "++name)))
98 else writeFile# file_star string `seqPrimIO`
99 fclose file_star `thenPrimIO` \ status ->
103 else Failure (WriteError ("WriteFile: closed failed: "++name))
106 processIORequest (AppendFile name string)
107 = fopen name "a+"{-don't create-} `thenPrimIO` \ file_star ->
108 if (file_star == ``NULL'')
109 then returnPrimIO (Failure (WriteError ("AppendFile: open failed: "++name)))
111 else writeFile# file_star string `seqPrimIO`
112 fclose file_star `thenPrimIO` \ status ->
116 else Failure (WriteError ("AppendFile: closed failed: "++name))
119 processIORequest (DeleteFile name)
120 = _casm_ ``%r = (I_) unlink((char *) %0);'' name `thenPrimIO` \ status ->
122 if (status == (0::Int)) then
124 else if ( (``errno''::Int) == (``ENOENT''::Int) ) then
125 Failure (SearchError ("DeleteFile: no such file: "++name))
127 Failure (WriteError ("DeleteFile: could not delete: "++name))
130 processIORequest (AppendChan chan str)
133 appendChan# ``stdout'' str `seqPrimIO`
134 fflush ``stdout'' `thenPrimIO` \ status ->
138 else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
141 appendChan# ``stderr'' str `seqPrimIO`
142 fflush ``stderr'' `thenPrimIO` \ status ->
146 else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
148 _ -> error "AppendChan: not implemented except for \"stdout\" and \"stderr\"\n"
150 processIORequest (ReadChan chan)
152 "stdin" -> readChan# ``stdin'' `thenPrimIO` \ str ->
153 returnPrimIO (Str str)
155 _ -> error "ReadChan: not implemented except for \"stdin\"\n"
157 processIORequest (Echo False) = returnPrimIO Success
158 processIORequest (Echo True)
159 = {- REMOVED: Can't be bothered. WDP: 95/04
160 appendChan# ``stderr'' "Glasgow Haskell doesn't support \"Echo\" requests properly (yet)\n"
161 `seqPrimIO` -} returnPrimIO Success
163 processIORequest GetArgs
164 = returnPrimIO (StrList (unpackArgv ``prog_argv'' (``prog_argc''::Int) ))
166 processIORequest GetProgName
167 = returnPrimIO (Str (unpackProgName ``prog_argv''))
169 processIORequest (GetEnv name)
170 = _casm_ ``%r = getenv((char *) %0);'' name `thenPrimIO` \ litstring ->
172 if (eqAddr litstring ``NULL'') then
173 Failure (SearchError ("GetEnv:"++name))
175 Str (_unpackPS (_packCString litstring)) -- cheaper than it looks
178 eqAddr (A# a1) (A# a2) = eqAddr# a1 a2
180 #ifndef __PARALLEL_HASKELL__
182 processIORequest (SigAction n act)
184 SAIgnore -> _ccall_ stg_sig_ignore n (``NULL''::_Addr)
185 SADefault -> _ccall_ stg_sig_default n (``NULL''::_Addr)
187 let handler :: PrimIO ()
188 handler s = case (requestToPrimIO dialogue s) of
189 ( (), s2@(S# _) ) -> ( (), s2 )
191 makeStablePtr handler `thenPrimIO` \ sptr ->
192 _ccall_ stg_sig_catch n sptr (``NULL''::_Addr))
193 `thenPrimIO` \ osptr ->
195 if osptr >= 0 then Success
196 else Failure (OtherError ("SigAction:" ++ show n)))
201 = error "DialogueToIO.processIORequest: unimplemented I/O request (please report)\n"
204 %************************************************************************
206 \subsection[DialogueIO]{Access to all @Dialogues@ in the IO world}
208 %************************************************************************
210 This is Andy Gill's stuff to make all of @Dialogue@-style IO readily
211 available in the monadic IO world.
213 %************************************************************************
215 \subsection{Support bits for all of this}
217 %************************************************************************
220 -- like unpackCString ...
222 type CHAR_STAR_STAR = _Addr -- this is all a HACK
223 type CHAR_STAR = _Addr
225 unpackArgv :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
226 unpackProgName :: CHAR_STAR_STAR -> String -- argv[0]
228 unpackArgv argv argc = unpack 1
230 unpack :: Int -> [String]
233 then ([] :: [String])
234 else case (indexAddrOffAddr argv n) of { item ->
235 _unpackPS (_packCString item) : unpack (n + 1)
239 = case (indexAddrOffAddr argv 0) of { prog ->
240 de_slash [] (_unpackPS (_packCString prog)) }
242 -- re-start accumulating at every '/'
243 de_slash :: String -> String -> String
244 de_slash acc [] = reverse acc
245 de_slash acc ('/':xs) = de_slash [] xs
246 de_slash acc (x:xs) = de_slash (x:acc) xs
249 Read and append a string from/on a given @FILE *@ stream. @appendChan#@
250 and @readChan#@ are well-behaved lazy functions; @writeFile#@ and
251 @readFile#@ (which ``know'' they are writing/reading disk files) are
255 appendChan#, writeFile# :: _FILE -> String -> PrimIO Bool
257 appendChan# stream [] = returnPrimIO True
259 appendChan# stream (c : cs)
260 = _ccall_ stg_putc c stream `seqPrimIO` -- stg_putc expands to putc
261 appendChan# stream cs -- (just does some casting stream)
264 writeFile# stream [] = returnPrimIO True
266 writeFile# stream (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _)
267 : c5@(C# _) : c6@(C# _) : c7@(C# _) : c8@(C# _)
268 : c9@(C# _) : c10@(C# _): c11@(C# _): c12@(C# _)
269 : c13@(C# _): c14@(C# _): c15@(C# _): c16@(C# _): cs)
270 = _ccall_ stg_putc c1 stream `seqPrimIO`
271 _ccall_ stg_putc c2 stream `seqPrimIO`
272 _ccall_ stg_putc c3 stream `seqPrimIO`
273 _ccall_ stg_putc c4 stream `seqPrimIO`
274 _ccall_ stg_putc c5 stream `seqPrimIO`
275 _ccall_ stg_putc c6 stream `seqPrimIO`
276 _ccall_ stg_putc c7 stream `seqPrimIO`
277 _ccall_ stg_putc c8 stream `seqPrimIO`
278 _ccall_ stg_putc c9 stream `seqPrimIO`
279 _ccall_ stg_putc c10 stream `seqPrimIO`
280 _ccall_ stg_putc c11 stream `seqPrimIO`
281 _ccall_ stg_putc c12 stream `seqPrimIO`
282 _ccall_ stg_putc c13 stream `seqPrimIO`
283 _ccall_ stg_putc c14 stream `seqPrimIO`
284 _ccall_ stg_putc c15 stream `seqPrimIO`
285 _ccall_ stg_putc c16 stream `seqPrimIO`
288 writeFile# stream (c : cs)
289 = _ccall_ stg_putc c stream `seqPrimIO`
293 @readChan#@ lazily reads the rest of some stream. Dodgy because two
296 ToDo: return fclose status.
299 readChan#, readFile# :: _FILE -> PrimIO String
304 = _ccall_ stg_getc{-macro-} stream `thenPrimIO` \ ch ->
306 if ch < 0 then -- SIGH: ch ==# ``EOF'' then
309 unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
310 returnPrimIO (chr ch : rest)
312 unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
313 returnPrimIO contents
319 = newCharArray (0::Int, 1023){-malloc!?-} `thenStrictlyST` \ arr# ->
320 -- ToDo: lift newCharArray out of the loop!
322 _ccall_ fread arr# (1::Int) (1024::Int) stream `thenPrimIO` \ num_read ->
324 cvt arr# 0 (num_read - 1) `thenPrimIO` \ chars ->
326 if num_read < 1024 then
327 fclose stream `seqPrimIO`
330 unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
331 returnPrimIO (chars ++ rest)
333 unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
334 returnPrimIO contents
336 cvt :: _MutableByteArray _RealWorld Int
344 readCharArray arr# idx `thenPrimIO` \ ch ->
345 cvt arr# (idx + 1) last `thenPrimIO` \ rest ->
346 returnPrimIO (ch : rest)