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