2 % (c) The AQUA Project, Glasgow University, 1994-2000
6 {-# OPTIONS -fno-implicit-prelude #-}
13 hugsprimPmFromInteger,
16 hugsprimRunIO_toplevel,
20 hugsprimCreateAdjThunk,
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)
43 import PrelPack(unpackCString)
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.
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
54 = error "hugsprimMkIO in combined mode: unimplemented"
56 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
57 hugsprimCreateAdjThunk fun typestr callconv
58 = error "hugsprimCreateAdjThunk in combined mode: unimplemented"
60 fromDouble :: Fractional a => Double -> a
61 fromDouble n = fromRational (toRational n)
63 hugsprimEqChar :: Char -> Char -> Bool
64 hugsprimEqChar c1 c2 = c1 == c2
66 hugsprimPmInt :: Num a => Int -> a -> Bool
67 hugsprimPmInt n x = fromInt n == x
69 hugsprimPmInteger :: Num a => Integer -> a -> Bool
70 hugsprimPmInteger n x = fromInteger n == x
72 hugsprimPmDouble :: Fractional a => Double -> a -> Bool
73 hugsprimPmDouble n x = fromDouble n == x
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
79 hugsprimPmFromInteger :: Integral a => Integer -> a
80 hugsprimPmFromInteger = fromIntegral
82 hugsprimPmSubtract :: Integral a => a -> a -> a
83 hugsprimPmSubtract x y = x - y
85 hugsprimPmLe :: Integral a => a -> a -> Bool
86 hugsprimPmLe x y = x <= y
88 hugsprimUnpackString :: Addr -> String
89 hugsprimUnpackString a = unpackCString a
91 -- ToDo: make the message more informative.
93 hugsprimPmFail = error "Pattern Match Failure"
95 hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
96 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
98 hugsprimError :: String -> a
99 hugsprimError s = error s
101 hugsprimShowField :: Show a => String -> a -> ShowS
102 hugsprimShowField m v = showString m . showChar '=' . shows v
104 hugsprimReadField :: Read a => String -> ReadS a
105 hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
110 -- used when Hugs invokes top level function
112 hugsprimRunIO_toplevel :: IO a -> ()
113 hugsprimRunIO_toplevel m
114 = protect 5 (fst (unST composite_action realWorld))
117 = do writeIORef prelCleanupAfterRunAction Nothing
119 cleanup_handles <- readIORef prelCleanupAfterRunAction
120 case cleanup_handles of
124 realWorld = error "primRunIO: entered the RealWorld"
125 protect :: Int -> () -> ()
129 = primCatch (protect (n-1) comp)
130 (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
133 hugsprimRunIO_toplevel :: IO a -> ()
134 hugsprimRunIO_toplevel m
136 catchException (m >> hFlush stderr >> hFlush stdout)
137 (\e -> putStr ("error: " ++ show e ++ "\n"))