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