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