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 --      lexToss__,   -- non-std
  27         readOct, readHex
  28     ) where
  29
  30 import Cls
  31 import Core
  32 import IChar            -- instances
  33 import IDouble
  34 import IFloat
  35 import IInt
  36 import IInteger
  37 import IList
  38 import IRatio
  39 import ITup2
  40 import List
  41 import Prel
  42 import PS               ( _PackedString, _unpackPS )
  43 import TyComplex        -- for pragmas
  44
  45 -- import Prelude hiding ( readParen )
  46
  47 type  ReadS a = String -> [(a,String)]
  48 type  ShowS   = String -> String
  49
  50 -- *** instances omitted ***
  51
  52
  53 {-# SPECIALIZE reads :: ReadS Int,
  54                         ReadS Integer,
  55                         ReadS Float,
  56                         ReadS Double #-}
  57 {-# SPECIALIZE shows :: Int     -> String -> String = shows_Int,
  58                         Integer -> String -> String = shows_Integer,
  59                         Float   -> String -> String,
  60                         Double  -> String -> String #-}
  61 {-# SPECIALIZE show  :: Char    -> String,
  62                         Int     -> String = itos,
  63                         Integer -> String = jtos,
  64                         Float   -> String,
  65                         Double  -> String,
  66                         _PackedString  -> String,
  67                         String  -> String,
  68                         (Int,Int) -> String,
  69                         (Integer,Integer) -> String #-}
  70 {-# SPECIALIZE read  :: String  -> Int,
  71                         String  -> Integer,
  72                         String  -> Float,
  73                         String  -> Double #-}
  74
  75 --{-# GENERATE_SPECS reads a #-}
  76 reads           :: (Text a) => ReadS a
  77 reads           =  readsPrec 0
  78
  79 --{-# GENERATE_SPECS read a #-}
  80 read            :: (Text a) => String -> a
  81 read s          =  case [x | (x,t) <- reads s, ("","") <- lex t] of
  82                         [x] -> x
  83                         []  -> error ("read{PreludeText}: no parse:"++s++"\n")
  84                         _   -> error ("read{PreludeText}: ambiguous parse:"++s++"\n")
  85
  86 --{-# GENERATE_SPECS shows a{+,Int} #-}
  87 shows           :: (Text a) => a -> ShowS
  88 shows           =  showsPrec 0
  89
  90 shows_Int       :: Int -> ShowS
  91 shows_Int n r   = itos n ++ r   --  showsPrec 0 n r
  92
  93 shows_Integer   :: Integer -> ShowS
  94 shows_Integer n r = jtos n ++ r --  showsPrec 0 n r
  95
  96 --{-# GENERATE_SPECS show a{+,Int} #-}
  97 show            :: (Text a) => a -> String
  98 show x          =  shows x ""
  99
 100 showChar        :: Char -> ShowS
 101 showChar        =  (:)
 102
 103 showSpace__     :: ShowS        -- partain: this one is non-std
 104 showSpace__     = {-showChar ' '-} \ xs -> ' ' : xs
 105
 106 showString      :: String -> ShowS
 107 showString      =  (++)
 108
 109 showParen       :: Bool -> ShowS -> ShowS
 110 showParen b p   =  if b then showChar '(' . p . showChar ')' else p
 111
 112 readParen       :: Bool -> ReadS a -> ReadS a
 113 readParen b g   =  if b then mandatory else optional
 114                    where optional r  = g r ++ mandatory r
 115                          mandatory r = [(x,u) | ("(",s) <- lex r,
 116                                                 (x,t)   <- optional s,
 117                                                 (")",u) <- lex t    ]
 118
 119 --------------------------------------------
 120 lex                     :: ReadS String
 121 lex ""                  = [("","")]
 122 lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
 123 lex ('-':'-':s)         = case dropWhile (/= '\n') s of
 124                                  '\n':t -> lex t
 125                                  _      -> [] -- unterminated end-of-line
 126                                               -- comment
 127
 128 lex ('{':'-':s)         = lexNest lex s
 129                           where
 130                           lexNest f ('-':'}':s) = f s
 131                           lexNest f ('{':'-':s) = lexNest (lexNest f) s
 132                           lexNest f (c:s)             = lexNest f s
 133                           lexNest _ ""          = [] -- unterminated
 134                                                      -- nested comment
 135
 136 lex ('<':'-':s)         = [("<-",s)]
 137 lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
 138                                                ch /= "'"                ]
 139 lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
 140                           where
 141                           lexString ('"':s) = [("\"",s)]
 142                           lexString s = [(ch++str, u)
 143                                                 | (ch,t)  <- lexStrItem s,
 144                                                   (str,u) <- lexString t  ]
 145
 146                           lexStrItem ('\\':'&':s) = [("\\&",s)]
 147                           lexStrItem ('\\':c:s) | isSpace c
 148                               = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
 149                           lexStrItem s            = lexLitChar s
 150
 151 lex (c:s) | isSingle c  = [([c],s)]
 152           | isSym1 c    = [(c:sym,t)         | (sym,t) <- [span isSym s]]
 153           | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
 154           | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
 155                                                (fe,t)  <- lexFracExp s     ]
 156           | otherwise   = []    -- bad character
 157                 where
 158                 isSingle c  =  c `elem` ",;()[]{}_`"
 159                 isSym1 c    =  c `elem` "-~" || isSym c
 160                 isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:"
 161                 isIdChar c  =  isAlphanum c || c `elem` "_'"
 162
 163                 lexFracExp ('.':d:s) | isDigit d
 164                         = [('.':d:ds++e,u) | (ds,t) <- [span isDigit s],
 165                                              (e,u)  <- lexExp t       ]
 166                 lexFracExp s       = [("",s)]
 167
 168                 lexExp (e:s) | e `elem` "eE"
 169                          = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
 170                                                    (ds,u) <- lexDigits t] ++
 171                            [(e:ds,t)   | (ds,t) <- lexDigits s]
 172                 lexExp s = [("",s)]
 173
 174 lexDigits               :: ReadS String
 175 lexDigits               =  nonnull isDigit
 176
 177 nonnull                 :: (Char -> Bool) -> ReadS String
 178 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
 179
 180 lexLitChar              :: ReadS String
 181
 182 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
 183         where
 184         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
 185         lexEsc ('^':c:s) | c >= '@' && c <= '_'  = [(['^',c],s)]
 186         lexEsc s@(d:_)   | isDigit d             = lexDigits s
 187         lexEsc ('o':s)  =  [('o':os, t) | (os,t) <- nonnull isOctDigit s]
 188         lexEsc ('x':s)  =  [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
 189         lexEsc s@(c:_)   | isUpper c
 190                         =  case [(mne,s') | mne <- "DEL" : asciiTab,
 191                                             ([],s') <- [match mne s]      ]
 192                            of (pr:_) -> [pr]
 193                               []     -> []
 194         lexEsc _        =  []
 195 lexLitChar (c:s)        =  [([c],s)]
 196 lexLitChar ""           =  []
 197
 198 isOctDigit c  =  c >= '0' && c <= '7'
 199 isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
 200                            || c >= 'a' && c <= 'f'
 201
 202 match                   :: (Eq a) => [a] -> [a] -> ([a],[a])
 203 match (x:xs) (y:ys) | x == y  =  match xs ys
 204 match xs     ys               =  (xs,ys)
 205
 206 asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')
 207            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
 208             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
 209             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
 210             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
 211             "SP"]
 212
 213 readLitChar             :: ReadS Char
 214
 215 readLitChar ('\\':s)    =  readEsc s
 216         where
 217         readEsc ('a':s)  = [('\a',s)]
 218         readEsc ('b':s)  = [('\b',s)]
 219         readEsc ('f':s)  = [('\f',s)]
 220         readEsc ('n':s)  = [('\n',s)]
 221         readEsc ('r':s)  = [('\r',s)]
 222         readEsc ('t':s)  = [('\t',s)]
 223         readEsc ('v':s)  = [('\v',s)]
 224         readEsc ('\\':s) = [('\\',s)]
 225         readEsc ('"':s)  = [('"',s)]
 226         readEsc ('\'':s) = [('\'',s)]
 227         readEsc ('^':c:s) | c >= '@' && c <= '_'
 228                          = [(chr (ord c - ord '@'), s)]
 229         readEsc s@(d:_) | isDigit d
 230                          = [(chr n, t) | (n,t) <- readDec s]
 231         readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
 232         readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]
 233         readEsc s@(c:_) | isUpper c
 234                          = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
 235                            in case [(c,s') | (c, mne) <- table,
 236                                              ([],s') <- [match mne s]]
 237                               of (pr:_) -> [pr]
 238                                  []     -> []
 239         readEsc _        = []
 240 readLitChar (c:s)       =  [(c,s)]
 241
 242 showLitChar                :: Char -> ShowS
 243 showLitChar c | c > '\DEL' =  showChar '\\' . protectEsc isDigit (shows (ord c))
 244 showLitChar '\DEL'         =  showString "\\DEL"
 245 showLitChar '\\'           =  showString "\\\\"
 246 showLitChar c | c >= ' '   =  showChar c
 247 showLitChar '\a'           =  showString "\\a"
 248 showLitChar '\b'           =  showString "\\b"
 249 showLitChar '\f'           =  showString "\\f"
 250 showLitChar '\n'           =  showString "\\n"
 251 showLitChar '\r'           =  showString "\\r"
 252 showLitChar '\t'           =  showString "\\t"
 253 showLitChar '\v'           =  showString "\\v"
 254 showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")
 255 showLitChar c              =  showString ('\\' : asciiTab!!ord c)
 256
 257 protectEsc p f             = f . cont
 258                              where cont s@(c:_) | p c = "\\&" ++ s
 259                                    cont s             = s
 260
 261 {-# SPECIALIZE readDec :: ReadS Int, ReadS Integer #-}
 262 -- specialisations of readInt should happen automagically
 263 {-# SPECIALIZE showInt :: Int -> ShowS, Integer -> ShowS #-}
 264
 265 readDec, readOct, readHex :: (Integral a) => ReadS a
 266 readDec = readInt 10 isDigit (\d -> ord d - i_ord_0)
 267 readOct = readInt  8 isOctDigit (\d -> ord d - i_ord_0)
 268 readHex = readInt 16 isHexDigit hex
 269             where hex d = ord d - (if isDigit d then i_ord_0
 270                                    else ord (if isUpper d then 'A' else 'a')
 271                                         - 10)
 272
 273 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
 274 readInt radix isDig digToInt s =
 275     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
 276         | (ds,r) <- nonnull isDig s ]
 277
 278 showInt :: (Integral a) => a -> ShowS
 279 {- USE_REPORT_PRELUDE
 280 showInt n r = let (n',d) = quotRem n 10
 281                   r' = chr (i_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 (i_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 -- #endif /* ! USE_REPORT_PRELUDE */
 295
 296 {-# SPECIALIZE readSigned :: ReadS Int     -> ReadS Int,
 297                              ReadS Integer -> ReadS Integer,
 298                              ReadS Double  -> ReadS Double #-}
 299 {-# SPECIALIZE showSigned :: (Int     -> ShowS) -> Int -> Int     -> ShowS = showSigned_Int,
 300                              (Integer -> ShowS) -> Int -> Integer -> ShowS = showSigned_Integer,
 301                              (Double  -> ShowS) -> Int -> Double  -> ShowS #-}
 302 {-# SPECIALIZE readFloat  :: ReadS Float,
 303                              ReadS Double #-}
 304 {-# SPECIALIZE showFloat  :: Float -> ShowS, Double -> ShowS #-}
 305
 306 readSigned:: (Real a) => ReadS a -> ReadS a
 307 readSigned readPos = readParen False read'
 308                      where read' r  = read'' r ++
 309                                       [(-x,t) | ("-",s) <- lex r,
 310                                                 (x,t)   <- read'' s]
 311                            read'' r = [(n,s)  | (str,s) <- lex r,
 312                                                 (n,"")  <- readPos str]
 313
 314 -- ******************************************************************
 315
 316 showSigned:: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
 317 showSigned showPos p x = if x < 0 then showParen (p > 6)
 318                                                  (showChar '-' . showPos (-x))
 319                                   else showPos x
 320
 321 showSigned_Int :: (Int -> ShowS) -> Int -> Int -> ShowS
 322 showSigned_Int _ p n r
 323   = -- from HBC version; support code follows
 324     if n < 0 && p > 6 then '(':itos n++(')':r) else itos n ++ r
 325
 326 showSigned_Integer :: (Integer -> ShowS) -> Int -> Integer -> ShowS
 327 showSigned_Integer _ p n r
 328   = -- from HBC version; support code follows
 329     if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
 330
 331 itos :: Int -> String
 332 itos n =
 333     if n < 0 then
 334         if -n < 0 then
 335             -- n is minInt, a difficult number
 336             itos (n `quot` 10) ++ itos' (-(n `rem` 10)) []
 337         else
 338             '-':itos' (-n) []
 339     else
 340         itos' n []
 341   where
 342     itos' :: Int -> String -> String
 343     itos' n cs =
 344         if n < 10 then
 345             chr (n + i_ord_0) : cs
 346         else
 347             itos' (n `quot` 10) (chr (n `rem` 10+i_ord_0) : cs)
 348
 349 i_ord_0 :: Int
 350 j_ord_0 :: Integer
 351 i_ord_0 = ord '0'
 352 j_ord_0 = toInteger (ord '0')
 353
 354 jtos :: Integer -> String
 355 jtos n =
 356     if n < 0 then
 357         if -n < 0 then
 358             -- n is minInt, a difficult number
 359             jtos (n `quot` 10) ++ jtos' (-(n `rem` 10)) []
 360         else
 361             '-':jtos' (-n) []
 362     else
 363         jtos' n []
 364   where
 365     jtos' :: Integer -> String -> String
 366     jtos' n cs =
 367         if n < 10 then
 368             chr (fromInteger (n + j_ord_0)) : cs
 369         else
 370             jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10+j_ord_0)) : cs)
 371
 372 -- ******************************************************************
 373
 374 -- The functions readFloat and showFloat below use rational arithmetic
 375 -- to insure correct conversion between the floating-point radix and
 376 -- decimal.  It is often possible to use a higher-precision floating-
 377 -- point type to obtain the same results.
 378
 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 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                       ((fromIntegral 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 (i_ord_0 + d)
 461              | otherwise = chr (ord 'a' + (d - 10))