ghc/lib/glaExts/PreludeDialogueIO.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
   3 %
   4 \section{The @Dialogue@ interface}
   5
   6 \begin{code}
   7 module PreludeDialogueIO (
   8         requestToPrimIO,    -- RTS uses this!
   9
  10         processIORequest,   -- used in PreludeGlaIO
  11         appendChan#,        -- used elsewhere in prelude
  12         unpackArgv,         -- ditto
  13         unpackProgName      -- ditto
  14     ) where
  15
  16 import PreludeGlaST     -- for _ST stuff
  17 import PreludeGlaMisc   -- for stable pointers
  18 import Cls
  19 import Core
  20 import IChar
  21 import IInt
  22 import IList
  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 )
  28 import Text
  29 import TyArray          ( Array(..) )
  30 import TyComplex
  31 import TyIO
  32 \end{code}
  33
  34 %************************************************************************
  35 %*                                                                      *
  36 \subsection[requestToIO]{Dialogue-to-IO}
  37 %*                                                                      *
  38 %************************************************************************
  39
  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
  44 like this:
  45 \begin{verbatim}
  46 mainPrimIO :: PrimIO ()
  47 mainPrimIO s = case (requestToPrimIO main s) of
  48              ( (), s2) -> ( (), s2 )
  49 \end{verbatim}
  50
  51 So, here's @requestToPrimIO@:
  52 \begin{code}
  53 requestToPrimIO :: Dialogue -> PrimIO ()
  54
  55 requestToPrimIO dialogue
  56  = newVar (error "HELP! (Forgot to link with -fhaskell-1.3?)\n")
  57                                         `thenPrimIO` \ rsV ->
  58    unsafeInterleavePrimIO (readVar rsV) `thenPrimIO` \ rs ->
  59    run (dialogue rs) rsV
  60
  61 run :: [Request] -> MutableVar _RealWorld [Response] -> PrimIO ()
  62
  63 run []         v = returnPrimIO ()
  64 run (req:reqs) v
  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`
  69    run reqs rsV
  70 \end{code}
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection[processIORequest]{@processIORequest@}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 The guy that really does the business is @processIORequest@.  We make
  79 this available to the intrepid user.
  80
  81 \begin{code}
  82 processIORequest :: Request -> PrimIO Response
  83
  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
  89
  90     else readFile# file_star `thenPrimIO` \ str ->
  91          returnPrimIO (Str str)
  92
  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)))
  97
  98     else writeFile# file_star string  `seqPrimIO`
  99          fclose      file_star        `thenPrimIO` \ status ->
 100          returnPrimIO (
 101              if status == 0
 102              then Success
 103              else Failure (WriteError ("WriteFile: closed failed: "++name))
 104          )
 105
 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)))
 110
 111     else writeFile# file_star string `seqPrimIO`
 112          fclose     file_star        `thenPrimIO` \ status ->
 113          returnPrimIO (
 114              if status == 0
 115              then Success
 116              else Failure (WriteError ("AppendFile: closed failed: "++name))
 117          )
 118
 119 processIORequest (DeleteFile name)
 120   = _casm_ ``%r = (I_) unlink((char *) %0);'' name   `thenPrimIO` \ status ->
 121     returnPrimIO (
 122     if (status == (0::Int)) then
 123         Success
 124     else if ( (``errno''::Int) == (``ENOENT''::Int) ) then
 125         Failure (SearchError ("DeleteFile: no such file: "++name))
 126     else
 127         Failure (WriteError ("DeleteFile: could not delete: "++name))
 128     )
 129
 130 processIORequest (AppendChan chan str)
 131   = case chan of
 132       "stdout" ->
 133         appendChan# ``stdout'' str      `seqPrimIO`
 134         fflush ``stdout''               `thenPrimIO` \ status ->
 135         returnPrimIO (
 136             if status == 0
 137             then Success
 138             else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
 139         )
 140       "stderr" ->
 141         appendChan# ``stderr'' str      `seqPrimIO`
 142         fflush ``stderr''               `thenPrimIO` \ status ->
 143         returnPrimIO (
 144             if status == 0
 145             then Success
 146             else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
 147         )
 148       _ -> error "AppendChan: not implemented except for \"stdout\" and \"stderr\"\n"
 149
 150 processIORequest (ReadChan chan)
 151   = case chan of
 152       "stdin" -> readChan# ``stdin'' `thenPrimIO` \ str ->
 153                  returnPrimIO (Str str)
 154
 155       _ -> error "ReadChan: not implemented except for \"stdin\"\n"
 156
 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
 162
 163 processIORequest GetArgs
 164   = returnPrimIO (StrList (unpackArgv ``prog_argv'' (``prog_argc''::Int) ))
 165
 166 processIORequest GetProgName
 167   = returnPrimIO (Str (unpackProgName ``prog_argv''))
 168
 169 processIORequest (GetEnv name)
 170   = _casm_ ``%r = getenv((char *) %0);'' name `thenPrimIO` \ litstring ->
 171     returnPrimIO (
 172         if (eqAddr litstring ``NULL'') then
 173             Failure (SearchError ("GetEnv:"++name))
 174         else
 175             Str (_unpackPS (_packCString litstring)) -- cheaper than it looks
 176     )
 177   where
 178     eqAddr (A# a1) (A# a2) = eqAddr# a1 a2
 179
 180 #ifndef __PARALLEL_HASKELL__
 181
 182 processIORequest (SigAction n act)
 183   = (case act of
 184     SAIgnore -> _ccall_ stg_sig_ignore n (``NULL''::_Addr)
 185     SADefault -> _ccall_ stg_sig_default n (``NULL''::_Addr)
 186     SACatch dialogue ->
 187                  let handler :: PrimIO ()
 188                      handler s = case (requestToPrimIO dialogue s) of
 189                                 ( (), s2@(S# _) ) -> ( (), s2 )
 190                  in
 191                     makeStablePtr handler    `thenPrimIO` \ sptr ->
 192                     _ccall_ stg_sig_catch n sptr (``NULL''::_Addr))
 193                                              `thenPrimIO` \ osptr ->
 194     returnPrimIO (
 195         if osptr >= 0 then Success
 196         else Failure (OtherError ("SigAction:" ++ show n)))
 197
 198 #endif {-!parallel-}
 199
 200 processIORequest _
 201   = error "DialogueToIO.processIORequest: unimplemented I/O request (please report)\n"
 202 \end{code}
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection[DialogueIO]{Access to all @Dialogues@ in the IO world}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 This is Andy Gill's stuff to make all of @Dialogue@-style IO readily
 211 available in the monadic IO world.
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection{Support bits for all of this}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 \begin{code}
 220 -- like unpackCString ...
 221
 222 type CHAR_STAR_STAR     = _Addr -- this is all a  HACK
 223 type CHAR_STAR          = _Addr
 224
 225 unpackArgv      :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
 226 unpackProgName  :: CHAR_STAR_STAR        -> String   -- argv[0]
 227
 228 unpackArgv argv argc = unpack 1
 229   where
 230     unpack :: Int -> [String]
 231     unpack n
 232       = if (n >= argc)
 233         then ([] :: [String])
 234         else case (indexAddrOffAddr argv n) of { item ->
 235              _unpackPS (_packCString item) : unpack (n + 1)
 236              }
 237
 238 unpackProgName argv
 239   = case (indexAddrOffAddr argv 0) of { prog ->
 240     de_slash [] (_unpackPS (_packCString prog)) }
 241   where
 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
 247 \end{code}
 248
 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
 252 much stricter.
 253
 254 \begin{code}
 255 appendChan#, writeFile# :: _FILE -> String -> PrimIO Bool
 256
 257 appendChan# stream [] = returnPrimIO True
 258
 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)
 262
 263 -----------
 264 writeFile# stream [] = returnPrimIO True
 265
 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`
 286    writeFile# stream cs
 287
 288 writeFile# stream (c : cs)
 289   = _ccall_ stg_putc c stream   `seqPrimIO`
 290     writeFile# stream cs
 291 \end{code}
 292
 293 @readChan#@ lazily reads the rest of some stream.  Dodgy because two
 294 uses of.
 295
 296 ToDo: return fclose status.
 297
 298 \begin{code}
 299 readChan#, readFile# :: _FILE -> PrimIO String
 300
 301 readChan# stream
 302   = let
 303         read_rest
 304           =  _ccall_ stg_getc{-macro-} stream `thenPrimIO` \ ch ->
 305
 306              if ch < 0 then -- SIGH: ch ==# ``EOF'' then
 307                 returnPrimIO []
 308              else
 309                 unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
 310                 returnPrimIO (chr ch : rest)
 311     in
 312     unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
 313     returnPrimIO contents
 314
 315 ------------------
 316 readFile# stream
 317   = let
 318         read_rest
 319           =  newCharArray (0::Int, 1023){-malloc!?-} `thenStrictlyST` \ arr# ->
 320                 -- ToDo: lift newCharArray out of the loop!
 321
 322              _ccall_ fread arr# (1::Int) (1024::Int) stream `thenPrimIO` \ num_read ->
 323
 324              cvt arr# 0 (num_read - 1)  `thenPrimIO` \ chars ->
 325
 326              if num_read < 1024 then
 327                 fclose stream `seqPrimIO`
 328                 returnPrimIO chars
 329              else
 330                 unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
 331                 returnPrimIO (chars ++ rest)
 332     in
 333     unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
 334     returnPrimIO contents
 335   where
 336     cvt :: _MutableByteArray _RealWorld Int
 337         -> Int -> Int
 338         -> PrimIO [Char]
 339
 340     cvt arr# idx last
 341       = if idx > last then
 342            returnPrimIO []
 343         else
 344            readCharArray arr# idx   `thenPrimIO` \ ch ->
 345            cvt arr# (idx + 1) last  `thenPrimIO` \ rest ->
 346            returnPrimIO (ch : rest)
 347 \end{code}