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