PrelHugs.lhs 3.63 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
   hugsprimUnpackString,
22
23
24
   hugsprimPmFail,
   hugsprimCompAux,
   hugsprimError
25
26
27
28
29
30
31
)
where
import PrelGHC
import PrelBase
import PrelNum
import PrelReal(Integral)
import Prelude(fromIntegral)
32
import IO(putStr,hFlush,stdout,stderr)
33
34
35
36
37
38
39
import PrelException(catch)
import PrelIOBase(IO,unsafePerformIO)
import PrelShow(show)
import PrelFloat(Double)
import PrelReal(Fractional,fromRational,toRational)
import PrelAddr(Addr)
import PrelErr(error)
40
import PrelPack(unpackCString)
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
83
84

-- 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

85
86
87
hugsprimUnpackString :: Addr -> String
hugsprimUnpackString a = unpackCString a

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

92
93
94
95
96
hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT

hugsprimError        :: String -> a
hugsprimError s       = error s
97

98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
-- 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 (
123
        catch (m >> hFlush stderr >> hFlush stdout)
124
125
126
              (\e -> putStr (show e ++ "\n"))
     )

127

128
\end{code}