[project @ 2000-03-09 06:14:38 by andy]

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

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index ce05049..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),

@@ -84,8 +84,7 @@ module Prelude (
     Real(toRational),
 --  Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
     Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
     Real(toRational),
 --  Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
     Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),

---  Fractional((/), recip, fromRational),
-    Fractional((/), recip, fromRational, fromDouble),
+    Fractional((/), recip, fromRational), fromDouble,

     Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
              asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
     RealFrac(properFraction, truncate, round, ceiling, floor),
     Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
              asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
     RealFrac(properFraction, truncate, round, ceiling, floor),

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

-    , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
-    , ThreadId, forkIO
-    ,trace
-
-    , STRef, newSTRef, readSTRef, writeSTRef
-    , IORef, newIORef, readIORef, writeIORef
-
-    -- This lot really shouldn't be exported, but are needed to
-    -- implement various libs.
-    ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
-    ,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} ----------------------------------------

@@ -227,13 +193,13 @@ class (Num a) => Fractional a where
     (/)          :: a -> a -> a
     recip        :: a -> a
     fromRational :: Rational -> a
     (/)          :: a -> a -> a
     recip        :: a -> a
     fromRational :: Rational -> a

-    fromDouble   :: Double -> a

 
     -- Minimal complete definition: fromRational and ((/) or recip)
     recip x       = 1 / x
 
     -- Minimal complete definition: fromRational and ((/) or recip)
     recip x       = 1 / x

-    fromDouble    = fromRational . toRational

     x / y         = x * recip y
 
     x / y         = x * recip y
 

+fromDouble :: Fractional a => Double -> a
+fromDouble n = fromRational (toRational n)

 
 class (Fractional a) => Floating a where
     pi                  :: a
 
 class (Fractional a) => Floating a where
     pi                  :: a

@@ -632,7 +598,7 @@ instance Ord a => Ord [a] where
     compare []     (_:_)  = LT
     compare []     []     = EQ
     compare (_:_)  []     = GT
     compare []     (_:_)  = LT
     compare []     []     = EQ
     compare (_:_)  []     = GT

-    compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
+    compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)

 
 instance Functor [] where
     fmap = map
 
 instance Functor [] where
     fmap = map

@@ -851,13 +817,10 @@ realFloatToRational x = (m%1)*(b%1)^^n
 instance Fractional Float where
     (/)           = primDivideFloat
     fromRational  = rationalToRealFloat
 instance Fractional Float where
     (/)           = primDivideFloat
     fromRational  = rationalToRealFloat

-    fromDouble    = primDoubleToFloat
-

 
 instance Fractional Double where
     (/)          = primDivideDouble
     fromRational = rationalToRealFloat
 
 instance Fractional Double where
     (/)          = primDivideDouble
     fromRational = rationalToRealFloat

-    fromDouble x = x

 
 rationalToRealFloat x = x'
  where x'    = f e
 
 rationalToRealFloat x = x'
  where x'    = f e

@@ -1039,7 +1002,6 @@ instance Integral a => Fractional (Ratio a) where
     (x:%y) / (x':%y')   = (x*y') % (y*x')
     recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
     fromRational (x:%y) = fromInteger x :% fromInteger y
     (x:%y) / (x':%y')   = (x*y') % (y*x')
     recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
     fromRational (x:%y) = fromInteger x :% fromInteger y

-    fromDouble                 = doubleToRatio

 
 -- Hugs optimises code of the form fromRational (doubleToRatio x)
 doubleToRatio :: Integral a => Double -> Ratio a
 
 -- Hugs optimises code of the form fromRational (doubleToRatio x)
 doubleToRatio :: Integral a => Double -> Ratio a

@@ -1337,8 +1299,8 @@ showString    = (++)
 showParen    :: Bool -> ShowS -> ShowS
 showParen b p = if b then showChar '(' . p . showChar ')' else p
 
 showParen    :: Bool -> ShowS -> ShowS
 showParen b p = if b then showChar '(' . p . showChar ')' else p
 

-showField    :: Show a => String -> a -> ShowS
-showField m v = showString m . showChar '=' . shows v
+hugsprimShowField    :: Show a => String -> a -> ShowS
+hugsprimShowField m v = showString m . showChar '=' . shows v

 
 readParen    :: Bool -> ReadS a -> ReadS a
 readParen b g = if b then mandatory else optional
 
 readParen    :: Bool -> ReadS a -> ReadS a
 readParen b g = if b then mandatory else optional

@@ -1348,10 +1310,10 @@ readParen b g = if b then mandatory else optional
                                             (")",u) <- lex t    ]
 
 
                                             (")",u) <- lex t    ]
 
 

-readField    :: Read a => String -> ReadS a
-readField m s0 = [ r | (t,  s1) <- lex s0, t == m,
-                       ("=",s2) <- lex s1,
-                       r        <- reads s2 ]
+hugsprimReadField    :: Read a => String -> ReadS a
+hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
+                               ("=",s2) <- lex s1,
+                               r        <- reads s2 ]

 
 lex                    :: ReadS String
 lex ""                  = [("","")]
 
 lex                    :: ReadS String
 lex ""                  = [("","")]

@@ -1545,8 +1507,11 @@ readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
 -- Hooks for primitives: -----------------------------------------------------
 -- Do not mess with these!
 
 -- Hooks for primitives: -----------------------------------------------------
 -- Do not mess with these!
 

-primCompAux      :: Ord a => a -> a -> Ordering -> Ordering
-primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
+hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
+hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
+
+hugsprimEqChar       :: Char -> Char -> Bool
+hugsprimEqChar c1 c2  = primEqChar c1 c2

 
 hugsprimPmInt        :: Num a => Int -> a -> Bool
 hugsprimPmInt n x     = fromInt n == x
 
 hugsprimPmInt        :: Num a => Int -> a -> Bool
 hugsprimPmInt n x     = fromInt n == x

@@ -1554,16 +1519,21 @@ hugsprimPmInt n x     = fromInt n == x
 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
 hugsprimPmInteger n x = fromInteger n == x
 
 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
 hugsprimPmInteger n x = fromInteger n == x
 

-primPmDouble     :: Fractional a => Double -> a -> Bool
-primPmDouble n x  = fromDouble n == x
+hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
+hugsprimPmDouble n x  = fromDouble n == x

 
 -- ToDo: make the message more informative.
 
 -- ToDo: make the message more informative.

-primPmFail       :: a
-primPmFail        = error "Pattern Match Failure"
+hugsprimPmFail       :: a
+hugsprimPmFail        = error "Pattern Match Failure"

 
 -- used in desugaring Foreign functions
 
 -- used in desugaring Foreign functions

+-- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
+-- bit of code of type   RealWorld -> (a,RealWorld)   into a proper IO value.
+-- What follows is the version for standalone mode.  ghc/lib/std/PrelHugs.lhs
+-- 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 :: (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

@@ -1590,8 +1560,8 @@ hugsprimPmLe x y         = x <= y
 -- 
 -- ToDo: change this (and Hugs code generator) to use ByteArrays
 
 -- 
 -- ToDo: change this (and Hugs code generator) to use ByteArrays
 

-primUnpackString :: Addr -> String
-primUnpackString a = unpack 0
+hugsprimUnpackString :: Addr -> String
+hugsprimUnpackString a = unpack 0

  where
   -- The following decoding is based on evalString in the old machine.c
   unpack i
  where
   -- The following decoding is based on evalString in the old machine.c
   unpack i

@@ -1624,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)

@@ -1645,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

@@ -1798,29 +1766,31 @@ primGetEnv v
      nh_getenv ptr                >>= \ptr2 ->
      nh_free ptr                  >>
      if   isNullAddr ptr2
      nh_getenv ptr                >>= \ptr2 ->
      nh_free ptr                  >>
      if   isNullAddr ptr2

-     then return []
+     then ioError (IOError "getEnv failed")

      else
      copy_cstring_to_String ptr2  >>= \result ->
      return result
 
 
 ------------------------------------------------------------------------------
      else
      copy_cstring_to_String ptr2  >>= \result ->
      return result
 
 
 ------------------------------------------------------------------------------

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

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

-
+unST (ST a) = a

 data RealWorld
 data RealWorld

-type IO a = ST RealWorld a

 
 

---primRunST :: (forall s. ST s a) -> a
-primRunST :: ST RealWorld a -> a
-primRunST m = fst (unST m theWorld)
+runST :: (__forall s . ST s a) -> a
+runST m = fst (unST m alpha)

    where
    where

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

 
 

-unST (ST a) = a
+fixST :: (a -> ST s a) -> ST s a
+fixST m = ST (\ s -> 
+               let 
+                  (r,s) = unST (m r) s
+               in
+                  (r,s))

 
 instance Functor (ST s) where
    fmap f x  = x >>= (return . f)
 
 instance Functor (ST s) where
    fmap f x  = x >>= (return . f)

@@ -1830,6 +1800,35 @@ instance Monad (ST s) where
    return x  = ST (\s -> (x,s))
    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) 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 fn) = IO fn
+
+ioToST       :: IO a -> ST RealWorld a
+ioToST (IO fn) = ST fn
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO m = fst (unIO m theWorld)
+   where
+      theWorld :: RealWorld
+      theWorld = error "unsafePerformIO: entered the RealWorld"
+
+instance Functor IO where
+   fmap f x  = x >>= (return . f)
+
+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

@@ -1839,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

@@ -1860,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 -----------------------------------------

@@ -1931,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)

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

@@ -1954,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

@@ -2013,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 ------------------------------------------------------------------