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