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