Ticket #1947: Main_.hs

File Main_.hs, 13.0 KB (added by NeilMitchell, 5 years ago)
Line 
1{-# OPTIONS_GHC -fffi -fglasgow-exts -cpp -pgmPcpphs -optP--cpp #-}
2
3module Main(main) where
4
5import System.IO.Unsafe
6import System.IO
7import System.Environment
8import System.Exit
9import Foreign.C.Types
10import Data.Char(ord,chr)
11
12
13-- low level imports
14import GHC.Base                 (realWorld#)
15import GHC.IOBase               (IO(IO), unIO, unsafePerformIO)
16import GHC.Prim                 (State#,RealWorld)
17
18
19-- FFI replacements for Haskell stuff
20foreign import ccall unsafe "stdio.h getchar" getchar :: IO CInt
21foreign import ccall unsafe "ctype.h iswspace" isspace :: CInt -> CInt
22
23
24-- CAF removal stuff
25{-
26-- Not allowed by GHC, so use the CPP
27argCAF :: State# RealWorld
28argCAF = realWorld#
29-}
30#define argCAF realWorld#
31
32skipCAF :: State# RealWorld -> a -> a
33skipCAF _ x = x
34
35
36-- IO Subsystem
37-- Unboxed IO is more efficient, but requires a certain level of
38-- optimisation, so provide a BOXED_IO fallback
39
40#if 1 || defined(BOXED_IO)
41
42data RW_Box = RW_Box (State# RealWorld)
43type RW_Pair a = (RW_Box, a)
44
45fromIO :: IO a -> (RW_Box -> RW_Pair a)
46fromIO a (RW_Box r) = case unIO a r of (# r, x #) -> (RW_Box r, x)
47
48toIO :: (RW_Box -> RW_Pair a) -> IO a
49toIO f = IO $ \r -> case f (RW_Box r) of (RW_Box r, x) -> (# r, x #)
50
51#define PAIR_WORLD0     (,)
52#define PAIR_WORLD(a,b) (a, b)
53#define WORLD (RW_Box realWorld#)
54
55#else
56
57type RW_Box = State# RealWorld
58type RW_Pair a = (# RW_Box, a #)
59
60fromIO :: IO a -> (RW_Box -> RW_Pair a)
61fromIO = unIO
62
63toIO :: (RW_Box -> RW_Pair a) -> IO a
64toIO = IO
65
66#define PAIR_WORLD0 (error "INVALID, PAIR_WORLD0 disallowed with unboxed IO")
67#define PAIR_WORLD(a,b) (# a :: State# RealWorld, b #)
68#define WORLD realWorld#
69
70#endif
71
72
73-- IO functions not dependent on the IO primitives
74main :: IO ()
75main = toIO main_generated
76
77typeRealWorld :: RW_Box -> RW_Box
78typeRealWorld x = x
79
80overlay_get_char :: RW_Box -> RW_Pair Int
81overlay_get_char = fromIO $ do
82    c <- getchar
83    return $ fromIntegral c
84
85system_IO_hPutChar :: Handle -> Int -> RW_Box -> RW_Pair ()
86system_IO_hPutChar h c = fromIO $ hPutChar h (chr c)
87
88overlay_errorIO :: [Int] -> RW_Box -> RW_Pair a
89overlay_errorIO x r = case fromIO (putStrLn ("ERROR: " ++ map chr x)) r of
90                           PAIR_WORLD(r, _) -> fromIO exitFailure r
91
92system_Environment_getArgs :: RW_Box -> RW_Pair [[Int]]
93system_Environment_getArgs r = case (fromIO getArgs) r of
94                                    PAIR_WORLD(r, s) -> PAIR_WORLD(r, map str_ s)
95
96overlay_supero_wrap x = x
97
98
99-- Primitives
100prelude_seq = seq
101
102prelude_error x = error (map chr x)
103
104aDD_W = (+) :: Int -> Int -> Int
105mUL_W = (*) :: Int -> Int -> Int
106sUB_W = (-) :: Int -> Int -> Int
107eQ_W = (==) :: Int -> Int -> Bool
108nE_W = (/=) :: Int -> Int -> Bool
109gT_W = (>) :: Int -> Int -> Bool
110gE_W = (>=) :: Int -> Int -> Bool
111lT_W = (<) :: Int -> Int -> Bool
112lE_W = (<=) :: Int -> Int -> Bool
113qUOT = quot :: Int -> Int -> Int
114rEM = rem :: Int -> Int -> Int
115nEG_W = negate :: Int -> Int
116yHC_Primitive_primIntAbs = abs :: Int -> Int
117yHC_Primitive_primIntSignum = signum :: Int -> Int
118yHC_Primitive_primIntegerAdd = (+) :: Integer -> Integer -> Integer
119yHC_Primitive_primIntegerEq = (==) :: Integer -> Integer -> Bool
120yHC_Primitive_primIntegerFromInt = toInteger :: Int -> Integer
121yHC_Primitive_primIntegerGe = (>=) :: Integer -> Integer -> Bool
122yHC_Primitive_primIntegerGt = (>) :: Integer -> Integer -> Bool
123yHC_Primitive_primIntegerLe = (<=) :: Integer -> Integer -> Bool
124yHC_Primitive_primIntegerMul = (*) :: Integer -> Integer -> Integer
125yHC_Primitive_primIntegerNe = (/=) :: Integer -> Integer -> Bool
126yHC_Primitive_primIntegerNeg = negate :: Integer -> Integer
127yHC_Primitive_primIntegerQuot = quot :: Integer -> Integer -> Integer
128yHC_Primitive_primIntegerQuotRem = quotRem :: Integer -> Integer -> (Integer, Integer)
129yHC_Primitive_primIntegerRem = rem :: Integer -> Integer -> Integer
130yHC_Primitive_primIntFromInteger = fromInteger :: Integer -> Int
131yHC_Primitive_primIntegerLt = (<) :: Integer -> Integer -> Bool
132yHC_Primitive_primIntegerSub = (-) :: Integer -> Integer -> Integer
133
134aDD_D = (+) :: Double -> Double -> Double
135sUB_D = (-) :: Double -> Double -> Double
136lT_D = (<) :: Double -> Double -> Bool
137lE_D = (<=) :: Double -> Double -> Bool
138gT_D = (>) :: Double -> Double -> Bool
139gE_D = (>=) :: Double -> Double -> Bool
140eQ_D = (==) :: Double -> Double -> Bool
141mUL_D = (*) :: Double -> Double -> Double
142nEG_D = (negate) :: Double -> Double
143nE_D = (/=) :: Double -> Double -> Bool
144sLASH_D = (/) :: Double -> Double -> Double
145yHC_Primitive_primDecodeDouble = decodeFloat :: Double -> (Integer,Int)
146yHC_Primitive_primDoubleACos = acos :: Double -> Double
147yHC_Primitive_primDoubleASin = asin :: Double -> Double
148yHC_Primitive_primDoubleATan = atan :: Double -> Double
149yHC_Primitive_primDoubleAbs = abs :: Double -> Double
150yHC_Primitive_primDoubleCos = cos :: Double -> Double
151yHC_Primitive_primDoubleExp = exp :: Double -> Double
152yHC_Primitive_primDoubleFromInteger = fromInteger :: Integer -> Double
153yHC_Primitive_primDoubleLog = log :: Double -> Double
154yHC_Primitive_primDoublePow = (**) :: Double -> Double -> Double
155yHC_Primitive_primDoubleSignum = signum :: Double -> Double
156yHC_Primitive_primDoubleSin = sin :: Double -> Double
157yHC_Primitive_primDoubleSqrt = sqrt :: Double -> Double
158yHC_Primitive_primDoubleTan = tan :: Double -> Double
159yHC_Primitive_primEncodeDouble = encodeFloat :: Integer -> Int -> Double
160
161
162
163
164-- things which Yhc decides should be hopelessly slow
165prelude_Int_Integral_mod = mod :: Int -> Int -> Int
166prelude_Integer_Integral_div = div :: Integer -> Integer -> Integer
167prelude_Integer_Integral_mod = mod :: Integer -> Integer -> Integer
168prelude_Integer_Num_signum = signum :: Integer -> Integer
169prelude_Integer_Num_abs = abs :: Integer -> Integer
170
171
172int_ x = x :: Int
173chr_ x = ord x
174str_ x = map chr_ x
175
176
177system_IO_stdin = stdin
178system_IO_stdout = stdout
179
180data_Char_isSpace :: Int -> Bool
181data_Char_isSpace c = isspace (toEnum c) /= 0
182
183
184
185type ReadsPrec a = Int -> [Int] -> [(a,[Int])]
186
187
188prelude_Int_Read_readsPrec :: ReadsPrec Int
189prelude_Int_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
190prelude_Int_Read_readList = undefined
191
192prelude_Integer_Read_readsPrec :: ReadsPrec Integer
193prelude_Integer_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
194prelude_Integer_Read_readList = undefined
195
196prelude_Double_Read_readsPrec :: ReadsPrec Double
197prelude_Double_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
198prelude_Double_Read_readList = undefined
199
200prelude_Char_Read_readsPrec :: ReadsPrec Int
201prelude_Char_Read_readsPrec p s = [(chr_ (a :: Char), str_ b) | (a,b) <- readsPrec p (map chr s)]
202
203prelude_Char_Show_showList :: [Int] -> [Int] -> [Int]
204prelude_Char_Show_showList value rest = str_ (show (map chr value)) ++ rest
205
206prelude_Char_Show_showsPrec :: Int -> Int -> [Int] -> [Int]
207prelude_Char_Show_showsPrec prec i rest = str_ (showsPrec prec (chr i) []) ++ rest
208
209prelude_Int_Show_showsPrec :: Int -> Int -> [Int] -> [Int]
210prelude_Int_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest
211
212prelude_Integer_Show_showsPrec :: Int -> Integer -> [Int] -> [Int]
213prelude_Integer_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest
214
215prelude_Double_Show_showsPrec :: Int -> Double -> [Int] -> [Int]
216prelude_Double_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest
217
218
219prelude_'amp'amp27 v1 v2 =
220    case (data_Char_isSpace v1) of
221        True ->
222            case v2 of
223                [] -> True
224                (:) v4 v5 -> prelude_'amp'amp27 v4 v5
225        False -> False
226
227prelude_LAMBDA22 v1 v2 =
228    case v1 of
229        (,) v267 v268 ->
230            case v268 of
231                [] -> prelude_LAMBDA24 v267 v2
232                (:) v7 v8 ->
233                    let v11 = prelude_'amp'amp27 v7 v8
234                    in case v11 of
235                           True -> prelude_LAMBDA24 v267 v2
236                           False -> prelude__foldr25 v2
237
238prelude_LAMBDA24 v1 v2 = (:) v1 (prelude__foldr25 v2)
239
240prelude_IO_Monad_fail41 v1 =
241    overlay_errorIO
242      (skipCAF argCAF (str_ "pattern-match failure in do expression"))
243      v1
244
245prelude__foldr25 v1 =
246    case v1 of
247        [] -> []
248        (:) v296 v297 -> prelude_LAMBDA22 v296 v297
249
250f17 uncaf = skipCAF uncaf (str_ "Prelude.read: no parse")
251
252f18 v1 v2 =
253    case v1 of
254        (,) v176 v177 ->
255            case v177 of
256                [] -> f20 v176 v2
257                (:) v7 v8 ->
258                    let v11 = prelude_'amp'amp27 v7 v8
259                    in case v11 of
260                           True -> f20 v176 v2
261                           False ->
262                               case v2 of
263                                   [] -> prelude_error (f17 argCAF)
264                                   (:) v4 v5 -> f18 v4 v5
265
266f20 v1 v2 =
267    case v2 of
268        [] -> v1
269        (:) v257 v258 ->
270            let v9 = prelude_LAMBDA22 v257 v258
271            in case v9 of
272                   [] -> v1
273                   (:) v10 v11 ->
274                       prelude_error
275                         (skipCAF argCAF (str_ "Prelude.read: ambiguous parse"))
276
277f34 v1 v2 v3 =
278    let v336 = f34 v1 v2 v3
279    in v336
280
281f38 v1 v2 =
282    case v1 of
283        [] -> system_IO_hPutChar system_IO_stdout (chr_ '\n') v2
284        (:) v350 v351 ->
285            case (system_IO_hPutChar
286                    system_IO_stdout
287                    v350
288                    (typeRealWorld v2)) of
289                PAIR_WORLD( v7  , v8  ) -> f38 v351 v7
290
291main_generated v1 =
292    case (system_Environment_getArgs (typeRealWorld v1)) of
293        PAIR_WORLD( v3  , v4  ) ->
294            case v4 of
295                (:) v7 v8 ->
296                    case v8 of
297                        (:) v9 v12 ->
298                            case v12 of
299                                (:) v13 v14 ->
300                                    case v14 of
301                                        [] ->
302                                            case (prelude_Int_Show_showsPrec
303                                                    (int_ 0)
304                                                    (let v8 =
305                                                             case (prelude_Int_Read_readsPrec
306                                                                     (int_ 0)
307                                                                     v7) of
308                                                                 [] -> prelude_error (f17 argCAF)
309                                                                 (:) v12 v14 -> f18 v12 v14
310                                                         v10 =
311                                                             case (prelude_Int_Read_readsPrec
312                                                                     (int_ 0)
313                                                                     v9) of
314                                                                 [] -> prelude_error (f17 argCAF)
315                                                                 (:) v15 v16 -> f18 v15 v16
316                                                         v11 =
317                                                             case (prelude_Int_Read_readsPrec
318                                                                     (int_ 0)
319                                                                     v13) of
320                                                                 [] -> prelude_error (f17 argCAF)
321                                                                 (:) v17 v18 -> f18 v17 v18
322                                                     in case (lT_W v10 v8) of
323                                                            True ->
324                                                                let v7 = f34 v8 v10 v11
325                                                                in v7
326                                                            False -> v11)
327                                                    (skipCAF argCAF (str_ ""))) of
328                                                [] ->
329                                                    system_IO_hPutChar
330                                                      system_IO_stdout
331                                                      (chr_ '\n')
332                                                      (typeRealWorld v3)
333                                                (:) v11 v12 ->
334                                                    case (system_IO_hPutChar
335                                                            system_IO_stdout
336                                                            v11
337                                                            (typeRealWorld (typeRealWorld v3))) of
338                                                        PAIR_WORLD( v7  , v8  ) -> f38 v12 v7
339                                        (:) v15 v16 -> prelude_IO_Monad_fail41 v3
340                                [] -> prelude_IO_Monad_fail41 v3
341                        [] -> prelude_IO_Monad_fail41 v3
342                [] -> prelude_IO_Monad_fail41 v3