GHC/Read.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: Read.lhs,v 1.3 2001/12/21 15:07:25 simonmar Exp $
   3 %
   4 % (c) The University of Glasgow, 1994-2000
   5 %
   6
   7 \section[GHC.Read]{Module @GHC.Read@}
   8
   9 Instances of the Read class.
  10
  11 \begin{code}
  12 {-# OPTIONS -fno-implicit-prelude #-}
  13
  14 module GHC.Read where
  15
  16 import Data.Maybe
  17 import Data.Either
  18
  19 import {-# SOURCE #-} GHC.Err           ( error )
  20 import GHC.Enum         ( Enum(..), maxBound )
  21 import GHC.Num
  22 import GHC.Real
  23 import GHC.Float
  24 import GHC.List
  25 import GHC.Show         -- isAlpha etc
  26 import GHC.Base
  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 In this module we treat [(a,String)] as a monad in Control.MonadPlus
  61 But Control.MonadPlus isn't defined yet, so we simply give local
  62 declarations for mzero and guard suitable for this particular
  63 type.  It would also be reasonably to move Control.MonadPlus to GHC.Base
  64 along with Control.Monad and Functor, but that seems overkill for one
  65 example
  66
  67 \begin{code}
  68 mzero :: [a]
  69 mzero = []
  70
  71 guard :: Bool -> [()]
  72 guard True  = [()]
  73 guard False = []
  74 \end{code}
  75
  76 %*********************************************************
  77 %*                                                      *
  78 \subsection{Utility functions}
  79 %*                                                      *
  80 %*********************************************************
  81
  82 \begin{code}
  83 reads           :: (Read a) => ReadS a
  84 reads           =  readsPrec 0
  85
  86 read            :: (Read a) => String -> a
  87 read s          =
  88    case read_s s of
  89 #ifndef NEW_READS_REP
  90       [x]     -> x
  91       []      -> error "Prelude.read: no parse"
  92       _       -> error "Prelude.read: ambiguous parse"
  93 #else
  94       Just x  -> x
  95       Nothing -> error "Prelude.read: no parse"
  96 #endif
  97  where
  98   read_s str = do
  99     (x,str1) <- reads str
 100     ("","")  <- lex str1
 101     return x
 102 \end{code}
 103
 104 \begin{code}
 105 readParen       :: Bool -> ReadS a -> ReadS a
 106 readParen b g   =  if b then mandatory else optional
 107                    where optional r  = g r ++ mandatory r
 108                          mandatory r = do
 109                                 ("(",s) <- lex r
 110                                 (x,t)   <- optional s
 111                                 (")",u) <- lex t
 112                                 return (x,u)
 113
 114
 115 readList__ :: ReadS a -> ReadS [a]
 116
 117 readList__ readx
 118   = readParen False (\r -> do
 119                        ("[",s) <- lex r
 120                        readl s)
 121   where readl  s =
 122            (do { ("]",t) <- lex s ; return ([],t) }) ++
 123            (do { (x,t) <- readx s ; (xs,u) <- readl2 t ; return (x:xs,u) })
 124
 125         readl2 s =
 126            (do { ("]",t) <- lex s ; return ([],t) }) ++
 127            (do { (",",t) <- lex s ; (x,u) <- readx t ; (xs,v) <- readl2 u ; return (x:xs,v) })
 128
 129 \end{code}
 130
 131
 132 %*********************************************************
 133 %*                                                      *
 134 \subsection{Lexical analysis}
 135 %*                                                      *
 136 %*********************************************************
 137
 138 This lexer is not completely faithful to the Haskell lexical syntax.
 139 Current limitations:
 140    Qualified names are not handled properly
 141    A `--' does not terminate a symbol
 142    Octal and hexidecimal numerics are not recognized as a single token
 143
 144 \begin{code}
 145 lex                   :: ReadS String
 146
 147 lex ""                = return ("","")
 148 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
 149 lex ('\'':s)          = do
 150             (ch, '\'':t) <- lexLitChar s
 151             guard (ch /= "'")
 152             return ('\'':ch++"'", t)
 153 lex ('"':s)           = do
 154             (str,t) <- lexString s
 155             return ('"':str, t)
 156
 157           where
 158             lexString ('"':s) = return ("\"",s)
 159             lexString s = do
 160                     (ch,t)  <- lexStrItem s
 161                     (str,u) <- lexString t
 162                     return (ch++str, u)
 163
 164
 165             lexStrItem ('\\':'&':s) = return ("\\&",s)
 166             lexStrItem ('\\':c:s) | isSpace c = do
 167                         ('\\':t) <- return (dropWhile isSpace s)
 168                         return ("\\&",t)
 169             lexStrItem s            = lexLitChar s
 170
 171 lex (c:s) | isSingle c = return ([c],s)
 172           | isSym c    = do
 173                 (sym,t) <- return (span isSym s)
 174                 return (c:sym,t)
 175           | isAlpha c  = do
 176                 (nam,t) <- return (span isIdChar s)
 177                 return (c:nam, t)
 178           | isDigit c  = do
 179 {- Removed, 13/03/2000 by SDM.
 180    Doesn't work, and not required by Haskell report.
 181                  let
 182                   (pred, s', isDec) =
 183                     case s of
 184                       ('o':rs) -> (isOctDigit, rs, False)
 185                       ('O':rs) -> (isOctDigit, rs, False)
 186                       ('x':rs) -> (isHexDigit, rs, False)
 187                       ('X':rs) -> (isHexDigit, rs, False)
 188                       _        -> (isDigit, s, True)
 189 -}
 190                  (ds,s)  <- return (span isDigit s)
 191                  (fe,t)  <- lexFracExp s
 192                  return (c:ds++fe,t)
 193           | otherwise  = mzero    -- bad character
 194              where
 195               isSingle c =  c `elem` ",;()[]{}_`"
 196               isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
 197               isIdChar c =  isAlphaNum c || c `elem` "_'"
 198
 199               lexFracExp ('.':c:cs) | isDigit c = do
 200                         (ds,t) <- lex0Digits cs
 201                         (e,u)  <- lexExp t
 202                         return ('.':c:ds++e,u)
 203               lexFracExp s        = return ("",s)
 204
 205               lexExp (e:s) | e `elem` "eE" =
 206                   (do
 207                     (c:t) <- return s
 208                     guard (c `elem` "+-")
 209                     (ds,u) <- lexDecDigits t
 210                     return (e:c:ds,u))      ++
 211                   (do
 212                     (ds,t) <- lexDecDigits s
 213                     return (e:ds,t))
 214
 215               lexExp s = return ("",s)
 216
 217 lexDigits            :: ReadS String
 218 lexDigits            = lexDecDigits
 219
 220 lexDecDigits            :: ReadS String
 221 lexDecDigits            =  nonnull isDigit
 222
 223 lexOctDigits            :: ReadS String
 224 lexOctDigits            =  nonnull isOctDigit
 225
 226 lexHexDigits            :: ReadS String
 227 lexHexDigits            =  nonnull isHexDigit
 228
 229 -- 0 or more digits
 230 lex0Digits               :: ReadS String
 231 lex0Digits  s            =  return (span isDigit s)
 232
 233 nonnull                 :: (Char -> Bool) -> ReadS String
 234 nonnull p s             = do
 235             (cs@(_:_),t) <- return (span p s)
 236             return (cs,t)
 237
 238 lexLitChar              :: ReadS String
 239 lexLitChar ('\\':s)     =  do
 240             (esc,t) <- lexEsc s
 241             return ('\\':esc, t)
 242        where
 243         lexEsc (c:s)     | c `elem` escChars = return ([c],s)
 244         lexEsc s@(d:_)   | isDigit d         = checkSize 10 lexDecDigits s
 245         lexEsc ('o':d:s) | isOctDigit d      = checkSize  8 lexOctDigits (d:s)
 246         lexEsc ('O':d:s) | isOctDigit d      = checkSize  8 lexOctDigits (d:s)
 247         lexEsc ('x':d:s) | isHexDigit d      = checkSize 16 lexHexDigits (d:s)
 248         lexEsc ('X':d:s) | isHexDigit d      = checkSize 16 lexHexDigits (d:s)
 249         lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] -- cf. cntrl in 2.6 of H. report.
 250         lexEsc s@(c:_)   | isUpper c            = fromAsciiLab s
 251         lexEsc _                                = mzero
 252
 253         escChars = "abfnrtv\\\"'"
 254
 255         fromAsciiLab (x:y:z:ls) | isUpper y && (isUpper z || isDigit z) &&
 256                                    [x,y,z] `elem` asciiEscTab = return ([x,y,z], ls)
 257         fromAsciiLab (x:y:ls)   | isUpper y &&
 258                                    [x,y]   `elem` asciiEscTab = return ([x,y], ls)
 259         fromAsciiLab _                                        = mzero
 260
 261         asciiEscTab = "DEL" : asciiTab
 262
 263          {-
 264            Check that the numerically escaped char literals are
 265            within accepted boundaries.
 266
 267            Note: this allows char lits with leading zeros, i.e.,
 268                  \0000000000000000000000000000001.
 269          -}
 270         checkSize base f str = do
 271            (num, res) <- f str
 272            if toAnInteger base num > toInteger (ord maxBound) 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         toAnInteger base = foldl (\ acc n -> acc*base + toInteger (digitToInt n)) 0
 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)
 528                    (map (fromInteger . toInteger . digToInt) ds), r)
 529
 530 {-# SPECIALISE readSigned ::
 531                 ReadS Int     -> ReadS Int,
 532                 ReadS Integer -> ReadS Integer,
 533                 ReadS Double  -> ReadS Double       #-}
 534 readSigned :: (Real a) => ReadS a -> ReadS a
 535 readSigned readPos = readParen False read'
 536                      where read' r  = read'' r ++
 537                                       (do
 538                                         ("-",s) <- lex r
 539                                         (x,t)   <- read'' s
 540                                         return (-x,t))
 541                            read'' r = do
 542                                (str,s) <- lex r
 543                                (n,"")  <- readPos str
 544                                return (n,s)
 545 \end{code}
 546
 547 The functions readFloat below uses rational arithmetic
 548 to ensure correct conversion between the floating-point radix and
 549 decimal.  It is often possible to use a higher-precision floating-
 550 point type to obtain the same results.
 551
 552 \begin{code}
 553 {-# SPECIALISE readFloat ::
 554                     ReadS Double,
 555                     ReadS Float     #-}
 556 readFloat :: (RealFloat a) => ReadS a
 557 readFloat r =
 558    (do
 559       (x,t) <- readRational r
 560       return (fromRational x,t) ) ++
 561    (do
 562       ("NaN",t) <- lex r
 563       return (0/0,t) ) ++
 564    (do
 565       ("Infinity",t) <- lex r
 566       return (1/0,t) )
 567
 568 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
 569 readRational r = do
 570      (n,d,s) <- readFix r
 571      (k,t)   <- readExp s
 572      return ((n%1)*10^^(k-d), 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}