ghc/lib/std/PrelRead.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: PrelRead.lhs,v 1.19 2001/05/22 19:25:49 qrczak Exp $
   3 %
   4 % (c) The University of Glasgow, 1994-2000
   5 %
   6
   7 \section[PrelRead]{Module @PrelRead@}
   8
   9 Instances of the Read class.
  10
  11 \begin{code}
  12 {-# OPTIONS -fno-implicit-prelude #-}
  13
  14 module PrelRead where
  15
  16 import {-# SOURCE #-} PrelErr           ( error )
  17 import PrelEnum         ( Enum(..), maxBound )
  18 import PrelNum
  19 import PrelReal
  20 import PrelFloat
  21 import PrelList
  22 import PrelMaybe
  23 import PrelShow         -- isAlpha etc
  24 import PrelBase
  25
  26 -- needed for readIO and instance Read Buffermode
  27 --import PrelIOBase ( IO, userError, BufferMode(..) )
  28 --import PrelException ( ioError )
  29 \end{code}
  30
  31 %*********************************************************
  32 %*                                                      *
  33 \subsection{The @Read@ class}
  34 %*                                                      *
  35 %*********************************************************
  36
  37 Note: if you compile this with -DNEW_READS_REP, you'll get
  38 a (simpler) ReadS representation that only allow one valid
  39 parse of a string of characters, instead of a list of
  40 possible ones.
  41
  42 [changing the ReadS rep has implications for the deriving
  43 machinery for Read, a change that hasn't been made, so you
  44 probably won't want to compile in this new rep. except
  45 when in an experimental mood.]
  46
  47 \begin{code}
  48
  49 #ifndef NEW_READS_REP
  50 type  ReadS a   = String -> [(a,String)]
  51 #else
  52 type  ReadS a   = String -> Maybe (a,String)
  53 #endif
  54
  55 class  Read a  where
  56     readsPrec :: Int -> ReadS a
  57
  58     readList  :: ReadS [a]
  59     readList   = readList__ reads
  60 \end{code}
  61
  62 In this module we treat [(a,String)] as a monad in MonadPlus
  63 But MonadPlus isn't defined yet, so we simply give local
  64 declarations for mzero and guard suitable for this particular
  65 type.  It would also be reasonably to move MonadPlus to PrelBase
  66 along with Monad and Functor, but that seems overkill for one
  67 example
  68
  69 \begin{code}
  70 mzero :: [a]
  71 mzero = []
  72
  73 guard :: Bool -> [()]
  74 guard True  = [()]
  75 guard False = []
  76 \end{code}
  77
  78 %*********************************************************
  79 %*                                                      *
  80 \subsection{Utility functions}
  81 %*                                                      *
  82 %*********************************************************
  83
  84 \begin{code}
  85 reads           :: (Read a) => ReadS a
  86 reads           =  readsPrec 0
  87
  88 read            :: (Read a) => String -> a
  89 read s          =
  90    case read_s s of
  91 #ifndef NEW_READS_REP
  92       [x]     -> x
  93       []      -> error "Prelude.read: no parse"
  94       _       -> error "Prelude.read: ambiguous parse"
  95 #else
  96       Just x  -> x
  97       Nothing -> error "Prelude.read: no parse"
  98 #endif
  99  where
 100   read_s str = do
 101     (x,str1) <- reads str
 102     ("","")  <- lex str1
 103     return x
 104 \end{code}
 105
 106 \begin{code}
 107 readParen       :: Bool -> ReadS a -> ReadS a
 108 readParen b g   =  if b then mandatory else optional
 109                    where optional r  = g r ++ mandatory r
 110                          mandatory r = do
 111                                 ("(",s) <- lex r
 112                                 (x,t)   <- optional s
 113                                 (")",u) <- lex t
 114                                 return (x,u)
 115
 116
 117 readList__ :: ReadS a -> ReadS [a]
 118
 119 readList__ readx
 120   = readParen False (\r -> do
 121                        ("[",s) <- lex r
 122                        readl s)
 123   where readl  s =
 124            (do { ("]",t) <- lex s ; return ([],t) }) ++
 125            (do { (x,t) <- readx s ; (xs,u) <- readl2 t ; return (x:xs,u) })
 126
 127         readl2 s =
 128            (do { ("]",t) <- lex s ; return ([],t) }) ++
 129            (do { (",",t) <- lex s ; (x,u) <- readx t ; (xs,v) <- readl2 u ; return (x:xs,v) })
 130
 131 \end{code}
 132
 133
 134 %*********************************************************
 135 %*                                                      *
 136 \subsection{Lexical analysis}
 137 %*                                                      *
 138 %*********************************************************
 139
 140 This lexer is not completely faithful to the Haskell lexical syntax.
 141 Current limitations:
 142    Qualified names are not handled properly
 143    A `--' does not terminate a symbol
 144    Octal and hexidecimal numerics are not recognized as a single token
 145
 146 \begin{code}
 147 lex                   :: ReadS String
 148
 149 lex ""                = return ("","")
 150 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
 151 lex ('\'':s)          = do
 152             (ch, '\'':t) <- lexLitChar s
 153             guard (ch /= "'")
 154             return ('\'':ch++"'", t)
 155 lex ('"':s)           = do
 156             (str,t) <- lexString s
 157             return ('"':str, t)
 158
 159           where
 160             lexString ('"':s) = return ("\"",s)
 161             lexString s = do
 162                     (ch,t)  <- lexStrItem s
 163                     (str,u) <- lexString t
 164                     return (ch++str, u)
 165
 166
 167             lexStrItem ('\\':'&':s) = return ("\\&",s)
 168             lexStrItem ('\\':c:s) | isSpace c = do
 169                         ('\\':t) <- return (dropWhile isSpace s)
 170                         return ("\\&",t)
 171             lexStrItem s            = lexLitChar s
 172
 173 lex (c:s) | isSingle c = return ([c],s)
 174           | isSym c    = do
 175                 (sym,t) <- return (span isSym s)
 176                 return (c:sym,t)
 177           | isAlpha c  = do
 178                 (nam,t) <- return (span isIdChar s)
 179                 return (c:nam, t)
 180           | isDigit c  = do
 181 {- Removed, 13/03/2000 by SDM.
 182    Doesn't work, and not required by Haskell report.
 183                  let
 184                   (pred, s', isDec) =
 185                     case s of
 186                       ('o':rs) -> (isOctDigit, rs, False)
 187                       ('O':rs) -> (isOctDigit, rs, False)
 188                       ('x':rs) -> (isHexDigit, rs, False)
 189                       ('X':rs) -> (isHexDigit, rs, False)
 190                       _        -> (isDigit, s, True)
 191 -}
 192                  (ds,s)  <- return (span isDigit s)
 193                  (fe,t)  <- lexFracExp s
 194                  return (c:ds++fe,t)
 195           | otherwise  = mzero    -- bad character
 196              where
 197               isSingle c =  c `elem` ",;()[]{}_`"
 198               isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
 199               isIdChar c =  isAlphaNum c || c `elem` "_'"
 200
 201               lexFracExp ('.':c:cs) | isDigit c = do
 202                         (ds,t) <- lex0Digits cs
 203                         (e,u)  <- lexExp t
 204                         return ('.':c:ds++e,u)
 205               lexFracExp s        = return ("",s)
 206
 207               lexExp (e:s) | e `elem` "eE" =
 208                   (do
 209                     (c:t) <- return s
 210                     guard (c `elem` "+-")
 211                     (ds,u) <- lexDecDigits t
 212                     return (e:c:ds,u))      ++
 213                   (do
 214                     (ds,t) <- lexDecDigits s
 215                     return (e:ds,t))
 216
 217               lexExp s = return ("",s)
 218
 219 lexDigits            :: ReadS String
 220 lexDigits            = lexDecDigits
 221
 222 lexDecDigits            :: ReadS String
 223 lexDecDigits            =  nonnull isDigit
 224
 225 lexOctDigits            :: ReadS String
 226 lexOctDigits            =  nonnull isOctDigit
 227
 228 lexHexDigits            :: ReadS String
 229 lexHexDigits            =  nonnull isHexDigit
 230
 231 -- 0 or more digits
 232 lex0Digits               :: ReadS String
 233 lex0Digits  s            =  return (span isDigit s)
 234
 235 nonnull                 :: (Char -> Bool) -> ReadS String
 236 nonnull p s             = do
 237             (cs@(_:_),t) <- return (span p s)
 238             return (cs,t)
 239
 240 lexLitChar              :: ReadS String
 241 lexLitChar ('\\':s)     =  do
 242             (esc,t) <- lexEsc s
 243             return ('\\':esc, t)
 244        where
 245         lexEsc (c:s)     | c `elem` escChars = return ([c],s)
 246         lexEsc s@(d:_)   | isDigit d         = checkSize 10 lexDecDigits s
 247         lexEsc ('o':d:s) | isOctDigit d      = checkSize  8 lexOctDigits (d:s)
 248         lexEsc ('O':d:s) | isOctDigit d      = checkSize  8 lexOctDigits (d:s)
 249         lexEsc ('x':d:s) | isHexDigit d      = checkSize 16 lexHexDigits (d:s)
 250         lexEsc ('X':d:s) | isHexDigit d      = checkSize 16 lexHexDigits (d:s)
 251         lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] -- cf. cntrl in 2.6 of H. report.
 252         lexEsc s@(c:_)   | isUpper c            = fromAsciiLab s
 253         lexEsc _                                = mzero
 254
 255         escChars = "abfnrtv\\\"'"
 256
 257         fromAsciiLab (x:y:z:ls) | isUpper y && (isUpper z || isDigit z) &&
 258                                    [x,y,z] `elem` asciiEscTab = return ([x,y,z], ls)
 259         fromAsciiLab (x:y:ls)   | isUpper y &&
 260                                    [x,y]   `elem` asciiEscTab = return ([x,y], ls)
 261         fromAsciiLab _                                        = mzero
 262
 263         asciiEscTab = "DEL" : asciiTab
 264
 265          {-
 266            Check that the numerically escaped char literals are
 267            within accepted boundaries.
 268
 269            Note: this allows char lits with leading zeros, i.e.,
 270                  \0000000000000000000000000000001.
 271          -}
 272         checkSize base f str = do
 273            (num, res) <- f str
 274            if toAnInteger base num > toInteger (ord maxBound) then
 275               mzero
 276             else
 277               case base of
 278                  8  -> return ('o':num, res)
 279                  16 -> return ('x':num, res)
 280                  _  -> return (num, res)
 281
 282         toAnInteger base = foldl (\ acc n -> acc*base + toInteger (digitToInt n)) 0
 283
 284
 285 lexLitChar (c:s)        =  return ([c],s)
 286 lexLitChar ""           =  mzero
 287
 288 digitToInt :: Char -> Int
 289 digitToInt c
 290  | isDigit c            =  fromEnum c - fromEnum '0'
 291  | c >= 'a' && c <= 'f' =  fromEnum c - fromEnum 'a' + 10
 292  | c >= 'A' && c <= 'F' =  fromEnum c - fromEnum 'A' + 10
 293  | otherwise            =  error ("Char.digitToInt: not a digit " ++ show c) -- sigh
 294 \end{code}
 295
 296 %*********************************************************
 297 %*                                                      *
 298 \subsection{Instances of @Read@}
 299 %*                                                      *
 300 %*********************************************************
 301
 302 \begin{code}
 303 instance  Read Char  where
 304     readsPrec _      = readParen False
 305                             (\r -> do
 306                                 ('\'':s,t) <- lex r
 307                                 (c,"\'")   <- readLitChar s
 308                                 return (c,t))
 309
 310     readList = readParen False (\r -> do
 311                                 ('"':s,t) <- lex r
 312                                 (l,_)     <- readl s
 313                                 return (l,t))
 314                where readl ('"':s)      = return ("",s)
 315                      readl ('\\':'&':s) = readl s
 316                      readl s            = do
 317                             (c,t)  <- readLitChar s
 318                             (cs,u) <- readl t
 319                             return (c:cs,u)
 320
 321 instance Read Bool where
 322     readsPrec _ = readParen False
 323                         (\r ->
 324                            lex r >>= \ lr ->
 325                            (do { ("True", rest)  <- return lr ; return (True,  rest) }) ++
 326                            (do { ("False", rest) <- return lr ; return (False, rest) }))
 327
 328
 329 instance Read Ordering where
 330     readsPrec _ = readParen False
 331                         (\r ->
 332                            lex r >>= \ lr ->
 333                            (do { ("LT", rest) <- return lr ; return (LT,  rest) }) ++
 334                            (do { ("EQ", rest) <- return lr ; return (EQ, rest) })  ++
 335                            (do { ("GT", rest) <- return lr ; return (GT, rest) }))
 336
 337 instance Read a => Read (Maybe a) where
 338     readsPrec _ = readParen False
 339                         (\r ->
 340                             lex r >>= \ lr ->
 341                             (do { ("Nothing", rest) <- return lr ; return (Nothing, rest)}) ++
 342                             (do
 343                                 ("Just", rest1) <- return lr
 344                                 (x, rest2)      <- reads rest1
 345                                 return (Just x, rest2)))
 346
 347 instance (Read a, Read b) => Read (Either a b) where
 348     readsPrec _ = readParen False
 349                         (\r ->
 350                             lex r >>= \ lr ->
 351                             (do
 352                                 ("Left", rest1) <- return lr
 353                                 (x, rest2)      <- reads rest1
 354                                 return (Left x, rest2)) ++
 355                             (do
 356                                 ("Right", rest1) <- return lr
 357                                 (x, rest2)      <- reads rest1
 358                                 return (Right x, rest2)))
 359
 360 instance  Read Int  where
 361     readsPrec _ x = readSigned readDec x
 362
 363 instance  Read Integer  where
 364     readsPrec _ x = readSigned readDec x
 365
 366 instance  Read Float  where
 367     readsPrec _ x = readSigned readFloat x
 368
 369 instance  Read Double  where
 370     readsPrec _ x = readSigned readFloat x
 371
 372 instance  (Integral a, Read a)  => Read (Ratio a)  where
 373     readsPrec p  =  readParen (p > ratio_prec)
 374                               (\r -> do
 375                                 (x,s)   <- reads r
 376                                 ("%",t) <- lex s
 377                                 (y,u)   <- reads t
 378                                 return (x%y,u))
 379
 380 instance  (Read a) => Read [a]  where
 381     readsPrec _         = readList
 382
 383 instance Read () where
 384     readsPrec _    = readParen False
 385                             (\r -> do
 386                                 ("(",s) <- lex r
 387                                 (")",t) <- lex s
 388                                 return ((),t))
 389
 390 instance  (Read a, Read b) => Read (a,b)  where
 391     readsPrec _ = readParen False
 392                             (\r -> do
 393                                 ("(",s) <- lex r
 394                                 (x,t)   <- readsPrec 0 s
 395                                 (",",u) <- lex t
 396                                 (y,v)   <- readsPrec 0 u
 397                                 (")",w) <- lex v
 398                                 return ((x,y), w))
 399
 400 instance (Read a, Read b, Read c) => Read (a, b, c) where
 401     readsPrec _ = readParen False
 402                             (\a -> do
 403                                 ("(",b) <- lex a
 404                                 (x,c)   <- readsPrec 0 b
 405                                 (",",d) <- lex c
 406                                 (y,e)   <- readsPrec 0 d
 407                                 (",",f) <- lex e
 408                                 (z,g)   <- readsPrec 0 f
 409                                 (")",h) <- lex g
 410                                 return ((x,y,z), h))
 411
 412 instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
 413     readsPrec _ = readParen False
 414                             (\a -> do
 415                                 ("(",b) <- lex a
 416                                 (w,c)   <- readsPrec 0 b
 417                                 (",",d) <- lex c
 418                                 (x,e)   <- readsPrec 0 d
 419                                 (",",f) <- lex e
 420                                 (y,g)   <- readsPrec 0 f
 421                                 (",",h) <- lex g
 422                                 (z,h)   <- readsPrec 0 h
 423                                 (")",i) <- lex h
 424                                 return ((w,x,y,z), i))
 425
 426 instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
 427     readsPrec _ = readParen False
 428                             (\a -> do
 429                                 ("(",b) <- lex a
 430                                 (v,c)   <- readsPrec 0 b
 431                                 (",",d) <- lex c
 432                                 (w,e)   <- readsPrec 0 d
 433                                 (",",f) <- lex e
 434                                 (x,g)   <- readsPrec 0 f
 435                                 (",",h) <- lex g
 436                                 (y,i)   <- readsPrec 0 h
 437                                 (",",j) <- lex i
 438                                 (z,k)   <- readsPrec 0 j
 439                                 (")",l) <- lex k
 440                                 return ((v,w,x,y,z), l))
 441 \end{code}
 442
 443
 444 %*********************************************************
 445 %*                                                      *
 446 \subsection{Reading characters}
 447 %*                                                      *
 448 %*********************************************************
 449
 450 \begin{code}
 451 readLitChar             :: ReadS Char
 452
 453 readLitChar []          =  mzero
 454 readLitChar ('\\':s)    =  readEsc s
 455         where
 456         readEsc ('a':s)  = return ('\a',s)
 457         readEsc ('b':s)  = return ('\b',s)
 458         readEsc ('f':s)  = return ('\f',s)
 459         readEsc ('n':s)  = return ('\n',s)
 460         readEsc ('r':s)  = return ('\r',s)
 461         readEsc ('t':s)  = return ('\t',s)
 462         readEsc ('v':s)  = return ('\v',s)
 463         readEsc ('\\':s) = return ('\\',s)
 464         readEsc ('"':s)  = return ('"',s)
 465         readEsc ('\'':s) = return ('\'',s)
 466         readEsc ('^':c:s) | c >= '@' && c <= '_'
 467                          = return (chr (ord c - ord '@'), s)
 468         readEsc s@(d:_) | isDigit d
 469                          = do
 470                           (n,t) <- readDec s
 471                           return (chr n,t)
 472         readEsc ('o':s)  = do
 473                           (n,t) <- readOct s
 474                           return (chr n,t)
 475         readEsc ('x':s)  = do
 476                           (n,t) <- readHex s
 477                           return (chr n,t)
 478
 479         readEsc s@(c:_) | isUpper c
 480                          = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
 481                            in case [(c,s') | (c, mne) <- table,
 482                                              ([],s') <- [match mne s]]
 483                               of (pr:_) -> return pr
 484                                  []     -> mzero
 485         readEsc _        = mzero
 486
 487 readLitChar (c:s)       =  return (c,s)
 488
 489 match                   :: (Eq a) => [a] -> [a] -> ([a],[a])
 490 match (x:xs) (y:ys) | x == y  =  match xs ys
 491 match xs     ys               =  (xs,ys)
 492
 493 \end{code}
 494
 495
 496 %*********************************************************
 497 %*                                                      *
 498 \subsection{Reading numbers}
 499 %*                                                      *
 500 %*********************************************************
 501
 502 Note: reading numbers at bases different than 10, does not
 503 include lexing common prefixes such as '0x' or '0o' etc.
 504
 505 \begin{code}
 506 {-# SPECIALISE readDec ::
 507                 ReadS Int,
 508                 ReadS Integer #-}
 509 readDec :: (Integral a) => ReadS a
 510 readDec = readInt 10 isDigit (\d -> ord d - ord '0')
 511
 512 {-# SPECIALISE readOct ::
 513                 ReadS Int,
 514                 ReadS Integer #-}
 515 readOct :: (Integral a) => ReadS a
 516 readOct = readInt 8 isOctDigit (\d -> ord d - ord '0')
 517
 518 {-# SPECIALISE readHex ::
 519                 ReadS Int,
 520                 ReadS Integer #-}
 521 readHex :: (Integral a) => ReadS a
 522 readHex = readInt 16 isHexDigit hex
 523             where hex d = ord d - (if isDigit d then ord '0'
 524                                    else ord (if isUpper d then 'A' else 'a') - 10)
 525
 526 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
 527 readInt radix isDig digToInt s = do
 528     (ds,r) <- nonnull isDig s
 529     return (foldl1 (\n d -> n * radix + d)
 530                    (map (fromInteger . toInteger . digToInt) ds), r)
 531
 532 {-# SPECIALISE readSigned ::
 533                 ReadS Int     -> ReadS Int,
 534                 ReadS Integer -> ReadS Integer,
 535                 ReadS Double  -> ReadS Double       #-}
 536 readSigned :: (Real a) => ReadS a -> ReadS a
 537 readSigned readPos = readParen False read'
 538                      where read' r  = read'' r ++
 539                                       (do
 540                                         ("-",s) <- lex r
 541                                         (x,t)   <- read'' s
 542                                         return (-x,t))
 543                            read'' r = do
 544                                (str,s) <- lex r
 545                                (n,"")  <- readPos str
 546                                return (n,s)
 547 \end{code}
 548
 549 The functions readFloat below uses rational arithmetic
 550 to ensure correct conversion between the floating-point radix and
 551 decimal.  It is often possible to use a higher-precision floating-
 552 point type to obtain the same results.
 553
 554 \begin{code}
 555 {-# SPECIALISE readFloat ::
 556                     ReadS Double,
 557                     ReadS Float     #-}
 558 readFloat :: (RealFloat a) => ReadS a
 559 readFloat r = do
 560     (x,t) <- readRational r
 561     return (fromRational x,t)
 562
 563 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
 564
 565 readRational r =
 566    (do
 567       (n,d,s) <- readFix r
 568       (k,t)   <- readExp s
 569       return ((n%1)*10^^(k-d), t )) ++
 570    (do
 571       ("NaN",t) <- lex r
 572       return (0/0,t) ) ++
 573    (do
 574       ("Infinity",t) <- lex r
 575       return (1/0,t) )
 576  where
 577      readFix r = do
 578         (ds,s)  <- lexDecDigits r
 579         (ds',t) <- lexDotDigits s
 580         return (read (ds++ds'), length ds', t)
 581
 582      readExp (e:s) | e `elem` "eE" = readExp' s
 583      readExp s                     = return (0,s)
 584
 585      readExp' ('+':s) = readDec s
 586      readExp' ('-':s) = do
 587                         (k,t) <- readDec s
 588                         return (-k,t)
 589      readExp' s       = readDec s
 590
 591      lexDotDigits ('.':s) = lex0Digits s
 592      lexDotDigits s       = return ("",s)
 593
 594 readRational__ :: String -> Rational -- we export this one (non-std)
 595                                     -- NB: *does* handle a leading "-"
 596 readRational__ top_s
 597   = case top_s of
 598       '-' : xs -> - (read_me xs)
 599       xs       -> read_me xs
 600   where
 601     read_me s
 602       = case (do { (x,t) <- readRational s ; ("","") <- lex t ; return x }) of
 603 #ifndef NEW_READS_REP
 604           [x] -> x
 605           []  -> error ("readRational__: no parse:"        ++ top_s)
 606           _   -> error ("readRational__: ambiguous parse:" ++ top_s)
 607 #else
 608           Just x  -> x
 609           Nothing -> error ("readRational__: no parse:"        ++ top_s)
 610 #endif
 611
 612 \end{code}