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         , IOArray       -- instance of: Eq
  27         , newIOArray
  28         , boundsIOArray
  29         , readIOArray
  30         , writeIOArray
  31         , freezeIOArray
  32         , thawIOArray
  33
  34 #ifdef __HUGS__
  35 #else
  36         , openFileEx
  37         , IOModeEx(..)
  38
  39         , hSetEcho
  40         , hGetEcho
  41         , hIsTerminalDevice
  42         , hConnectTo
  43 #endif
  44         , trace
  45 #ifdef __HUGS__
  46 #else
  47         , performGC
  48 #endif
  49
  50         , unsafePtrEq
  51         , unsafeIOToST
  52         , stToIO
  53
  54         ) where
  55
  56 \end{code}
  57
  58 \begin{code}
  59 #ifdef __HUGS__
  60 import PreludeBuiltin
  61 import ST
  62 #else
  63 import PrelBase
  64 import PrelIOBase
  65 import PrelHandle ( openFileEx, IOModeEx(..),
  66                     hSetEcho, hGetEcho, getHandleFd
  67                   )
  68 import PrelST
  69 import PrelArr
  70 import PrelGHC
  71 import PrelHandle
  72 import PrelErr
  73 import IO       ( hPutStr, hPutChar )
  74 #endif
  75 import Ix
  76
  77 unsafePtrEq :: a -> a -> Bool
  78
  79 #ifdef __HUGS__
  80 unsafePtrEq = primReallyUnsafePtrEquality
  81 #else
  82 unsafePtrEq a b =
  83     case reallyUnsafePtrEquality# a b of
  84          0# -> False
  85          _  -> True
  86 #endif
  87 \end{code}
  88
  89 \begin{code}
  90 newIORef   :: a -> IO (IORef a)
  91 readIORef  :: IORef a -> IO a
  92 writeIORef :: IORef a -> a -> IO ()
  93
  94 #ifdef __HUGS__
  95 type IORef a = STRef RealWorld a
  96 newIORef   = newSTRef
  97 readIORef  = readSTRef
  98 writeIORef = writeSTRef
  99 #else
 100 newtype IORef a = IORef (MutableVar RealWorld a)
 101     deriving Eq
 102
 103 newIORef v = stToIO (newVar v) >>= \ var -> return (IORef var)
 104 readIORef  (IORef var) = stToIO (readVar var)
 105 writeIORef (IORef var) v = stToIO (writeVar var v)
 106 #endif
 107 \end{code}
 108
 109 \begin{code}
 110 newIOArray          :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
 111 boundsIOArray       :: Ix ix => IOArray ix elt -> (ix, ix)
 112 readIOArray         :: Ix ix => IOArray ix elt -> ix -> IO elt
 113 writeIOArray        :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
 114 freezeIOArray       :: Ix ix => IOArray ix elt -> IO (Array ix elt)
 115 thawIOArray         :: Ix ix => Array ix elt -> IO (IOArray ix elt)
 116
 117 #ifdef __HUGS__
 118 type IOArray ix elt = STArray RealWorld ix elt
 119 newIOArray    = newSTArray
 120 boundsIOArray = boundsSTArray
 121 readIOArray   = readSTArray
 122 writeIOArray  = writeSTArray
 123 freezeIOArray = freezeSTArray
 124 thawIOArray   = thawSTArray
 125 #else
 126 newtype IOArray ix elt = IOArray (MutableArray RealWorld ix elt)
 127     deriving Eq
 128
 129 newIOArray ixs elt =
 130     stToIO (newArray ixs elt) >>= \arr ->
 131     return (IOArray arr)
 132
 133 boundsIOArray (IOArray arr) = boundsOfArray arr
 134
 135 readIOArray (IOArray arr) ix = stToIO (readArray arr ix)
 136
 137 writeIOArray (IOArray arr) ix elt = stToIO (writeArray arr ix elt)
 138
 139 freezeIOArray (IOArray arr) = stToIO (freezeArray arr)
 140
 141 thawIOArray arr = do
 142         marr <- stToIO (thawArray arr)
 143         return (IOArray marr)
 144 #endif
 145 \end{code}
 146
 147 \begin{code}
 148 {-# NOINLINE trace #-}
 149 trace :: String -> a -> a
 150 #ifdef __HUGS__
 151 trace string expr = unsafePerformIO $ do
 152     putStrLn string
 153     return expr
 154 #else
 155 trace string expr = unsafePerformIO $ do
 156     fd <- getHandleFd stderr
 157     hPutStr stderr string
 158     hPutChar stderr '\n'
 159     _ccall_ PostTraceHook fd
 160     return expr
 161 #endif
 162 \end{code}
 163
 164 \begin{code}
 165 unsafeIOToST       :: IO a -> ST s a
 166 #ifdef __HUGS__
 167 unsafeIOToST = primUnsafeCoerce
 168 #else
 169 unsafeIOToST (IO io) = ST $ \ s ->
 170     case ((unsafeCoerce# io) s) of
 171       (#  new_s, a #) -> unsafeCoerce# (STret new_s a)
 172 --      IOfail new_s e -> error ("I/O Error (unsafeIOToST): " ++ showsPrec 0 e "\n")
 173 #endif
 174 \end{code}
 175
 176 Not something you want to call normally, but useful
 177 in the cases where you do want to flush stuff out of
 178 the heap or make sure you've got room enough
 179
 180 \begin{code}
 181 #ifdef __HUGS__
 182 #else
 183 performGC :: IO ()
 184 performGC = _ccall_GC_ performGC
 185 #endif
 186 \end{code}
 187