PrelHugs.lhs 3.39 KB
Newer Older
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,
20
   hugsprimCreateAdjThunk,
21
22
   hugsprimUnpackString,
   hugsprimPmFail
23
24
25
26
27
28
29
)
where
import PrelGHC
import PrelBase
import PrelNum
import PrelReal(Integral)
import Prelude(fromIntegral)
30
import IO(putStr,hFlush,stdout,stderr)
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)
38
import PrelPack(unpackCString)
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

83
84
85
hugsprimUnpackString :: Addr -> String
hugsprimUnpackString a = unpackCString a

86
87
88
89
-- ToDo: make the message more informative.
hugsprimPmFail       :: a
hugsprimPmFail        = error "Pattern Match Failure"

90

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 (
116
        catch (m >> hFlush stderr >> hFlush stdout)
117
118
119
              (\e -> putStr (show e ++ "\n"))
     )

120

121
\end{code}