home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / IOExts.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  4.4 KB  |  143 lines
  1. -----------------------------------------------------------------------------
  2. -- IO monad extensions:
  3. --
  4. -- Suitable for use with Hugs 98.
  5. -----------------------------------------------------------------------------
  6.  
  7. module IOExts
  8.     ( fixIO
  9.     , unsafePerformIO
  10.     , unsafeInterleaveIO
  11.  
  12.     , IORef
  13.       -- instance Eq (IORef a)
  14.     , newIORef
  15.     , readIORef
  16.     , writeIORef
  17.  
  18.         , IOArray
  19.           -- instance Eq (IOArray ix elt)
  20.         , newIOArray
  21.         , boundsIOArray
  22.         , readIOArray
  23.         , writeIOArray
  24.         , thawIOArray
  25.         , freezeIOArray
  26.         , unsafeFreezeIOArray
  27.  
  28.     , performGC
  29.     , trace
  30.     , unsafePtrEq
  31.     , unsafePtrToInt
  32.     ) where
  33.  
  34. import Trace( trace )
  35. import IO( ioeGetErrorString )
  36. import Array
  37.  
  38. -----------------------------------------------------------------------------
  39.  
  40. primitive performGC "primGC" :: IO ()
  41.  
  42. unsafePerformIO :: IO a -> a
  43. unsafePerformIO m = performIO (runAndShowError m)
  44.  
  45. unsafeInterleaveIO :: IO a -> IO a
  46. unsafeInterleaveIO m = interleaveIO (runAndShowError m)
  47.  
  48. primitive unsafePtrEq    :: a -> a -> Bool
  49. primitive unsafePtrToInt :: a -> Int
  50.  
  51. fixIO :: (a -> IO a) -> IO a
  52. fixIO m = IO fixIO'
  53.  where
  54.   fixIO' fail succ =
  55.     case r of
  56.     Hugs_Return a   -> succ a
  57.     Hugs_Error err  -> fail err
  58.     other           -> other
  59.    where
  60.     r = case m a of { IO ma -> ma Hugs_Error Hugs_Return }
  61.     a = case r   of 
  62.         Hugs_Return a  -> a
  63.         Hugs_Error err -> error "IOExts:fixIO: thread exited with error"
  64.         _              -> error "IOExts:fixIO: thread exited with no result"
  65.  
  66. performIO :: IO a -> a
  67. performIO (IO m) = 
  68.   case m Hugs_Error Hugs_Return of
  69.   Hugs_Return a  -> a
  70.   Hugs_Error err -> error "IOExts.performIO: thread exited with error"
  71.   _              -> error "IOExts.performIO: thread exited with no result"
  72.  
  73. interleaveIO :: IO a -> IO a
  74. interleaveIO (IO m) = IO (\ f s -> 
  75.   s (case m Hugs_Error Hugs_Return of
  76.      Hugs_Return a  -> a
  77.      Hugs_Error err -> error "IOExts.interleaveIO: thread exited with error"
  78.      _              -> error "IOExts.interleaveIO: thread exited with no result"
  79.      ))
  80.  
  81. runAndShowError :: IO a -> IO a
  82. runAndShowError m =
  83.   m `catch` \err -> do 
  84.       putChar '\n'
  85.       putStr (ioeGetErrorString err)
  86.       return undefined
  87.  
  88. -----------------------------------------------------------------------------
  89.  
  90. data IORef a        -- mutable variables containing values of type a
  91.  
  92. primitive newIORef   "newRef" :: a -> IO (IORef a)
  93. primitive readIORef  "getRef" :: IORef a -> IO a
  94. primitive writeIORef "setRef" :: IORef a -> a -> IO ()
  95. primitive eqIORef    "eqRef"  :: IORef a -> IORef a -> Bool
  96.  
  97. instance Eq (IORef a) where
  98.     (==) = eqIORef
  99.  
  100. -----------------------------------------------------------------------------
  101.  
  102. data IOArray ix elt -- implemented as an internal primitive
  103.  
  104. newIOArray          :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
  105. boundsIOArray       :: Ix ix => IOArray ix elt -> (ix, ix)
  106. readIOArray         :: Ix ix => IOArray ix elt -> ix -> IO elt
  107. writeIOArray        :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
  108. thawIOArray         :: Ix ix => Array ix elt -> IO (IOArray ix elt)
  109. freezeIOArray       :: Ix ix => IOArray ix elt -> IO (Array ix elt)
  110. unsafeFreezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
  111.  
  112. newIOArray bs e      = primNewArr bs (rangeSize bs) e
  113. boundsIOArray a      = primBounds a
  114. readIOArray a i      = primReadArr index a i
  115. writeIOArray a i e   = primWriteArr index a i e
  116. thawIOArray arr      = do a <- newIOArray (bounds arr) err
  117.               let fillin []          = return a
  118.                   fillin((ix,v):ixs) = do writeIOArray a ix v
  119.                                                       fillin ixs
  120.                           fillin (assocs arr)
  121.                        where err =  error "thawArray: element not overwritten"
  122.  
  123. freezeIOArray a      = primFreeze a
  124. unsafeFreezeIOArray  = freezeIOArray  -- not as fast as GHC
  125.  
  126. instance Eq (IOArray ix elt) where
  127.   (==) = eqIOArray
  128.  
  129. primitive primNewArr   "IONewArr"
  130.           :: (a,a) -> Int -> b -> IO (IOArray a b)
  131. primitive primReadArr  "IOReadArr"
  132.           :: ((a,a) -> a -> Int) -> IOArray a b -> a -> IO b
  133. primitive primWriteArr "IOWriteArr"
  134.           :: ((a,a) -> a -> Int) -> IOArray a b -> a -> b -> IO ()
  135. primitive primFreeze   "IOFreeze"
  136.           :: IOArray a b -> IO (Array a b)
  137. primitive primBounds   "IOBounds"
  138.           :: IOArray a b -> (a,a)
  139. primitive eqIOArray    "IOArrEq"
  140.           :: IOArray a b -> IOArray a b -> Bool
  141.  
  142. -----------------------------------------------------------------------------
  143.