ghc/lib/prelude/Text.hs

   1 module PreludeText (
   2         ReadS(..), ShowS(..),
   3
   4         lex,
   5         showString,
   6         readParen,
   7         showParen,
   8         read,
   9         readDec,
  10         readFloat,
  11         readLitChar,
  12         readSigned,
  13         _readRational,
  14         reads,
  15         show,
  16         showChar,
  17         showFloat,
  18         showInt,
  19         showLitChar,
  20         showSigned,
  21         shows,
  22
  23         _showHex, _showRadix, _showDigit, -- non-std
  24
  25         showSpace__, -- non-std
  26         readOct, readHex
  27     ) where
  28
  29 import Cls
  30 import Core
  31 import IArray
  32 import IBool            -- instances
  33 import IChar
  34 import IComplex
  35 import IDouble
  36 import IFloat
  37 import IInt
  38 import IInteger
  39 import IList
  40 import IRatio
  41 import ITup0
  42 import ITup2
  43 import ITup3
  44 import List
  45 import Prel
  46 import PS               ( _PackedString, _unpackPS )
  47 import TyComplex        -- for pragmas
  48
  49 -- import Prelude hiding ( readParen )
  50
  51 type  ReadS a = String -> [(a,String)]
  52 type  ShowS   = String -> String
  53
  54 #if defined(__UNBOXED_INSTANCES__)
  55 {-# SPECIALIZE shows      :: Int# -> String -> String = shows_Int# #-}
  56 {-# SPECIALIZE show       :: Int# -> String           = itos# #-}
  57 {-# SPECIALIZE showSigned :: (Int# -> ShowS) -> Int -> Int# -> ShowS = showSigned_Int# #-}
  58 #endif
  59
  60 -- *** instances omitted ***
  61
  62 reads           :: (Text a) => ReadS a
  63 reads           =  readsPrec 0
  64
  65 {-# 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)} #-}
  66 read            :: (Text a) => String -> a
  67 read s          =  case [x | (x,t) <- reads s, ("","") <- lex t] of
  68                         [x] -> x
  69                         []  -> error ("read{PreludeText}: no parse:"++s++"\n")
  70                         _   -> error ("read{PreludeText}: ambiguous parse:"++s++"\n")
  71
  72 {-# SPECIALIZE shows :: Int     -> String -> String = shows_Int,
  73                         Integer -> String -> String = shows_Integer #-}
  74
  75 shows           :: (Text a) => a -> ShowS
  76 shows           =  showsPrec 0
  77
  78 shows_Int#      :: Int# -> ShowS
  79 shows_Int# n r  = itos# n ++ r          --  showsPrec 0 n r
  80
  81 shows_Int       :: Int -> ShowS
  82 shows_Int n r   = itos n ++ r           --  showsPrec 0 n r
  83
  84 shows_Integer   :: Integer -> ShowS
  85 shows_Integer n r = jtos n ++ r         --  showsPrec 0 n r
  86
  87 {-# SPECIALIZE show  :: Int     -> String = itos,
  88                         Integer -> String = jtos #-}
  89 {-# 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)} #-}
  90 show            :: (Text a) => a -> String
  91 show x          =  shows x ""
  92
  93 showChar        :: Char -> ShowS
  94 showChar        =  (:)
  95
  96 showSpace__     :: ShowS        -- partain: this one is non-std
  97 showSpace__     = {-showChar ' '-} \ xs -> ' ' : xs
  98
  99 showString      :: String -> ShowS
 100 showString      =  (++)
 101
 102 showParen       :: Bool -> ShowS -> ShowS
 103 showParen b p   =  if b then showChar '(' . p . showChar ')' else p
 104
 105 readParen       :: Bool -> ReadS a -> ReadS a
 106 readParen b g   =  if b then mandatory else optional
 107                    where optional r  = g r ++ mandatory r
 108                          mandatory r = [(x,u) | ("(",s) <- lex r,
 109                                                 (x,t)   <- optional s,
 110                                                 (")",u) <- lex t    ]
 111
 112 --------------------------------------------
 113 lex                     :: ReadS String
 114 lex ""                  = [("","")]
 115 lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
 116 lex ('-':'-':s)         = case dropWhile (/= '\n') s of
 117                                  '\n':t -> lex t
 118                                  _      -> [] -- unterminated end-of-line
 119                                               -- comment
 120
 121 lex ('{':'-':s)         = lexNest lex s
 122                           where
 123                           lexNest f ('-':'}':s) = f s
 124                           lexNest f ('{':'-':s) = lexNest (lexNest f) s
 125                           lexNest f (c:s)       = lexNest f s
 126                           lexNest _ ""          = [] -- unterminated
 127                                                      -- nested comment
 128
 129 lex ('<':'-':s)         = [("<-",s)]
 130 lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
 131                                                ch /= "'"                ]
 132 lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
 133                           where
 134                           lexString ('"':s) = [("\"",s)]
 135                           lexString s = [(ch++str, u)
 136                                                 | (ch,t)  <- lexStrItem s,
 137                                                   (str,u) <- lexString t  ]
 138
 139                           lexStrItem ('\\':'&':s) = [("\\&",s)]
 140                           lexStrItem ('\\':c:s) | isSpace c
 141                               = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
 142                           lexStrItem s            = lexLitChar s
 143
 144 lex (c:s) | isSingle c  = [([c],s)]
 145           | isSym1 c    = [(c:sym,t)         | (sym,t) <- [span isSym s]]
 146           | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
 147           | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
 148                                                (fe,t)  <- lexFracExp s     ]
 149           | otherwise   = []    -- bad character
 150                 where
 151                 isSingle c  =  c `elem` ",;()[]{}_`"
 152                 isSym1 c    =  c `elem` "-~" || isSym c
 153                 isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:"
 154                 isIdChar c  =  isAlphanum c || c `elem` "_'"
 155
 156                 lexFracExp ('.':d:s) | isDigit d
 157                         = [('.':d:ds++e,u) | (ds,t) <- [span isDigit s],
 158                                              (e,u)  <- lexExp t       ]
 159                 lexFracExp s       = [("",s)]
 160
 161                 lexExp (e:s) | e `elem` "eE"
 162                          = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
 163                                                    (ds,u) <- lexDigits t] ++
 164                            [(e:ds,t)   | (ds,t) <- lexDigits s]
 165                 lexExp s = [("",s)]
 166
 167 lexDigits               :: ReadS String
 168 lexDigits               =  nonnull isDigit
 169
 170 nonnull                 :: (Char -> Bool) -> ReadS String
 171 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
 172
 173 lexLitChar              :: ReadS String
 174
 175 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
 176         where
 177         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
 178         lexEsc ('^':c:s) | c >= '@' && c <= '_'  = [(['^',c],s)]
 179         lexEsc s@(d:_)   | isDigit d             = lexDigits s
 180         lexEsc ('o':s)  =  [('o':os, t) | (os,t) <- nonnull isOctDigit s]
 181         lexEsc ('x':s)  =  [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
 182         lexEsc s@(c:_)   | isUpper c
 183                         =  case [(mne,s') | mne <- "DEL" : asciiTab,
 184                                             ([],s') <- [match mne s]      ]
 185                            of (pr:_) -> [pr]
 186                               []     -> []
 187         lexEsc _        =  []
 188 lexLitChar (c:s)        =  [([c],s)]
 189 lexLitChar ""           =  []
 190
 191 isOctDigit c  =  c >= '0' && c <= '7'
 192 isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
 193                            || c >= 'a' && c <= 'f'
 194
 195 match                   :: (Eq a) => [a] -> [a] -> ([a],[a])
 196 match (x:xs) (y:ys) | x == y  =  match xs ys
 197 match xs     ys               =  (xs,ys)
 198
 199 asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')
 200            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
 201             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
 202             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
 203             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
 204             "SP"]
 205
 206 readLitChar             :: ReadS Char
 207
 208 readLitChar ('\\':s)    =  readEsc s
 209         where
 210         readEsc ('a':s)  = [('\a',s)]
 211         readEsc ('b':s)  = [('\b',s)]
 212         readEsc ('f':s)  = [('\f',s)]
 213         readEsc ('n':s)  = [('\n',s)]
 214         readEsc ('r':s)  = [('\r',s)]
 215         readEsc ('t':s)  = [('\t',s)]
 216         readEsc ('v':s)  = [('\v',s)]
 217         readEsc ('\\':s) = [('\\',s)]
 218         readEsc ('"':s)  = [('"',s)]
 219         readEsc ('\'':s) = [('\'',s)]
 220         readEsc ('^':c:s) | c >= '@' && c <= '_'
 221                          = [(chr (ord c - ord '@'), s)]
 222         readEsc s@(d:_) | isDigit d
 223                          = [(chr n, t) | (n,t) <- readDec s]
 224         readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
 225         readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]
 226         readEsc s@(c:_) | isUpper c
 227                          = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
 228                            in case [(c,s') | (c, mne) <- table,
 229                                              ([],s') <- [match mne s]]
 230                               of (pr:_) -> [pr]
 231                                  []     -> []
 232         readEsc _        = []
 233 readLitChar (c:s)       =  [(c,s)]
 234
 235 showLitChar                :: Char -> ShowS
 236 showLitChar c | c > '\DEL' =  showChar '\\' . protectEsc isDigit (shows (ord c))
 237 showLitChar '\DEL'         =  showString "\\DEL"
 238 showLitChar '\\'           =  showString "\\\\"
 239 showLitChar c | c >= ' '   =  showChar c
 240 showLitChar '\a'           =  showString "\\a"
 241 showLitChar '\b'           =  showString "\\b"
 242 showLitChar '\f'           =  showString "\\f"
 243 showLitChar '\n'           =  showString "\\n"
 244 showLitChar '\r'           =  showString "\\r"
 245 showLitChar '\t'           =  showString "\\t"
 246 showLitChar '\v'           =  showString "\\v"
 247 showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")
 248 showLitChar c              =  showString ('\\' : asciiTab!!ord c)
 249
 250 protectEsc p f             = f . cont
 251                              where cont s@(c:_) | p c = "\\&" ++ s
 252                                    cont s             = s
 253
 254 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
 255 readDec :: (Integral a) => ReadS a
 256 readDec = readInt __i10 isDigit (\d -> ord d - ord_0)
 257
 258 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
 259 readOct :: (Integral a) => ReadS a
 260 readOct = readInt __i8 isOctDigit (\d -> ord d - ord_0)
 261
 262 {-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-}
 263 readHex :: (Integral a) => ReadS a
 264 readHex = readInt __i16 isHexDigit hex
 265             where hex d = ord d - (if isDigit d then ord_0
 266                                    else ord (if isUpper d then 'A' else 'a') - 10)
 267
 268 {-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-}
 269 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
 270 readInt radix isDig digToInt s =
 271     [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r)
 272         | (ds,r) <- nonnull isDig s ]
 273
 274
 275 {-# GENERATE_SPECS showInt a{Int#,Int,Integer} #-}
 276 showInt :: (Integral a) => a -> ShowS
 277
 278 {- USE_REPORT_PRELUDE
 279 showInt n r = let (n',d) = quotRem n 10
 280                   r' = chr (ord_0 + fromIntegral d) : r
 281               in if n' == 0 then r' else showInt n' r'
 282 -}
 283
 284 showInt n r
 285   = case quotRem n 10 of                     { (n', d) ->
 286     case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
 287     let
 288         r' = C# c# : r
 289     in
 290     if n' == 0 then r' else showInt n' r'
 291     }}
 292
 293 -- ******************************************************************
 294
 295 {-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-}
 296 readSigned :: (Real a) => ReadS a -> ReadS a
 297 readSigned readPos = readParen False read'
 298                      where read' r  = read'' r ++
 299                                       [(-x,t) | ("-",s) <- lex r,
 300                                                 (x,t)   <- read'' s]
 301                            read'' r = [(n,s)  | (str,s) <- lex r,
 302                                                 (n,"")  <- readPos str]
 303
 304
 305 {-# SPECIALIZE showSigned :: (Int     -> ShowS) -> Int -> Int     -> ShowS = showSigned_Int,
 306                              (Integer -> ShowS) -> Int -> Integer -> ShowS = showSigned_Integer #-}
 307 {-# GENERATE_SPECS showSigned a{Double#,Double} #-}
 308 showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
 309 showSigned showPos p x = if x < 0 then showParen (p > 6)
 310                                                  (showChar '-' . showPos (-x))
 311                                   else showPos x
 312
 313 showSigned_Int# :: (Int# -> ShowS) -> Int -> Int# -> ShowS
 314 showSigned_Int# _ p n r
 315   = -- from HBC version; support code follows
 316     if n `ltInt#` 0# && p > 6 then '(':itos# n++(')':r) else itos# n ++ r
 317
 318 showSigned_Int :: (Int -> ShowS) -> Int -> Int -> ShowS
 319 showSigned_Int _ p n r
 320   = -- from HBC version; support code follows
 321     if n < 0 && p > 6 then '(':itos n++(')':r) else itos n ++ r
 322
 323 showSigned_Integer :: (Integer -> ShowS) -> Int -> Integer -> ShowS
 324 showSigned_Integer _ p n r
 325   = -- from HBC version; support code follows
 326     if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
 327
 328
 329 -- ******************************************************************
 330
 331 itos# :: Int# -> String
 332 itos# n =
 333     if n `ltInt#` 0# then
 334         if negateInt# n `ltInt#` 0# then
 335             -- n is minInt, a difficult number
 336             itos# (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) []
 337         else
 338             '-':itos' (negateInt# n) []
 339     else
 340         itos' n []
 341   where
 342     itos' :: Int# -> String -> String
 343     itos' n cs =
 344         if n `ltInt#` 10# then
 345             fromChar# (chr# (n `plusInt#` ord# '0'#)) : cs
 346         else
 347             itos' (n `quotInt#` 10#) (fromChar# (chr# (n `remInt#` 10# `plusInt#` ord# '0'#)) : cs)
 348
 349 itos :: Int -> String
 350 itos (I# n) = itos# n
 351
 352 jtos :: Integer -> String
 353 jtos n
 354   = if n < __i0 then
 355         '-' : jtos' (-n) []
 356     else
 357         jtos' n []
 358
 359 jtos' :: Integer -> String -> String
 360 jtos' n cs
 361   = if n < __i10 then
 362         chr (fromInteger (n + ord_0)) : cs
 363     else
 364         jtos' (n `quot` __i10) (chr (fromInteger (n `rem` __i10 + ord_0)) : cs)
 365
 366 ord_0 :: Num a => a
 367 ord_0 = fromInt (ord '0')
 368
 369
 370 -- ******************************************************************
 371
 372 -- The functions readFloat and showFloat below use rational arithmetic
 373 -- to insure correct conversion between the floating-point radix and
 374 -- decimal.  It is often possible to use a higher-precision floating-
 375 -- point type to obtain the same results.
 376
 377 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
 378 readFloat :: (RealFloat a) => ReadS a
 379 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
 380
 381 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
 382
 383 readRational r
 384   = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
 385                                (k,t)   <- readExp s]
 386               where readFix r = [(read (ds++ds'), length ds', t)
 387                                         | (ds,'.':s) <- lexDigits r,
 388                                           (ds',t)    <- lexDigits s ]
 389
 390                     readExp (e:s) | e `elem` "eE" = readExp' s
 391                     readExp s                     = [(0,s)]
 392
 393                     readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
 394                     readExp' ('+':s) = readDec s
 395                     readExp' s       = readDec s
 396
 397 _readRational :: String -> Rational -- we export this one (non-std)
 398                                     -- NB: *does* handle a leading "-"
 399 _readRational top_s
 400   = case top_s of
 401       '-' : xs -> - (read_me xs)
 402       xs       -> read_me xs
 403   where
 404     read_me s
 405       = case [x | (x,t) <- readRational s, ("","") <- lex t] of
 406           [x] -> x
 407           []  -> error ("_readRational: no parse:" ++ top_s)
 408           _   -> error ("_readRational: ambiguous parse:" ++ top_s)
 409
 410 -- The number of decimal digits m below is chosen to guarantee
 411 -- read (show x) == x.  See
 412 --      Matula, D. W.  A formalization of floating-point numeric base
 413 --      conversion.  IEEE Transactions on Computers C-19, 8 (1970 August),
 414 --      681-692.
 415
 416 zeros = repeat '0'
 417
 418 {-# GENERATE_SPECS showFloat a{Double#,Double} #-}
 419 showFloat:: (RealFloat a) => a -> ShowS
 420 showFloat x =
 421     if x == 0 then showString ("0." ++ take (m-1) zeros)
 422               else if e >= m-1 || e < 0 then showSci else showFix
 423     where
 424     showFix     = showString whole . showChar '.' . showString frac
 425                   where (whole,frac) = splitAt (e+1) (show sig)
 426     showSci     = showChar d . showChar '.' . showString frac
 427                       . showChar 'e' . shows e
 428                   where (d:frac) = show sig
 429     (m, sig, e) = if b == 10 then (w,   s,   n+w-1)
 430                              else (m', sig', e'   )
 431     m'          = ceiling
 432                       ((fromInt w * log (fromInteger b)) / log 10 :: Double)
 433                   + 1
 434     (sig', e')  = if      sig1 >= 10^m'     then (round (t/10), e1+1)
 435                   else if sig1 <  10^(m'-1) then (round (t*10), e1-1)
 436                                             else (sig1,          e1  )
 437     sig1        = round t
 438     t           = s%1 * (b%1)^^n * 10^^(m'-e1-1)
 439     e1          = floor (logBase 10 x)
 440     (s, n)      = decodeFloat x
 441     b           = floatRadix x
 442     w           = floatDigits x
 443
 444
 445 -- With all the guff the Prelude defines, you'd have thought they'd
 446 -- include a few of the basics! ADR
 447 -- (I guess this could be put in a utilities module instead...)
 448
 449 _showHex :: Int -> ShowS
 450 _showHex = _showRadix 16
 451
 452 _showRadix :: Int -> Int -> ShowS
 453 _showRadix radix n r =
 454   let (n',d) = quotRem n radix
 455       r' = _showDigit d : r
 456   in
 457   if n' == 0 then r' else _showRadix radix n' r'
 458
 459 _showDigit :: Int -> Char
 460 _showDigit d | d < 10    = chr (ord_0 + d)
 461              | otherwise = chr (ord 'a' + (d - 10))