ghc/lib/std/PrelHugs.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-2000
   3 %
   4
   5 \begin{code}
   6 {-# OPTIONS -fno-implicit-prelude #-}
   7
   8 module PrelHugs (
   9    hugsprimPmInt,
  10    hugsprimPmInteger,
  11    hugsprimPmDouble,
  12    hugsprimPmSub,
  13    hugsprimPmFromInteger,
  14    hugsprimPmSubtract,
  15    hugsprimPmLe,
  16    hugsprimRunIO_toplevel,
  17    hugsprimEqChar,
  18    fromDouble,
  19    hugsprimMkIO,
  20    hugsprimCreateAdjThunk
  21 )
  22 where
  23 import PrelGHC
  24 import PrelBase
  25 import PrelNum
  26 import PrelReal(Integral)
  27 import Prelude(fromIntegral)
  28 import IO(putStr)
  29 import PrelException(catch)
  30 import PrelIOBase(IO,unsafePerformIO)
  31 import PrelShow(show)
  32 import PrelFloat(Double)
  33 import PrelReal(Fractional,fromRational,toRational)
  34 import PrelAddr(Addr)
  35 import PrelErr(error)
  36
  37 -- Stuff needed by Hugs for desugaring.  Do not mess with these!
  38 -- They need to correspond exactly to versions written in
  39 -- the Hugs standalone Prelude.
  40
  41 --hugs doesn't know about RealWorld and so throws this
  42 --away if the original type signature is used
  43 --hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
  44 hugsprimMkIO :: (rw -> (a,rw)) -> IO a
  45 hugsprimMkIO
  46    = error "hugsprimMkIO in combined mode: unimplemented"
  47
  48 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
  49 hugsprimCreateAdjThunk fun typestr callconv
  50    = error "hugsprimCreateAdjThunk in combined mode: unimplemented"
  51
  52 fromDouble :: Fractional a => Double -> a
  53 fromDouble n = fromRational (toRational n)
  54
  55 hugsprimEqChar       :: Char -> Char -> Bool
  56 hugsprimEqChar c1 c2  = c1 == c2
  57
  58 hugsprimPmInt        :: Num a => Int -> a -> Bool
  59 hugsprimPmInt n x     = fromInt n == x
  60
  61 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
  62 hugsprimPmInteger n x = fromInteger n == x
  63
  64 hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
  65 hugsprimPmDouble n x  = fromDouble n == x
  66
  67 -- The following primitives are only needed if (n+k) patterns are enabled:
  68 hugsprimPmSub           :: Integral a => Int -> a -> a
  69 hugsprimPmSub n x        = x - fromInt n
  70
  71 hugsprimPmFromInteger   :: Integral a => Integer -> a
  72 hugsprimPmFromInteger    = fromIntegral
  73
  74 hugsprimPmSubtract      :: Integral a => a -> a -> a
  75 hugsprimPmSubtract x y   = x - y
  76
  77 hugsprimPmLe            :: Integral a => a -> a -> Bool
  78 hugsprimPmLe x y         = x <= y
  79
  80 -- used when Hugs invokes top level function
  81 {-
  82 hugsprimRunIO_toplevel :: IO a -> ()
  83 hugsprimRunIO_toplevel m
  84    = protect 5 (fst (unST composite_action realWorld))
  85      where
  86         composite_action
  87            = do writeIORef prelCleanupAfterRunAction Nothing
  88                 m
  89                 cleanup_handles <- readIORef prelCleanupAfterRunAction
  90                 case cleanup_handles of
  91                    Nothing -> return ()
  92                    Just xx -> xx
  93
  94         realWorld = error "primRunIO: entered the RealWorld"
  95         protect :: Int -> () -> ()
  96         protect 0 comp
  97            = comp
  98         protect n comp
  99            = primCatch (protect (n-1) comp)
 100                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
 101 -}
 102 hugsprimRunIO_toplevel :: IO a -> ()
 103 hugsprimRunIO_toplevel m
 104    = unsafePerformIO (
 105         catch (m >> return ())
 106               (\e -> putStr (show e ++ "\n"))
 107      )
 108
 109 \end{code}