ghc/lib/exts/IOExts.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4 \section[IOExts]{Module @IOExts@}
   5
   6 @IOExts@ provides useful functionality that fall outside the
   7 standard Haskell IO interface. Expect the contents of IOExts
   8 to be the same for Hugs and GHC (same goes for any other
   9 Hugs/GHC extension libraries, unless a function/type is
  10 explicitly flagged as being implementation specific
  11 extension.)
  12
  13 \begin{code}
  14 {-# OPTIONS -fno-implicit-prelude #-}
  15
  16 module IOExts
  17         ( fixIO
  18         , unsafePerformIO
  19         , unsafeInterleaveIO
  20
  21         , IORef             -- instance of: Eq
  22         , newIORef
  23         , readIORef
  24         , writeIORef
  25         , updateIORef
  26
  27         , mkWeakIORef
  28
  29         , IOArray       -- instance of: Eq
  30         , newIOArray
  31         , boundsIOArray
  32         , readIOArray
  33         , writeIOArray
  34         , freezeIOArray
  35         , thawIOArray
  36 #ifndef __HUGS__
  37         , unsafeFreezeIOArray
  38         , unsafeThawIOArray
  39 #endif
  40
  41 #ifdef __HUGS__
  42 #else
  43         , openFileEx
  44         , IOModeEx(..)
  45
  46         , hSetEcho
  47         , hGetEcho
  48         , hIsTerminalDevice
  49         , hConnectTo
  50         , withHandleFor
  51         , withStdout
  52         , withStdin
  53         , withStderr
  54 #endif
  55         , trace
  56 #ifdef __HUGS__
  57 #else
  58         , performGC
  59 #endif
  60
  61         , unsafePtrEq
  62
  63         , freeHaskellFunctionPtr
  64
  65         , HandlePosition
  66         , HandlePosn(..)
  67         , hTell                -- :: Handle -> IO HandlePosition
  68
  69         , hSetBinaryMode       -- :: Handle -> Bool -> IO Bool
  70
  71         ) where
  72
  73 \end{code}
  74
  75 \begin{code}
  76 #ifdef __HUGS__
  77 import PreludeBuiltin
  78 import ST
  79 #else
  80 import PrelBase
  81 import PrelIOBase
  82 import IO
  83 import PrelHandle ( openFileEx, IOModeEx(..),
  84                     hSetEcho, hGetEcho, getHandleFd
  85                   )
  86 import PrelST
  87 import PrelArr
  88 import PrelWeak
  89 import PrelGHC
  90 import PrelHandle
  91 import PrelErr
  92 import IO       ( hPutStr, hPutChar )
  93 import PrelAddr ( Addr )
  94 #endif
  95 import Ix
  96
  97 unsafePtrEq :: a -> a -> Bool
  98
  99 #ifdef __HUGS__
 100 unsafePtrEq = primReallyUnsafePtrEquality
 101 #else
 102 unsafePtrEq a b =
 103     case reallyUnsafePtrEquality# a b of
 104          0# -> False
 105          _  -> True
 106 #endif
 107 \end{code}
 108
 109 \begin{code}
 110 newIORef    :: a -> IO (IORef a)
 111 readIORef   :: IORef a -> IO a
 112 writeIORef  :: IORef a -> a -> IO ()
 113
 114 #ifdef __HUGS__
 115 type IORef a = STRef RealWorld a
 116 newIORef   = newSTRef
 117 readIORef  = readSTRef
 118 writeIORef = writeSTRef
 119 #else
 120 newtype IORef a = IORef (MutableVar RealWorld a)
 121     deriving Eq
 122
 123 newIORef v = stToIO (newVar v) >>= \ var -> return (IORef var)
 124 readIORef  (IORef var) = stToIO (readVar var)
 125 writeIORef (IORef var) v = stToIO (writeVar var v)
 126 #endif
 127
 128 updateIORef :: IORef a -> (a -> a) -> IO ()
 129 updateIORef ref f = do
 130   x <- readIORef ref
 131   let x' = f x
 132   writeIORef ref x'
 133   -- or should we return new value ? (or old?)
 134
 135 mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))
 136 mkWeakIORef r@(IORef (MutableVar r#)) f = IO $ \s ->
 137   case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)
 138 \end{code}
 139
 140 \begin{code}
 141 newIOArray          :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
 142 boundsIOArray       :: Ix ix => IOArray ix elt -> (ix, ix)
 143 readIOArray         :: Ix ix => IOArray ix elt -> ix -> IO elt
 144 writeIOArray        :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
 145 freezeIOArray       :: Ix ix => IOArray ix elt -> IO (Array ix elt)
 146 thawIOArray         :: Ix ix => Array ix elt -> IO (IOArray ix elt)
 147 #ifndef __HUGS__
 148 unsafeFreezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
 149 unsafeThawIOArray   :: Ix ix => Array ix elt -> IO (IOArray ix elt)
 150 #endif
 151
 152 #ifdef __HUGS__
 153 type IOArray ix elt = STArray RealWorld ix elt
 154 newIOArray    = newSTArray
 155 boundsIOArray = boundsSTArray
 156 readIOArray   = readSTArray
 157 writeIOArray  = writeSTArray
 158 freezeIOArray = freezeSTArray
 159 thawIOArray   = thawSTArray
 160 #else
 161 newtype IOArray ix elt = IOArray (MutableArray RealWorld ix elt)
 162     deriving Eq
 163
 164 newIOArray ixs elt =
 165     stToIO (newArray ixs elt) >>= \arr ->
 166     return (IOArray arr)
 167
 168 boundsIOArray (IOArray arr) = boundsOfArray arr
 169
 170 readIOArray (IOArray arr) ix = stToIO (readArray arr ix)
 171
 172 writeIOArray (IOArray arr) ix elt = stToIO (writeArray arr ix elt)
 173
 174 freezeIOArray (IOArray arr) = stToIO (freezeArray arr)
 175
 176 thawIOArray arr = do
 177         marr <- stToIO (thawArray arr)
 178         return (IOArray marr)
 179
 180 unsafeFreezeIOArray (IOArray arr) = stToIO (unsafeFreezeArray arr)
 181 unsafeThawIOArray   arr = do
 182         marr <- stToIO (unsafeThawArray arr)
 183         return (IOArray marr)
 184 #endif
 185 \end{code}
 186
 187 \begin{code}
 188 {-# NOINLINE trace #-}
 189 trace :: String -> a -> a
 190 #ifdef __HUGS__
 191 trace string expr = unsafePerformIO $ do
 192     putStrLn string
 193     return expr
 194 #else
 195 trace string expr = unsafePerformIO $ do
 196     fd <- getHandleFd stderr
 197     hPutStr stderr string
 198     hPutChar stderr '\n'
 199     postTraceHook fd
 200     return expr
 201
 202 foreign import "PostTraceHook" postTraceHook :: Int -> IO ()
 203 #endif
 204
 205 \end{code}
 206
 207 Not something you want to call normally, but useful
 208 in the cases where you do want to flush stuff out of
 209 the heap or make sure you've got room enough
 210
 211 \begin{code}
 212 #ifndef __HUGS__
 213 foreign import "performGC" performGC :: IO ()
 214 #endif
 215 \end{code}
 216
 217 When using 'foreign export dynamic' to dress up a Haskell
 218 IO action to look like a C function pointer, a little bit
 219 of memory is allocated (along with a stable pointer to
 220 the Haskell IO action). When done with the C function
 221 pointer, you'll need to call @freeHaskellFunctionPtr()@ to
 222 let go of these resources - here's the Haskell wrapper for
 223 that RTS entry point, should you want to free it from
 224 within Haskell.
 225
 226 \begin{code}
 227 foreign import ccall "freeHaskellFunctionPtr"
 228   freeHaskellFunctionPtr :: Addr -> IO ()
 229
 230 \end{code}
 231
 232 (Experimental)
 233
 234 Support for redirecting I/O on a handle to another for the
 235 duration of an IO action. To re-route a handle, it is first
 236 flushed, followed by replacing its innards (i.e., FILE_OBJECT)
 237 with that of the other. This happens before and after the
 238 action is executed.
 239
 240 If the action raises an exception, the handle is replaced back
 241 to its old contents, but without flushing it first - as this
 242 may provoke exceptions. Notice that the action may perform
 243 I/O on either Handle, with the result that the I/O is interleaved.
 244 (Why you would want to do this, is a completely different matter.)
 245
 246 ToDo: probably want to restrict what kind of handles can be
 247 replaced with another - i.e., don't want to be able to replace
 248 a writeable handle with a readable one.
 249
 250 \begin{code}
 251 withHandleFor :: Handle
 252               -> Handle
 253               -> IO a
 254               -> IO a
 255 withHandleFor h1 h2 act = do
 256    h1_fo <- getFO h1
 257    plugIn h1_fo
 258  where
 259   plugIn h1_fo = do
 260     hFlush h2
 261     h2_fo <- withHandle h2 $ \ h2_ -> return (h2_{haFO__=h1_fo}, haFO__ h2_)
 262     catch (act >>= \ x -> hFlush h2 >> setFO h2 h2_fo >> return x)
 263           (\ err -> setFO h2 h2_fo >> ioError err)
 264
 265   setFO h fo =
 266     withHandle h $ \ h_ -> return (h_{haFO__=fo}, ())
 267
 268   getFO h =
 269     wantRWHandle "withHandleFor" h $ \ h_ ->
 270     return (haFO__ h_)
 271
 272 \end{code}
 273
 274 Derived @withHandleFor@ combinators and, at the moment, these
 275 are exported from @IOExts@ and not @withHandleFor@ itself.
 276
 277 \begin{code}
 278 withStdin  h a = withHandleFor h stdin  a
 279 withStdout h a = withHandleFor h stdout a
 280 withStderr h a = withHandleFor h stderr a
 281 \end{code}
 282
 283 @hTell@ is the lower-level version of @hGetPosn@ - return the
 284 position, without bundling it together with the handle itself:
 285
 286 \begin{code}
 287 hTell :: Handle -> IO HandlePosition
 288 hTell h = do
 289   (HandlePosn _ x) <- hGetPosn h
 290   return x
 291 \end{code}
 292
 293 @hSetBinaryMode@ lets you change the translation mode for a handle.
 294 On some platforms (e.g., Win32) a distinction is made between being in
 295 'text mode' or 'binary mode', with the former terminating lines
 296 by \r\n rather than just \n.
 297
 298 Debating the Winnitude or otherwise of such a scheme is less than
 299 interesting -- it's there, so we have to cope.
 300
 301 A side-effect of calling @hSetBinaryMode@ is that the output buffer
 302 (if any) is flushed prior to changing the translation mode.
 303
 304 \begin{code}
 305 hSetBinaryMode :: Handle -> Bool -> IO Bool
 306 hSetBinaryMode handle is_binary = do
 307         -- is_binary = True => set translation mode to binary.
 308     wantRWHandle "hSetBinaryMode" handle $ \ handle_ -> do
 309     let fo = haFO__ handle_
 310     rc      <- setBinaryMode fo flg
 311     if rc >= 0 then
 312        return (int2Bool rc)
 313      else
 314        constructErrorAndFail "hSetBinaryMode"
 315   where
 316    flg | is_binary = 1
 317        | otherwise = 0
 318
 319    int2Bool 0 = False
 320    int2Bool _ = True
 321
 322 \end{code}