23 _showHex, _showRadix, _showDigit, -- non-std
25 showSpace__, -- non-std
32 import IBool -- instances
46 import PreludeGlaST ( _MutableArray )
47 import PS ( _PackedString, _unpackPS )
48 import TyComplex -- for pragmas
50 -- import Prelude hiding ( readParen )
52 type ReadS a = String -> [(a,String)]
53 type ShowS = String -> String
55 #if defined(__UNBOXED_INSTANCES__)
56 {-# SPECIALIZE shows :: Int# -> String -> String = shows_Int# #-}
57 {-# SPECIALIZE show :: Int# -> String = itos# #-}
58 {-# SPECIALIZE showSigned :: (Int# -> ShowS) -> Int -> Int# -> ShowS = showSigned_Int# #-}
61 -- *** instances omitted ***
63 reads :: (Text a) => ReadS a
66 {-# GENERATE_SPECS read a{+,Int,Integer,(),Bool,Char,Double,Rational,Ratio(Integer),Complex(Double#),Complex(Double),_PackedString,[Bool],[Char],[Int],[Double],[Float],[Integer],[Complex(Double)],[[Int]],[[Char]],(Int,Int),(Int,Int,Int),(Integer,Integer),Array(Int)(Double),Array(Int,Int)(Double)} #-}
67 read :: (Text a) => String -> a
68 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
70 [] -> error ("read{PreludeText}: no parse:"++s++"\n")
71 _ -> error ("read{PreludeText}: ambiguous parse:"++s++"\n")
73 {-# SPECIALIZE shows :: Int -> String -> String = shows_Int,
74 Integer -> String -> String = shows_Integer #-}
76 shows :: (Text a) => a -> ShowS
79 shows_Int# :: Int# -> ShowS
80 shows_Int# n r = itos# n ++ r -- showsPrec 0 n r
82 shows_Int :: Int -> ShowS
83 shows_Int n r = itos n ++ r -- showsPrec 0 n r
85 shows_Integer :: Integer -> ShowS
86 shows_Integer n r = jtos n ++ r -- showsPrec 0 n r
88 {-# SPECIALIZE show :: Int -> String = itos,
89 Integer -> String = jtos #-}
90 {-# GENERATE_SPECS show a{Char#,Double#,(),Bool,Char,Double,Rational,Ratio(Integer),Complex(Double#),Complex(Double),_PackedString,[Bool],[Char],[Int],[Double],[Integer],[Complex(Double)],[[Int]],[[Char]],(Int,Int),(Int,Int,Int),(Integer,Integer),Array(Int)(Double),Array(Int,Int)(Double)} #-}
91 show :: (Text a) => a -> String
94 showChar :: Char -> ShowS
97 showSpace__ :: ShowS -- partain: this one is non-std
98 showSpace__ = {-showChar ' '-} \ xs -> ' ' : xs
100 showString :: String -> ShowS
103 showParen :: Bool -> ShowS -> ShowS
104 showParen b p = if b then showChar '(' . p . showChar ')' else p
106 readParen :: Bool -> ReadS a -> ReadS a
107 readParen b g = if b then mandatory else optional
108 where optional r = g r ++ mandatory r
109 mandatory r = [(x,u) | ("(",s) <- lex r,
113 --------------------------------------------
116 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
117 lex ('-':'-':s) = case dropWhile (/= '\n') s of
119 _ -> [] -- unterminated end-of-line
122 lex ('{':'-':s) = lexNest lex s
124 lexNest f ('-':'}':s) = f s
125 lexNest f ('{':'-':s) = lexNest (lexNest f) s
126 lexNest f (c:s) = lexNest f s
127 lexNest _ "" = [] -- unterminated
130 lex ('<':'-':s) = [("<-",s)]
131 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
133 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
135 lexString ('"':s) = [("\"",s)]
136 lexString s = [(ch++str, u)
137 | (ch,t) <- lexStrItem s,
138 (str,u) <- lexString t ]
140 lexStrItem ('\\':'&':s) = [("\\&",s)]
141 lexStrItem ('\\':c:s) | isSpace c
142 = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
143 lexStrItem s = lexLitChar s
145 lex (c:s) | isSingle c = [([c],s)]
146 | isSym1 c = [(c:sym,t) | (sym,t) <- [span isSym s]]
147 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
148 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
149 (fe,t) <- lexFracExp s ]
150 | otherwise = [] -- bad character
152 isSingle c = c `elem` ",;()[]{}_`"
153 isSym1 c = c `elem` "-~" || isSym c
154 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:"
155 isIdChar c = isAlphanum c || c `elem` "_'"
157 lexFracExp ('.':d:s) | isDigit d
158 = [('.':d:ds++e,u) | (ds,t) <- [span isDigit s],
160 lexFracExp s = [("",s)]
162 lexExp (e:s) | e `elem` "eE"
163 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
164 (ds,u) <- lexDigits t] ++
165 [(e:ds,t) | (ds,t) <- lexDigits s]
168 lexDigits :: ReadS String
169 lexDigits = nonnull isDigit
171 nonnull :: (Char -> Bool) -> ReadS String
172 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
174 lexLitChar :: ReadS String
176 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
178 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
179 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
180 lexEsc s@(d:_) | isDigit d = lexDigits s
181 lexEsc ('o':s) = [('o':os, t) | (os,t) <- nonnull isOctDigit s]
182 lexEsc ('x':s) = [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
183 lexEsc s@(c:_) | isUpper c
184 = case [(mne,s') | mne <- "DEL" : asciiTab,
185 ([],s') <- [match mne s] ]
189 lexLitChar (c:s) = [([c],s)]
192 isOctDigit c = c >= '0' && c <= '7'
193 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
194 || c >= 'a' && c <= 'f'
196 match :: (Eq a) => [a] -> [a] -> ([a],[a])
197 match (x:xs) (y:ys) | x == y = match xs ys
198 match xs ys = (xs,ys)
200 asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
201 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
202 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
203 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
204 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
207 readLitChar :: ReadS Char
209 readLitChar ('\\':s) = readEsc s
211 readEsc ('a':s) = [('\a',s)]
212 readEsc ('b':s) = [('\b',s)]
213 readEsc ('f':s) = [('\f',s)]
214 readEsc ('n':s) = [('\n',s)]
215 readEsc ('r':s) = [('\r',s)]
216 readEsc ('t':s) = [('\t',s)]
217 readEsc ('v':s) = [('\v',s)]
218 readEsc ('\\':s) = [('\\',s)]
219 readEsc ('"':s) = [('"',s)]
220 readEsc ('\'':s) = [('\'',s)]
221 readEsc ('^':c:s) | c >= '@' && c <= '_'
222 = [(chr (ord c - ord '@'), s)]
223 readEsc s@(d:_) | isDigit d
224 = [(chr n, t) | (n,t) <- readDec s]
225 readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s]
226 readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s]
227 readEsc s@(c:_) | isUpper c
228 = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
229 in case [(c,s') | (c, mne) <- table,
230 ([],s') <- [match mne s]]
234 readLitChar (c:s) = [(c,s)]
236 showLitChar :: Char -> ShowS
237 showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c))
238 showLitChar '\DEL' = showString "\\DEL"
239 showLitChar '\\' = showString "\\\\"
240 showLitChar c | c >= ' ' = showChar c
241 showLitChar '\a' = showString "\\a"
242 showLitChar '\b' = showString "\\b"
243 showLitChar '\f' = showString "\\f"
244 showLitChar '\n' = showString "\\n"
245 showLitChar '\r' = showString "\\r"
246 showLitChar '\t' = showString "\\t"
247 showLitChar '\v' = showString "\\v"
248 showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO")
249 showLitChar c = showString ('\\' : asciiTab!!ord c)
251 protectEsc p f = f . cont
252 where cont s@(c:_) | p c = "\\&" ++ s
255 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
256 readDec :: (Integral a) => ReadS a
257 readDec = readInt __i10 isDigit (\d -> ord d - ord_0)
259 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
260 readOct :: (Integral a) => ReadS a
261 readOct = readInt __i8 isOctDigit (\d -> ord d - ord_0)
263 {-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-}
264 readHex :: (Integral a) => ReadS a
265 readHex = readInt __i16 isHexDigit hex
266 where hex d = ord d - (if isDigit d then ord_0
267 else ord (if isUpper d then 'A' else 'a') - 10)
269 {-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-}
270 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
271 readInt radix isDig digToInt s =
272 [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r)
273 | (ds,r) <- nonnull isDig s ]
276 {-# GENERATE_SPECS showInt a{Int#,Int,Integer} #-}
277 showInt :: (Integral a) => a -> ShowS
279 {- USE_REPORT_PRELUDE
280 showInt n r = let (n',d) = quotRem n 10
281 r' = chr (ord_0 + fromIntegral d) : r
282 in if n' == 0 then r' else showInt n' r'
286 = case quotRem n 10 of { (n', d) ->
287 case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
291 if n' == 0 then r' else showInt n' r'
294 -- ******************************************************************
296 {-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-}
297 readSigned :: (Real a) => ReadS a -> ReadS a
298 readSigned readPos = readParen False read'
299 where read' r = read'' r ++
300 [(-x,t) | ("-",s) <- lex r,
302 read'' r = [(n,s) | (str,s) <- lex r,
303 (n,"") <- readPos str]
306 {-# SPECIALIZE showSigned :: (Int -> ShowS) -> Int -> Int -> ShowS = showSigned_Int,
307 (Integer -> ShowS) -> Int -> Integer -> ShowS = showSigned_Integer #-}
308 {-# GENERATE_SPECS showSigned a{Double#,Double} #-}
309 showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
310 showSigned showPos p x = if x < 0 then showParen (p > 6)
311 (showChar '-' . showPos (-x))
314 showSigned_Int# :: (Int# -> ShowS) -> Int -> Int# -> ShowS
315 showSigned_Int# _ p n r
316 = -- from HBC version; support code follows
317 if n `ltInt#` 0# && p > 6 then '(':itos# n++(')':r) else itos# n ++ r
319 showSigned_Int :: (Int -> ShowS) -> Int -> Int -> ShowS
320 showSigned_Int _ p n r
321 = -- from HBC version; support code follows
322 if n < 0 && p > 6 then '(':itos n++(')':r) else itos n ++ r
324 showSigned_Integer :: (Integer -> ShowS) -> Int -> Integer -> ShowS
325 showSigned_Integer _ p n r
326 = -- from HBC version; support code follows
327 if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
330 -- ******************************************************************
332 itos# :: Int# -> String
334 if n `ltInt#` 0# then
335 if negateInt# n `ltInt#` 0# then
336 -- n is minInt, a difficult number
337 itos# (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) []
339 '-':itos' (negateInt# n) []
343 itos' :: Int# -> String -> String
345 if n `ltInt#` 10# then
346 fromChar# (chr# (n `plusInt#` ord# '0'#)) : cs
348 itos' (n `quotInt#` 10#) (fromChar# (chr# (n `remInt#` 10# `plusInt#` ord# '0'#)) : cs)
350 itos :: Int -> String
351 itos (I# n) = itos# n
353 jtos :: Integer -> String
360 jtos' :: Integer -> String -> String
363 chr (fromInteger (n + ord_0)) : cs
365 jtos' (n `quot` __i10) (chr (fromInteger (n `rem` __i10 + ord_0)) : cs)
368 ord_0 = fromInt (ord '0')
371 -- ******************************************************************
373 -- The functions readFloat and showFloat below use rational arithmetic
374 -- to insure correct conversion between the floating-point radix and
375 -- decimal. It is often possible to use a higher-precision floating-
376 -- point type to obtain the same results.
378 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
379 readFloat :: (RealFloat a) => ReadS a
380 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
382 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
385 = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
387 where readFix r = [(read (ds++ds'), length ds', t)
388 | (ds,'.':s) <- lexDigits r,
389 (ds',t) <- lexDigits s ]
391 readExp (e:s) | e `elem` "eE" = readExp' s
394 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
395 readExp' ('+':s) = readDec s
396 readExp' s = readDec s
398 _readRational :: String -> Rational -- we export this one (non-std)
399 -- NB: *does* handle a leading "-"
402 '-' : xs -> - (read_me xs)
406 = case [x | (x,t) <- readRational s, ("","") <- lex t] of
408 [] -> error ("_readRational: no parse:" ++ top_s)
409 _ -> error ("_readRational: ambiguous parse:" ++ top_s)
411 -- The number of decimal digits m below is chosen to guarantee
412 -- read (show x) == x. See
413 -- Matula, D. W. A formalization of floating-point numeric base
414 -- conversion. IEEE Transactions on Computers C-19, 8 (1970 August),
419 {-# GENERATE_SPECS showFloat a{Double#,Double} #-}
420 showFloat:: (RealFloat a) => a -> ShowS
422 if x == 0 then showString ("0." ++ take (m-1) zeros)
423 else if e >= m-1 || e < 0 then showSci else showFix
425 showFix = showString whole . showChar '.' . showString frac
426 where (whole,frac) = splitAt (e+1) (show sig)
427 showSci = showChar d . showChar '.' . showString frac
428 . showChar 'e' . shows e
429 where (d:frac) = show sig
430 (m, sig, e) = if b == 10 then (w, s, n+w-1)
433 ((fromInt w * log (fromInteger b)) / log 10 :: Double)
435 (sig', e') = if sig1 >= 10^m' then (round (t/10), e1+1)
436 else if sig1 < 10^(m'-1) then (round (t*10), e1-1)
439 t = s%1 * (b%1)^^n * 10^^(m'-e1-1)
440 e1 = floor (logBase 10 x)
441 (s, n) = decodeFloat x
446 -- With all the guff the Prelude defines, you'd have thought they'd
447 -- include a few of the basics! ADR
448 -- (I guess this could be put in a utilities module instead...)
450 _showHex :: Int -> ShowS
451 _showHex = _showRadix 16
453 _showRadix :: Int -> Int -> ShowS
454 _showRadix radix n r =
455 let (n',d) = quotRem n radix
456 r' = _showDigit d : r
458 if n' == 0 then r' else _showRadix radix n' r'
460 _showDigit :: Int -> Char
461 _showDigit d | d < 10 = chr (ord_0 + d)
462 | otherwise = chr (ord 'a' + (d - 10))