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