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    hugsprimUnpackString,
  22    hugsprimPmFail,
  23    hugsprimCompAux,
  24    hugsprimError
  25 )
  26 where
  27 import PrelGHC
  28 import PrelBase
  29 import PrelNum
  30 import PrelReal(Integral)
  31 import Prelude(fromIntegral)
  32 import IO(putStr,hFlush,stdout,stderr)
  33 import PrelException(catch)
  34 import PrelIOBase(IO,unsafePerformIO)
  35 import PrelShow(show)
  36 import PrelFloat(Double)
  37 import PrelReal(Fractional,fromRational,toRational)
  38 import PrelAddr(Addr)
  39 import PrelErr(error)
  40 import PrelPack(unpackCString)
  41
  42 -- Stuff needed by Hugs for desugaring.  Do not mess with these!
  43 -- They need to correspond exactly to versions written in
  44 -- the Hugs standalone Prelude.
  45
  46 --hugs doesn't know about RealWorld and so throws this
  47 --away if the original type signature is used
  48 --hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
  49 hugsprimMkIO :: (rw -> (a,rw)) -> IO a
  50 hugsprimMkIO
  51    = error "hugsprimMkIO in combined mode: unimplemented"
  52
  53 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
  54 hugsprimCreateAdjThunk fun typestr callconv
  55    = error "hugsprimCreateAdjThunk in combined mode: unimplemented"
  56
  57 fromDouble :: Fractional a => Double -> a
  58 fromDouble n = fromRational (toRational n)
  59
  60 hugsprimEqChar       :: Char -> Char -> Bool
  61 hugsprimEqChar c1 c2  = c1 == c2
  62
  63 hugsprimPmInt        :: Num a => Int -> a -> Bool
  64 hugsprimPmInt n x     = fromInt n == x
  65
  66 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
  67 hugsprimPmInteger n x = fromInteger n == x
  68
  69 hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
  70 hugsprimPmDouble n x  = fromDouble n == x
  71
  72 -- The following primitives are only needed if (n+k) patterns are enabled:
  73 hugsprimPmSub           :: Integral a => Int -> a -> a
  74 hugsprimPmSub n x        = x - fromInt n
  75
  76 hugsprimPmFromInteger   :: Integral a => Integer -> a
  77 hugsprimPmFromInteger    = fromIntegral
  78
  79 hugsprimPmSubtract      :: Integral a => a -> a -> a
  80 hugsprimPmSubtract x y   = x - y
  81
  82 hugsprimPmLe            :: Integral a => a -> a -> Bool
  83 hugsprimPmLe x y         = x <= y
  84
  85 hugsprimUnpackString :: Addr -> String
  86 hugsprimUnpackString a = unpackCString a
  87
  88 -- ToDo: make the message more informative.
  89 hugsprimPmFail       :: a
  90 hugsprimPmFail        = error "Pattern Match Failure"
  91
  92 hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
  93 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
  94
  95 hugsprimError        :: String -> a
  96 hugsprimError s       = error s
  97
  98 -- used when Hugs invokes top level function
  99 {-
 100 hugsprimRunIO_toplevel :: IO a -> ()
 101 hugsprimRunIO_toplevel m
 102    = protect 5 (fst (unST composite_action realWorld))
 103      where
 104         composite_action
 105            = do writeIORef prelCleanupAfterRunAction Nothing
 106                 m
 107                 cleanup_handles <- readIORef prelCleanupAfterRunAction
 108                 case cleanup_handles of
 109                    Nothing -> return ()
 110                    Just xx -> xx
 111
 112         realWorld = error "primRunIO: entered the RealWorld"
 113         protect :: Int -> () -> ()
 114         protect 0 comp
 115            = comp
 116         protect n comp
 117            = primCatch (protect (n-1) comp)
 118                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
 119 -}
 120 hugsprimRunIO_toplevel :: IO a -> ()
 121 hugsprimRunIO_toplevel m
 122    = unsafePerformIO (
 123         catch (m >> hFlush stderr >> hFlush stdout)
 124               (\e -> putStr (show e ++ "\n"))
 125      )
 126
 127
 128 \end{code}