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