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 TyIO
  31 \end{code}
  32
  33 %************************************************************************
  34 %*                                                                      *
  35 \subsection[requestToIO]{Dialogue-to-IO}
  36 %*                                                                      *
  37 %************************************************************************
  38
  39 We would like to take existing Haskell programs, written with @main@
  40 of type @Dialogue@, and run them on our system.  To do this, our
  41 system actually evaluates @mainPrimIO@ (rather than @main@ directly).
  42 @main@ has type @Dialogue@ then @mainPrimIO@ [separate module] is defined
  43 like this:
  44 \begin{verbatim}
  45 mainPrimIO :: PrimIO ()
  46 mainPrimIO s = case (requestToPrimIO main s) of
  47              ( (), s2) -> ( (), s2 )
  48 \end{verbatim}
  49
  50 So, here's @requestToPrimIO@:
  51 \begin{code}
  52 requestToPrimIO :: Dialogue -> PrimIO ()
  53
  54 requestToPrimIO dialogue
  55  = newVar (error "HELP! (Forgot to link with -fhaskell-1.3?)\n")
  56                                         `thenPrimIO` \ rsV ->
  57    unsafeInterleavePrimIO (readVar rsV) `thenPrimIO` \ rs ->
  58    run (dialogue rs) rsV
  59
  60 run :: [Request] -> MutableVar _RealWorld [Response] -> PrimIO ()
  61
  62 run []         v = returnPrimIO ()
  63 run (req:reqs) v
  64  = processIORequest req                 `thenPrimIO` \ r ->
  65    newVar (error "GlasgowIO:run:synch") `thenPrimIO` \ rsV ->
  66    unsafeInterleavePrimIO (readVar rsV) `thenPrimIO` \ rs ->
  67    writeVar v (r:rs)                    `seqPrimIO`
  68    run reqs rsV
  69 \end{code}
  70
  71 %************************************************************************
  72 %*                                                                      *
  73 \subsection[processIORequest]{@processIORequest@}
  74 %*                                                                      *
  75 %************************************************************************
  76
  77 The guy that really does the business is @processIORequest@.  We make
  78 this available to the intrepid user.
  79
  80 \begin{code}
  81 processIORequest :: Request -> PrimIO Response
  82
  83 processIORequest (ReadFile name)
  84   = fopen name "r"      `thenPrimIO` \ file_star ->
  85     if (file_star == ``NULL'')
  86     then returnPrimIO (Failure (ReadError ("ReadFile: can't read: "++name)))
  87         -- ToDo: return SearchErrors when appropriate
  88
  89     else readFile# file_star `thenPrimIO` \ str ->
  90          returnPrimIO (Str str)
  91
  92 processIORequest (WriteFile name string)
  93   = fopen name "w"      `thenPrimIO` \ file_star ->
  94     if (file_star == ``NULL'')
  95     then returnPrimIO (Failure (WriteError ("WriteFile: open failed: "++name)))
  96
  97     else writeFile# file_star string  `seqPrimIO`
  98          fclose      file_star        `thenPrimIO` \ status ->
  99          returnPrimIO (
 100              if status == 0
 101              then Success
 102              else Failure (WriteError ("WriteFile: closed failed: "++name))
 103          )
 104
 105 processIORequest (AppendFile name string)
 106   = fopen name "a+"{-don't create-} `thenPrimIO` \ file_star ->
 107     if (file_star == ``NULL'')
 108     then returnPrimIO (Failure (WriteError ("AppendFile: open failed: "++name)))
 109
 110     else writeFile# file_star string `seqPrimIO`
 111          fclose     file_star        `thenPrimIO` \ status ->
 112          returnPrimIO (
 113              if status == 0
 114              then Success
 115              else Failure (WriteError ("AppendFile: closed failed: "++name))
 116          )
 117
 118 processIORequest (DeleteFile name)
 119   = _casm_ ``%r = (I_) unlink((char *) %0);'' name   `thenPrimIO` \ status ->
 120     returnPrimIO (
 121     if (status == (0::Int)) then
 122         Success
 123     else if ( (``errno''::Int) == (``ENOENT''::Int) ) then
 124         Failure (SearchError ("DeleteFile: no such file: "++name))
 125     else
 126         Failure (WriteError ("DeleteFile: could not delete: "++name))
 127     )
 128
 129 processIORequest (AppendChan chan str)
 130   = case chan of
 131       "stdout" ->
 132         appendChan# ``stdout'' str      `seqPrimIO`
 133         fflush ``stdout''               `thenPrimIO` \ status ->
 134         returnPrimIO (
 135             if status == 0
 136             then Success
 137             else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
 138         )
 139       "stderr" ->
 140         appendChan# ``stderr'' str      `seqPrimIO`
 141         fflush ``stderr''               `thenPrimIO` \ status ->
 142         returnPrimIO (
 143             if status == 0
 144             then Success
 145             else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
 146         )
 147       _ -> error "AppendChan: not implemented except for \"stdout\" and \"stderr\"\n"
 148
 149 processIORequest (ReadChan chan)
 150   = case chan of
 151       "stdin" -> readChan# ``stdin'' `thenPrimIO` \ str ->
 152                  returnPrimIO (Str str)
 153
 154       _ -> error "ReadChan: not implemented except for \"stdin\"\n"
 155
 156 processIORequest (Echo False) = returnPrimIO Success
 157 processIORequest (Echo True)
 158   = {- REMOVED: Can't be bothered. WDP: 95/04
 159     appendChan# ``stderr'' "Glasgow Haskell doesn't support \"Echo\" requests properly (yet)\n"
 160     `seqPrimIO` -} returnPrimIO Success
 161
 162 processIORequest GetArgs
 163   = returnPrimIO (StrList (unpackArgv ``prog_argv'' (``prog_argc''::Int) ))
 164
 165 processIORequest GetProgName
 166   = returnPrimIO (Str (unpackProgName ``prog_argv''))
 167
 168 processIORequest (GetEnv name)
 169   = _casm_ ``%r = getenv((char *) %0);'' name `thenPrimIO` \ litstring ->
 170     returnPrimIO (
 171         if (eqAddr litstring ``NULL'') then
 172             Failure (SearchError ("GetEnv:"++name))
 173         else
 174             Str (_unpackPS (_packCString litstring)) -- cheaper than it looks
 175     )
 176   where
 177     eqAddr (A# a1) (A# a2) = eqAddr# a1 a2
 178
 179 #ifndef __PARALLEL_HASKELL__
 180
 181 processIORequest (SigAction n act)
 182   = (case act of
 183     SAIgnore -> _ccall_ stg_sig_ignore n (``NULL''::_Addr)
 184     SADefault -> _ccall_ stg_sig_default n (``NULL''::_Addr)
 185     SACatch dialogue ->
 186                  let handler :: PrimIO ()
 187                      handler s = case (requestToPrimIO dialogue s) of
 188                                 ( (), s2@(S# _) ) -> ( (), s2 )
 189                  in
 190                     makeStablePtr handler    `thenPrimIO` \ sptr ->
 191                     _ccall_ stg_sig_catch n sptr (``NULL''::_Addr))
 192                                              `thenPrimIO` \ osptr ->
 193     returnPrimIO (
 194         if osptr >= 0 then Success
 195         else Failure (OtherError ("SigAction:" ++ show n)))
 196
 197 #endif {-!parallel-}
 198
 199 processIORequest _
 200   = error "DialogueToIO.processIORequest: unimplemented I/O request (please report)\n"
 201 \end{code}
 202
 203 %************************************************************************
 204 %*                                                                      *
 205 \subsection[DialogueIO]{Access to all @Dialogues@ in the IO world}
 206 %*                                                                      *
 207 %************************************************************************
 208
 209 This is Andy Gill's stuff to make all of @Dialogue@-style IO readily
 210 available in the monadic IO world.
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection{Support bits for all of this}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 \begin{code}
 219 -- like unpackCString ...
 220
 221 type CHAR_STAR_STAR     = _Addr -- this is all a  HACK
 222 type CHAR_STAR          = _Addr
 223
 224 unpackArgv      :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
 225 unpackProgName  :: CHAR_STAR_STAR        -> String   -- argv[0]
 226
 227 unpackArgv argv argc = unpack 1
 228   where
 229     unpack :: Int -> [String]
 230     unpack n
 231       = if (n >= argc)
 232         then ([] :: [String])
 233         else case (indexAddrOffAddr argv n) of { item ->
 234              _unpackPS (_packCString item) : unpack (n + 1)
 235              }
 236
 237 unpackProgName argv
 238   = case (indexAddrOffAddr argv 0) of { prog ->
 239     de_slash [] (_unpackPS (_packCString prog)) }
 240   where
 241     -- re-start accumulating at every '/'
 242     de_slash :: String -> String -> String
 243     de_slash acc []       = reverse acc
 244     de_slash acc ('/':xs) = de_slash []      xs
 245     de_slash acc (x:xs)   = de_slash (x:acc) xs
 246 \end{code}
 247
 248 Read and append a string from/on a given @FILE *@ stream.  @appendChan#@
 249 and @readChan#@ are well-behaved lazy functions; @writeFile#@ and
 250 @readFile#@ (which ``know'' they are writing/reading disk files) are
 251 much stricter.
 252
 253 \begin{code}
 254 appendChan#, writeFile# :: _FILE -> String -> PrimIO Bool
 255
 256 appendChan# stream [] = returnPrimIO True
 257
 258 appendChan# stream (c : cs)
 259   = _ccall_ stg_putc c stream   `seqPrimIO` -- stg_putc expands to putc
 260     appendChan# stream cs                   -- (just does some casting stream)
 261
 262 -----------
 263 writeFile# stream [] = returnPrimIO True
 264
 265 writeFile# stream (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _)
 266                  : c5@(C# _) : c6@(C# _) : c7@(C# _) : c8@(C# _)
 267                  : c9@(C# _) : c10@(C# _): c11@(C# _): c12@(C# _)
 268                  : c13@(C# _): c14@(C# _): c15@(C# _): c16@(C# _): cs)
 269  = _ccall_ stg_putc  c1 stream  `seqPrimIO`
 270    _ccall_ stg_putc  c2 stream  `seqPrimIO`
 271    _ccall_ stg_putc  c3 stream  `seqPrimIO`
 272    _ccall_ stg_putc  c4 stream  `seqPrimIO`
 273    _ccall_ stg_putc  c5 stream  `seqPrimIO`
 274    _ccall_ stg_putc  c6 stream  `seqPrimIO`
 275    _ccall_ stg_putc  c7 stream  `seqPrimIO`
 276    _ccall_ stg_putc  c8 stream  `seqPrimIO`
 277    _ccall_ stg_putc  c9 stream  `seqPrimIO`
 278    _ccall_ stg_putc c10 stream  `seqPrimIO`
 279    _ccall_ stg_putc c11 stream  `seqPrimIO`
 280    _ccall_ stg_putc c12 stream  `seqPrimIO`
 281    _ccall_ stg_putc c13 stream  `seqPrimIO`
 282    _ccall_ stg_putc c14 stream  `seqPrimIO`
 283    _ccall_ stg_putc c15 stream  `seqPrimIO`
 284    _ccall_ stg_putc c16 stream  `seqPrimIO`
 285    writeFile# stream cs
 286
 287 writeFile# stream (c : cs)
 288   = _ccall_ stg_putc c stream   `seqPrimIO`
 289     writeFile# stream cs
 290 \end{code}
 291
 292 @readChan#@ lazily reads the rest of some stream.  Dodgy because two
 293 uses of.
 294
 295 ToDo: return fclose status.
 296
 297 \begin{code}
 298 readChan#, readFile# :: _FILE -> PrimIO String
 299
 300 readChan# stream
 301   = let
 302         read_rest
 303           =  _ccall_ stg_getc{-macro-} stream `thenPrimIO` \ ch ->
 304
 305              if ch < 0 then -- SIGH: ch ==# ``EOF'' then
 306                 returnPrimIO []
 307              else
 308                 unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
 309                 returnPrimIO (chr ch : rest)
 310     in
 311     unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
 312     returnPrimIO contents
 313
 314 ------------------
 315 readFile# stream
 316   = let
 317         read_rest
 318           =  newCharArray (0::Int, 1023){-malloc!?-} `thenStrictlyST` \ arr# ->
 319                 -- ToDo: lift newCharArray out of the loop!
 320
 321              _ccall_ fread arr# (1::Int) (1024::Int) stream `thenPrimIO` \ num_read ->
 322
 323              cvt arr# 0 (num_read - 1)  `thenPrimIO` \ chars ->
 324
 325              if num_read < 1024 then
 326                 fclose stream `seqPrimIO`
 327                 returnPrimIO chars
 328              else
 329                 unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
 330                 returnPrimIO (chars ++ rest)
 331     in
 332     unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
 333     returnPrimIO contents
 334   where
 335     cvt :: _MutableByteArray _RealWorld Int
 336         -> Int -> Int
 337         -> PrimIO [Char]
 338
 339     cvt arr# idx last
 340       = if idx > last then
 341            returnPrimIO []
 342         else
 343            readCharArray arr# idx   `thenPrimIO` \ ch ->
 344            cvt arr# (idx + 1) last  `thenPrimIO` \ rest ->
 345            returnPrimIO (ch : rest)
 346 \end{code}