GHC/Read.lhs

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