ghc/lib/std/PrelRead.lhs

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