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 PreludeGlaST     ( _MutableArray )
  47 import PS               ( _PackedString, _unpackPS )
  48 import TyComplex        -- for pragmas
  49
  50 -- import Prelude hiding ( readParen )
  51
  52 type  ReadS a = String -> [(a,String)]
  53 type  ShowS   = String -> String
  54
  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# #-}
  59 #endif
  60
  61 -- *** instances omitted ***
  62
  63 reads           :: (Text a) => ReadS a
  64 reads           =  readsPrec 0
  65
  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
  69                         [x] -> x
  70                         []  -> error ("read{PreludeText}: no parse:"++s++"\n")
  71                         _   -> error ("read{PreludeText}: ambiguous parse:"++s++"\n")
  72
  73 {-# SPECIALIZE shows :: Int     -> String -> String = shows_Int,
  74                         Integer -> String -> String = shows_Integer #-}
  75
  76 shows           :: (Text a) => a -> ShowS
  77 shows           =  showsPrec 0
  78
  79 shows_Int#      :: Int# -> ShowS
  80 shows_Int# n r  = itos# n ++ r          --  showsPrec 0 n r
  81
  82 shows_Int       :: Int -> ShowS
  83 shows_Int n r   = itos n ++ r           --  showsPrec 0 n r
  84
  85 shows_Integer   :: Integer -> ShowS
  86 shows_Integer n r = jtos n ++ r         --  showsPrec 0 n r
  87
  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
  92 show x          =  shows x ""
  93
  94 showChar        :: Char -> ShowS
  95 showChar        =  (:)
  96
  97 showSpace__     :: ShowS        -- partain: this one is non-std
  98 showSpace__     = {-showChar ' '-} \ xs -> ' ' : xs
  99
 100 showString      :: String -> ShowS
 101 showString      =  (++)
 102
 103 showParen       :: Bool -> ShowS -> ShowS
 104 showParen b p   =  if b then showChar '(' . p . showChar ')' else p
 105
 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,
 110                                                 (x,t)   <- optional s,
 111                                                 (")",u) <- lex t    ]
 112
 113 --------------------------------------------
 114 lex                     :: ReadS String
 115 lex ""                  = [("","")]
 116 lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
 117 lex ('-':'-':s)         = case dropWhile (/= '\n') s of
 118                                  '\n':t -> lex t
 119                                  _      -> [] -- unterminated end-of-line
 120                                               -- comment
 121
 122 lex ('{':'-':s)         = lexNest lex s
 123                           where
 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
 128                                                      -- nested comment
 129
 130 lex ('<':'-':s)         = [("<-",s)]
 131 lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
 132                                                ch /= "'"                ]
 133 lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
 134                           where
 135                           lexString ('"':s) = [("\"",s)]
 136                           lexString s = [(ch++str, u)
 137                                                 | (ch,t)  <- lexStrItem s,
 138                                                   (str,u) <- lexString t  ]
 139
 140                           lexStrItem ('\\':'&':s) = [("\\&",s)]
 141                           lexStrItem ('\\':c:s) | isSpace c
 142                               = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
 143                           lexStrItem s            = lexLitChar s
 144
 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
 151                 where
 152                 isSingle c  =  c `elem` ",;()[]{}_`"
 153                 isSym1 c    =  c `elem` "-~" || isSym c
 154                 isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:"
 155                 isIdChar c  =  isAlphanum c || c `elem` "_'"
 156
 157                 lexFracExp ('.':d:s) | isDigit d
 158                         = [('.':d:ds++e,u) | (ds,t) <- [span isDigit s],
 159                                              (e,u)  <- lexExp t       ]
 160                 lexFracExp s       = [("",s)]
 161
 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]
 166                 lexExp s = [("",s)]
 167
 168 lexDigits               :: ReadS String
 169 lexDigits               =  nonnull isDigit
 170
 171 nonnull                 :: (Char -> Bool) -> ReadS String
 172 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
 173
 174 lexLitChar              :: ReadS String
 175
 176 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
 177         where
 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]      ]
 186                            of (pr:_) -> [pr]
 187                               []     -> []
 188         lexEsc _        =  []
 189 lexLitChar (c:s)        =  [([c],s)]
 190 lexLitChar ""           =  []
 191
 192 isOctDigit c  =  c >= '0' && c <= '7'
 193 isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
 194                            || c >= 'a' && c <= 'f'
 195
 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)
 199
 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",
 205             "SP"]
 206
 207 readLitChar             :: ReadS Char
 208
 209 readLitChar ('\\':s)    =  readEsc s
 210         where
 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]]
 231                               of (pr:_) -> [pr]
 232                                  []     -> []
 233         readEsc _        = []
 234 readLitChar (c:s)       =  [(c,s)]
 235
 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)
 250
 251 protectEsc p f             = f . cont
 252                              where cont s@(c:_) | p c = "\\&" ++ s
 253                                    cont s             = s
 254
 255 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
 256 readDec :: (Integral a) => ReadS a
 257 readDec = readInt __i10 isDigit (\d -> ord d - ord_0)
 258
 259 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
 260 readOct :: (Integral a) => ReadS a
 261 readOct = readInt __i8 isOctDigit (\d -> ord d - ord_0)
 262
 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)
 268
 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 ]
 274
 275
 276 {-# GENERATE_SPECS showInt a{Int#,Int,Integer} #-}
 277 showInt :: (Integral a) => a -> ShowS
 278
 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'
 283 -}
 284
 285 showInt n r
 286   = case quotRem n 10 of                     { (n', d) ->
 287     case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
 288     let
 289         r' = C# c# : r
 290     in
 291     if n' == 0 then r' else showInt n' r'
 292     }}
 293
 294 -- ******************************************************************
 295
 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,
 301                                                 (x,t)   <- read'' s]
 302                            read'' r = [(n,s)  | (str,s) <- lex r,
 303                                                 (n,"")  <- readPos str]
 304
 305
 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))
 312                                   else showPos x
 313
 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
 318
 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
 323
 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
 328
 329
 330 -- ******************************************************************
 331
 332 itos# :: Int# -> String
 333 itos# n =
 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#)) []
 338         else
 339             '-':itos' (negateInt# n) []
 340     else
 341         itos' n []
 342   where
 343     itos' :: Int# -> String -> String
 344     itos' n cs =
 345         if n `ltInt#` 10# then
 346             fromChar# (chr# (n `plusInt#` ord# '0'#)) : cs
 347         else
 348             itos' (n `quotInt#` 10#) (fromChar# (chr# (n `remInt#` 10# `plusInt#` ord# '0'#)) : cs)
 349
 350 itos :: Int -> String
 351 itos (I# n) = itos# n
 352
 353 jtos :: Integer -> String
 354 jtos n
 355   = if n < __i0 then
 356         '-' : jtos' (-n) []
 357     else
 358         jtos' n []
 359
 360 jtos' :: Integer -> String -> String
 361 jtos' n cs
 362   = if n < __i10 then
 363         chr (fromInteger (n + ord_0)) : cs
 364     else
 365         jtos' (n `quot` __i10) (chr (fromInteger (n `rem` __i10 + ord_0)) : cs)
 366
 367 ord_0 :: Num a => a
 368 ord_0 = fromInt (ord '0')
 369
 370
 371 -- ******************************************************************
 372
 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.
 377
 378 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
 379 readFloat :: (RealFloat a) => ReadS a
 380 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
 381
 382 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
 383
 384 readRational r
 385   = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
 386                                (k,t)   <- readExp s]
 387               where readFix r = [(read (ds++ds'), length ds', t)
 388                                         | (ds,'.':s) <- lexDigits r,
 389                                           (ds',t)    <- lexDigits s ]
 390
 391                     readExp (e:s) | e `elem` "eE" = readExp' s
 392                     readExp s                     = [(0,s)]
 393
 394                     readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
 395                     readExp' ('+':s) = readDec s
 396                     readExp' s       = readDec s
 397
 398 _readRational :: String -> Rational -- we export this one (non-std)
 399                                     -- NB: *does* handle a leading "-"
 400 _readRational top_s
 401   = case top_s of
 402       '-' : xs -> - (read_me xs)
 403       xs       -> read_me xs
 404   where
 405     read_me s
 406       = case [x | (x,t) <- readRational s, ("","") <- lex t] of
 407           [x] -> x
 408           []  -> error ("_readRational: no parse:" ++ top_s)
 409           _   -> error ("_readRational: ambiguous parse:" ++ top_s)
 410
 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),
 415 --      681-692.
 416
 417 zeros = repeat '0'
 418
 419 {-# GENERATE_SPECS showFloat a{Double#,Double} #-}
 420 showFloat:: (RealFloat a) => a -> ShowS
 421 showFloat x =
 422     if x == 0 then showString ("0." ++ take (m-1) zeros)
 423               else if e >= m-1 || e < 0 then showSci else showFix
 424     where
 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)
 431                              else (m', sig', e'   )
 432     m'          = ceiling
 433                       ((fromInt w * log (fromInteger b)) / log 10 :: Double)
 434                   + 1
 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)
 437                                             else (sig1,          e1  )
 438     sig1        = round t
 439     t           = s%1 * (b%1)^^n * 10^^(m'-e1-1)
 440     e1          = floor (logBase 10 x)
 441     (s, n)      = decodeFloat x
 442     b           = floatRadix x
 443     w           = floatDigits x
 444
 445
 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...)
 449
 450 _showHex :: Int -> ShowS
 451 _showHex = _showRadix 16
 452
 453 _showRadix :: Int -> Int -> ShowS
 454 _showRadix radix n r =
 455   let (n',d) = quotRem n radix
 456       r' = _showDigit d : r
 457   in
 458   if n' == 0 then r' else _showRadix radix n' r'
 459
 460 _showDigit :: Int -> Char
 461 _showDigit d | d < 10    = chr (ord_0 + d)
 462              | otherwise = chr (ord 'a' + (d - 10))