[project @ 2000-03-13 10:53:55 by simonmar]

[ghc-hetmet.git] / ghc / lib / hugs / Prelude.hs

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index cde2783..1937a12 100644 (file)
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -4,7 +4,7 @@ __   __ __  __  ____   ___    _______________________________________________
 ||___|| ||__|| ||__||  __||   Copyright (c) 1994-1999
 ||---||         ___||         World Wide Web: http://haskell.org/hugs
 ||   ||                       Report bugs to: hugs-bugs@haskell.org
 ||___|| ||__|| ||__||  __||   Copyright (c) 1994-1999
 ||---||         ___||         World Wide Web: http://haskell.org/hugs
 ||   ||                       Report bugs to: hugs-bugs@haskell.org

-||   || Version: January 1999 _______________________________________________
+||   || Version: STG Hugs     _______________________________________________

 
  This is the Hugs 98 Standard Prelude, based very closely on the Standard
  Prelude for Haskell 98.
 
  This is the Hugs 98 Standard Prelude, based very closely on the Standard
  Prelude for Haskell 98.

@@ -60,7 +60,7 @@ module Prelude (
 --  module Ratio,
     Ratio, Rational, (%), numerator, denominator, approxRational,
 --  Non-standard exports
 --  module Ratio,
     Ratio, Rational, (%), numerator, denominator, approxRational,
 --  Non-standard exports

-    IO(..), IOResult(..), Addr, StablePtr,
+    IO, IOResult(..), Addr, StablePtr,

     makeStablePtr, freeStablePtr, deRefStablePtr,
 
     Bool(False, True),
     makeStablePtr, freeStablePtr, deRefStablePtr,
 
     Bool(False, True),

@@ -102,49 +102,6 @@ module Prelude (
     asTypeOf, error, undefined,
     seq, ($!)
 
     asTypeOf, error, undefined,
     seq, ($!)
 

-    , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
-    , ThreadId, forkIO
-    , trace
-
-
-    , ST(..)
-    , STRef, newSTRef, readSTRef, writeSTRef
-    , IORef, newIORef, readIORef, writeIORef
-    , PrimMutableArray, PrimMutableByteArray
-    , RealWorld
-
-    -- This lot really shouldn't be exported, but are needed to
-    -- implement various libs.
-    , runST , fixST, unsafeInterleaveST 
-    , stToIO , ioToST
-    , unsafePerformIO
-    , primReallyUnsafePtrEquality
-    ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
-    ,primReadArray, primIndexArray, primSizeMutableArray
-    ,primSizeArray
-    ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
-    ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
-    ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
-    ,unsafeInterleaveIO,nh_write,primCharToInt,
-    nullAddr, incAddr, isNullAddr, 
-    nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
-    nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
-
-    Word,
-    primGtWord, primGeWord, primEqWord, primNeWord,
-    primLtWord, primLeWord, primMinWord, primMaxWord,
-    primPlusWord, primMinusWord, primTimesWord, primQuotWord,
-    primRemWord, primQuotRemWord, primNegateWord, primAndWord,
-    primOrWord, primXorWord, primNotWord, primShiftLWord,
-    primShiftRAWord, primShiftRLWord, primIntToWord, primWordToInt,
-
-    primAndInt, primOrInt, primXorInt, primNotInt,
-    primShiftLInt, primShiftRAInt,  primShiftRLInt,
-
-    primAddrToInt, primIntToAddr,
-
-    primDoubleToFloat, primFloatToDouble,
-

   ) where
 
 -- Standard value bindings {Prelude} ----------------------------------------
   ) where
 
 -- Standard value bindings {Prelude} ----------------------------------------

@@ -1576,7 +1533,7 @@ hugsprimPmFail        = error "Pattern Match Failure"
 -- contains a version used in combined mode.  That version takes care of
 -- switching between the GHC and Hugs IO representations, which are different.
 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
 -- contains a version used in combined mode.  That version takes care of
 -- switching between the GHC and Hugs IO representations, which are different.
 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a

-hugsprimMkIO = ST
+hugsprimMkIO = IO

 
 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
 hugsprimCreateAdjThunk fun typestr callconv
 
 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
 hugsprimCreateAdjThunk fun typestr callconv

@@ -1637,7 +1594,7 @@ userError s = primRaise (ErrorCall s)
 
 catch :: IO a -> (IOError -> IO a) -> IO a
 catch m k 
 
 catch :: IO a -> (IOError -> IO a) -> IO a
 catch m k 

-  = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
+  = IO (\s -> unIO m s `primCatch` \ err -> unIO (k (e2ioe err)) s)

     where
        e2ioe (IOExcept s) = IOError s
        e2ioe other        = IOError (show other)
     where
        e2ioe (IOExcept s) = IOError s
        e2ioe other        = IOError (show other)

@@ -1658,11 +1615,9 @@ print :: Show a => a -> IO ()
 print = putStrLn . show
 
 getChar :: IO Char
 print = putStrLn . show
 
 getChar :: IO Char

-getChar = unsafeInterleaveIO (
-          nh_stdin  >>= \h -> 
+getChar = nh_stdin  >>= \h -> 

           nh_read h >>= \ci -> 
           return (primIntToChar ci)
           nh_read h >>= \ci -> 
           return (primIntToChar ci)

-          )

 
 getLine :: IO String
 getLine    = do c <- getChar
 
 getLine :: IO String
 getLine    = do c <- getChar

@@ -1818,21 +1773,17 @@ primGetEnv v
 
 
 ------------------------------------------------------------------------------
 
 
 ------------------------------------------------------------------------------

--- ST, IO --------------------------------------------------------------------
+-- ST ------------------------------------------------------------------------

 ------------------------------------------------------------------------------
 
 newtype ST s a = ST (s -> (a,s))
 ------------------------------------------------------------------------------
 
 newtype ST s a = ST (s -> (a,s))

-
-primRunST :: ST RealWorld a -> a
-primRunST m = fst (unST m theWorld)
-   where
-      theWorld :: RealWorld
-      theWorld = error "primRunST: entered the RealWorld"
+unST (ST a) = a
+data RealWorld

 
 runST :: (__forall s . ST s a) -> a
 runST m = fst (unST m alpha)
    where
 
 runST :: (__forall s . ST s a) -> a
 runST m = fst (unST m alpha)
    where

-      alpha = error "primRunST: entered the RealWorld"
+      alpha = error "runST: entered the RealWorld"

 
 fixST :: (a -> ST s a) -> ST s a
 fixST m = ST (\ s -> 
 
 fixST :: (a -> ST s a) -> ST s a
 fixST m = ST (\ s -> 

@@ -1841,30 +1792,43 @@ fixST m = ST (\ s ->
                in
                   (r,s))
 
                in
                   (r,s))
 

-unST (ST a) = a
+instance Functor (ST s) where
+   fmap f x  = x >>= (return . f)

 
 

-data RealWorld
--- Should IO not be abstract? 
--- Is "instance (IO a)" allowed, for example ?
-type IO a = ST RealWorld a
+instance Monad (ST s) where
+   m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
+   return x  = ST (\s -> (x,s))
+   m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
+
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
+
+------------------------------------------------------------------------------
+-- IO ------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+newtype IO a = IO (RealWorld -> (a,RealWorld))
+unIO (IO a) = a

 
 stToIO       :: ST RealWorld a -> IO a
 
 stToIO       :: ST RealWorld a -> IO a

-stToIO = id
+stToIO (ST fn) = IO fn

 
 ioToST       :: IO a -> ST RealWorld a
 
 ioToST       :: IO a -> ST RealWorld a

-ioToST = id
+ioToST (IO fn) = ST fn

 
 unsafePerformIO :: IO a -> a
 
 unsafePerformIO :: IO a -> a

-unsafePerformIO m = primRunST (ioToST m)
+unsafePerformIO m = fst (unIO m theWorld)
+   where
+      theWorld :: RealWorld
+      theWorld = error "unsafePerformIO: entered the RealWorld"

 
 

-instance Functor (ST s) where
+instance Functor IO where

    fmap f x  = x >>= (return . f)
 
    fmap f x  = x >>= (return . f)
 

-instance Monad (ST s) where
-   m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
-   return x  = ST (\s -> (x,s))
-   m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
-
+instance Monad IO where
+   m >> k    = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
+   return x  = IO (\s -> (x,s))
+   m >>= k   = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })

 
 -- Library IO has a global variable which accumulates Handles
 -- as they are opened.  We keep here a second global variable
 
 -- Library IO has a global variable which accumulates Handles
 -- as they are opened.  We keep here a second global variable

@@ -1874,12 +1838,12 @@ instance Monad (ST s) where
 -- Doing it like this means the Prelude does not have to know
 -- anything about the grotty details of the Handle implementation.
 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
 -- Doing it like this means the Prelude does not have to know
 -- anything about the grotty details of the Handle implementation.
 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))

-prelCleanupAfterRunAction = primRunST (newIORef Nothing)
+prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)

 
 -- used when Hugs invokes top level function
 hugsprimRunIO_toplevel :: IO a -> ()
 hugsprimRunIO_toplevel m
 
 -- used when Hugs invokes top level function
 hugsprimRunIO_toplevel :: IO a -> ()
 hugsprimRunIO_toplevel m

-   = protect 5 (fst (unST composite_action realWorld))
+   = protect 5 (fst (unIO composite_action realWorld))

      where
         composite_action
            = do writeIORef prelCleanupAfterRunAction Nothing
      where
         composite_action
            = do writeIORef prelCleanupAfterRunAction Nothing

@@ -1895,20 +1859,10 @@ hugsprimRunIO_toplevel m
            = comp
         protect n comp
            = primCatch (protect (n-1) comp)
            = comp
         protect n comp
            = primCatch (protect (n-1) comp)

-                       (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
-
-trace, trace_quiet :: String -> a -> a
-trace s x
-   = trace_quiet ("trace: " ++ s) x
-trace_quiet s x
-   = (primRunST (putStr (s ++ "\n"))) `seq` x
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
+                       (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))

 
 unsafeInterleaveIO :: IO a -> IO a
 
 unsafeInterleaveIO :: IO a -> IO a

-unsafeInterleaveIO = unsafeInterleaveST
-
+unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))

 
 ------------------------------------------------------------------------------
 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
 
 ------------------------------------------------------------------------------
 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------

@@ -1966,13 +1920,13 @@ readSTRef   = primReadRef
 writeSTRef :: STRef s a -> a -> ST s ()
 writeSTRef  = primWriteRef
 
 writeSTRef :: STRef s a -> a -> ST s ()
 writeSTRef  = primWriteRef
 

-type IORef a = STRef RealWorld a
+newtype IORef a = IORef (STRef RealWorld a)

 newIORef   :: a -> IO (IORef a)
 newIORef   :: a -> IO (IORef a)

-newIORef    = primNewRef
+newIORef   a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))

 readIORef  :: IORef a -> IO a
 readIORef  :: IORef a -> IO a

-readIORef   = primReadRef
+readIORef  (IORef ref) = stToIO (primReadRef ref)

 writeIORef :: IORef a -> a -> IO ()
 writeIORef :: IORef a -> a -> IO ()

-writeIORef  = primWriteRef
+writeIORef  (IORef ref) a = stToIO (primWriteRef ref a)

 
 
 ------------------------------------------------------------------------------
 
 
 ------------------------------------------------------------------------------

@@ -1989,7 +1943,7 @@ putMVar = primPutMVar
 
 takeMVar :: MVar a -> IO a
 takeMVar m
 
 takeMVar :: MVar a -> IO a
 takeMVar m

-   = ST (\world -> primTakeMVar m cont world)
+   = IO (\world -> primTakeMVar m cont world)

      where
         -- cont :: a -> RealWorld -> (a,RealWorld)
         -- where 'a' is as in the top-level signature
      where
         -- cont :: a -> RealWorld -> (a,RealWorld)
         -- where 'a' is as in the top-level signature

@@ -2048,17 +2002,19 @@ instance Ord ThreadId where
 forkIO :: IO a -> IO ThreadId
 -- Simple version; doesn't catch exceptions in computation
 -- forkIO computation 
 forkIO :: IO a -> IO ThreadId
 -- Simple version; doesn't catch exceptions in computation
 -- forkIO computation 

---    = primForkIO (primRunST computation)
+--    = primForkIO (unsafePerformIO computation)

 
 forkIO computation
    = primForkIO (
         primCatch
 
 forkIO computation
    = primForkIO (
         primCatch

-           (unST computation realWorld `primSeq` ())
+           (unIO computation realWorld `primSeq` ())

            (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
      )
      where
         realWorld = error "primForkIO: entered the RealWorld"
 
            (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
      )
      where
         realWorld = error "primForkIO: entered the RealWorld"
 

+trace_quiet s x
+   = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x

 
 -- showFloat ------------------------------------------------------------------
 
 
 -- showFloat ------------------------------------------------------------------