ghc/lib/std/PrelRead.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   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 \end{code}
  22
  23 %*********************************************************
  24 %*                                                      *
  25 \subsection{The @Read@ class}
  26 %*                                                      *
  27 %*********************************************************
  28
  29 \begin{code}
  30 type  ReadS a   = String -> [(a,String)]
  31
  32 class  Read a  where
  33     readsPrec :: Int -> ReadS a
  34
  35     readList  :: ReadS [a]
  36     readList   = readList__ reads
  37 \end{code}
  38
  39 %*********************************************************
  40 %*                                                      *
  41 \subsection{Utility functions}
  42 %*                                                      *
  43 %*********************************************************
  44
  45 \begin{code}
  46 reads           :: (Read a) => ReadS a
  47 reads           =  readsPrec 0
  48
  49 read            :: (Read a) => String -> a
  50 read s          =  case [x | (x,t) <- reads s, ("","") <- lex t] of
  51                         [x] -> x
  52                         []  -> error "PreludeText.read: no parse"
  53                         _   -> error "PreludeText.read: ambiguous parse"
  54
  55 readParen       :: Bool -> ReadS a -> ReadS a
  56 readParen b g   =  if b then mandatory else optional
  57                    where optional r  = g r ++ mandatory r
  58                          mandatory r = [(x,u) | ("(",s) <- lex r,
  59                                                 (x,t)   <- optional s,
  60                                                 (")",u) <- lex t    ]
  61
  62
  63 {-# GENERATE_SPECS readList__ a #-}
  64 readList__ :: ReadS a -> ReadS [a]
  65
  66 readList__ readx
  67   = readParen False (\r -> [pr | ("[",s)  <- lex r, pr <- readl s])
  68   where readl  s = [([],t)   | ("]",t)  <- lex s] ++
  69                    [(x:xs,u) | (x,t)    <- readx s,
  70                                (xs,u)   <- readl2 t]
  71         readl2 s = [([],t)   | ("]",t)  <- lex s] ++
  72                    [(x:xs,v) | (",",t)  <- lex s,
  73                                (x,u)    <- readx t,
  74                                (xs,v)   <- readl2 u]
  75 \end{code}
  76
  77
  78 %*********************************************************
  79 %*                                                      *
  80 \subsection{Lexical analysis}
  81 %*                                                      *
  82 %*********************************************************
  83
  84 This lexer is not completely faithful to the Haskell lexical syntax.
  85 Current limitations:
  86    Qualified names are not handled properly
  87    A `--' does not terminate a symbol
  88    Octal and hexidecimal numerics are not recognized as a single token
  89
  90 \begin{code}
  91 lex                   :: ReadS String
  92
  93 lex ""                = [("","")]
  94 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
  95 lex ('\'':s)          = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
  96                                               ch /= "'"                ]
  97 lex ('"':s)           = [('"':str, t)      | (str,t) <- lexString s]
  98                         where
  99                         lexString ('"':s) = [("\"",s)]
 100                         lexString s = [(ch++str, u)
 101                                               | (ch,t)  <- lexStrItem s,
 102                                                 (str,u) <- lexString t  ]
 103
 104                         lexStrItem ('\\':'&':s) = [("\\&",s)]
 105                         lexStrItem ('\\':c:s) | isSpace c
 106                             = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
 107                         lexStrItem s            = lexLitChar s
 108
 109 lex (c:s) | isSingle c = [([c],s)]
 110           | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]
 111           | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]
 112           | isDigit c  = [(c:ds++fe,t)    | (ds,s)  <- [span isDigit s],
 113                                             (fe,t)  <- lexFracExp s     ]
 114           | otherwise  = []    -- bad character
 115              where
 116               isSingle c =  c `elem` ",;()[]{}_`"
 117               isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
 118               isIdChar c =  isAlphanum c || c `elem` "_'"
 119
 120               lexFracExp ('.':cs)   = [('.':ds++e,u) | (ds,t) <- lex0Digits cs,
 121                                                        (e,u)  <- lexExp t]
 122               lexFracExp s          = [("",s)]
 123
 124               lexExp (e:s) | e `elem` "eE"
 125                        = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
 126                                                  (ds,u) <- lexDigits t] ++
 127                          [(e:ds,t)   | (ds,t) <- lexDigits s]
 128               lexExp s = [("",s)]
 129
 130 lexDigits               :: ReadS String
 131 lexDigits               =  nonnull isDigit
 132
 133 -- 0 or more digits
 134 lex0Digits               :: ReadS String
 135 lex0Digits  s            =  [span isDigit s]
 136
 137 nonnull                 :: (Char -> Bool) -> ReadS String
 138 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
 139
 140 lexLitChar              :: ReadS String
 141 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
 142         where
 143         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
 144         lexEsc s@(d:_)   | isDigit d               = lexDigits s
 145         lexEsc _                                   = []
 146 lexLitChar (c:s)        =  [([c],s)]
 147 lexLitChar ""           =  []
 148 \end{code}
 149
 150 %*********************************************************
 151 %*                                                      *
 152 \subsection{Instances of @Read@}
 153 %*                                                      *
 154 %*********************************************************
 155
 156 \begin{code}
 157 instance  Read Char  where
 158     readsPrec p      = readParen False
 159                             (\r -> [(c,t) | ('\'':s,t)<- lex r,
 160                                             (c,_)     <- readLitChar s])
 161
 162     readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
 163                                                (l,_)      <- readl s ])
 164                where readl ('"':s)      = [("",s)]
 165                      readl ('\\':'&':s) = readl s
 166                      readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,
 167                                                       (cs,u) <- readl t       ]
 168
 169 instance Read Bool where
 170     readsPrec p = readParen False
 171                         (\r ->  let lr = lex r
 172                                 in
 173                                 [(True, rest) | ("True", rest) <- lr] ++
 174                                 [(False,rest) | ("False",rest) <- lr])
 175
 176
 177 instance Read Ordering where
 178     readsPrec p = readParen False
 179                         (\r ->  let lr = lex r
 180                                 in
 181                                 [(LT, rest) | ("LT", rest) <- lr] ++
 182                                 [(EQ, rest) | ("EQ", rest) <- lr] ++
 183                                 [(GT, rest) | ("GT", rest) <- lr])
 184
 185 instance Read a => Read (Maybe a) where
 186     readsPrec p = readParen False
 187                         (\r ->  let lr = lex r
 188                                 in
 189                                 [(Nothing, rest) | ("Nothing", rest) <- lr] ++
 190                                 [(Just x, rest2) | ("Just", rest1) <- lr,
 191                                                    (x, rest2) <- reads rest1])
 192
 193 instance (Read a, Read b) => Read (Either a b) where
 194     readsPrec p = readParen False
 195                         (\r ->  let lr = lex r
 196                                 in
 197                                 [(Left x, rest2)  | ("Left", rest1) <- lr,
 198                                                     (x, rest2) <- reads rest1] ++
 199                                 [(Right x, rest2) | ("Right", rest1) <- lr,
 200                                                     (x, rest2) <- reads rest1])
 201
 202 instance  Read Int  where
 203     readsPrec p x = readSigned readDec x
 204
 205 instance  Read Integer  where
 206     readsPrec p x = readSigned readDec x
 207
 208 instance  Read Float  where
 209     readsPrec p x = readSigned readFloat x
 210
 211 instance  Read Double  where
 212     readsPrec p x = readSigned readFloat x
 213
 214 instance  (Integral a, Read a)  => Read (Ratio a)  where
 215     readsPrec p  =  readParen (p > ratio_prec)
 216                               (\r -> [(x%y,u) | (x,s)   <- reads r,
 217                                                 ("%",t) <- lex s,
 218                                                 (y,u)   <- reads t ])
 219
 220 instance  (Read a) => Read [a]  where
 221     readsPrec p         = readList
 222
 223 instance Read () where
 224     readsPrec p    = readParen False
 225                             (\r -> [((),t) | ("(",s) <- lex r,
 226                                              (")",t) <- lex s ] )
 227
 228 instance  (Read a, Read b) => Read (a,b)  where
 229     readsPrec p = readParen False
 230                             (\r -> [((x,y), w) | ("(",s) <- lex r,
 231                                                  (x,t)   <- reads s,
 232                                                  (",",u) <- lex t,
 233                                                  (y,v)   <- reads u,
 234                                                  (")",w) <- lex v ] )
 235
 236 instance (Read a, Read b, Read c) => Read (a, b, c) where
 237     readsPrec p = readParen False
 238                         (\a -> [((x,y,z), h) | ("(",b) <- lex a,
 239                                                (x,c)   <- readsPrec 0 b,
 240                                                (",",d) <- lex c,
 241                                                (y,e)   <- readsPrec 0 d,
 242                                                (",",f) <- lex e,
 243                                                (z,g)   <- readsPrec 0 f,
 244                                                (")",h) <- lex g ] )
 245
 246 instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
 247     readsPrec p = readParen False
 248                     (\a -> [((w,x,y,z), j) | ("(",b) <- lex a,
 249                                              (w,c)   <- readsPrec 0 b,
 250                                              (",",d) <- lex c,
 251                                              (x,e)   <- readsPrec 0 d,
 252                                              (",",f) <- lex e,
 253                                              (y,g)   <- readsPrec 0 f,
 254                                              (",",h) <- lex g,
 255                                              (z,i)   <- readsPrec 0 h,
 256                                              (")",j) <- lex i ] )
 257
 258 instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
 259     readsPrec p = readParen False
 260                     (\a -> [((w,x,y,z,v), l) | ("(",b) <- lex a,
 261                                                (w,c)   <- readsPrec 0 b,
 262                                                (",",d) <- lex c,
 263                                                (x,e)   <- readsPrec 0 d,
 264                                                (",",f) <- lex e,
 265                                                (y,g)   <- readsPrec 0 f,
 266                                                (",",h) <- lex g,
 267                                                (z,i)   <- readsPrec 0 h,
 268                                                (",",j) <- lex i,
 269                                                (v,k)   <- readsPrec 0 j,
 270                                                (")",l) <- lex k ] )
 271 \end{code}
 272
 273
 274 %*********************************************************
 275 %*                                                      *
 276 \subsection{Reading characters}
 277 %*                                                      *
 278 %*********************************************************
 279
 280 \begin{code}
 281 readLitChar             :: ReadS Char
 282
 283 readLitChar ('\\':s)    =  readEsc s
 284         where
 285         readEsc ('a':s)  = [('\a',s)]
 286         readEsc ('b':s)  = [('\b',s)]
 287         readEsc ('f':s)  = [('\f',s)]
 288         readEsc ('n':s)  = [('\n',s)]
 289         readEsc ('r':s)  = [('\r',s)]
 290         readEsc ('t':s)  = [('\t',s)]
 291         readEsc ('v':s)  = [('\v',s)]
 292         readEsc ('\\':s) = [('\\',s)]
 293         readEsc ('"':s)  = [('"',s)]
 294         readEsc ('\'':s) = [('\'',s)]
 295         readEsc ('^':c:s) | c >= '@' && c <= '_'
 296                          = [(chr (ord c - ord '@'), s)]
 297         readEsc s@(d:_) | isDigit d
 298                          = [(chr n, t) | (n,t) <- readDec s]
 299         readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
 300         readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]
 301         readEsc s@(c:_) | isUpper c
 302                          = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
 303                            in case [(c,s') | (c, mne) <- table,
 304                                              ([],s') <- [match mne s]]
 305                               of (pr:_) -> [pr]
 306                                  []     -> []
 307         readEsc _        = []
 308 readLitChar (c:s)       =  [(c,s)]
 309
 310 match                   :: (Eq a) => [a] -> [a] -> ([a],[a])
 311 match (x:xs) (y:ys) | x == y  =  match xs ys
 312 match xs     ys               =  (xs,ys)
 313
 314 \end{code}
 315
 316
 317 %*********************************************************
 318 %*                                                      *
 319 \subsection{Reading numbers}
 320 %*                                                      *
 321 %*********************************************************
 322
 323 \begin{code}
 324 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
 325 readDec :: (Integral a) => ReadS a
 326 readDec = readInt 10 isDigit (\d -> ord d - ord_0)
 327
 328 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
 329 readOct :: (Integral a) => ReadS a
 330 readOct = readInt 8 isOctDigit (\d -> ord d - ord_0)
 331
 332 {-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-}
 333 readHex :: (Integral a) => ReadS a
 334 readHex = readInt 16 isHexDigit hex
 335             where hex d = ord d - (if isDigit d then ord_0
 336                                    else ord (if isUpper d then 'A' else 'a') - 10)
 337
 338 {-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-}
 339 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
 340 readInt radix isDig digToInt s =
 341     [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r)
 342         | (ds,r) <- nonnull isDig s ]
 343
 344 {-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-}
 345 readSigned :: (Real a) => ReadS a -> ReadS a
 346 readSigned readPos = readParen False read'
 347                      where read' r  = read'' r ++
 348                                       [(-x,t) | ("-",s) <- lex r,
 349                                                 (x,t)   <- read'' s]
 350                            read'' r = [(n,s)  | (str,s) <- lex r,
 351                                                 (n,"")  <- readPos str]
 352 \end{code}
 353
 354 The functions readFloat below uses rational arithmetic
 355 to insure correct conversion between the floating-point radix and
 356 decimal.  It is often possible to use a higher-precision floating-
 357 point type to obtain the same results.
 358
 359 \begin{code}
 360 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
 361 readFloat :: (RealFloat a) => ReadS a
 362 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
 363
 364 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
 365
 366 readRational r
 367   = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
 368                                (k,t)   <- readExp s] ++
 369     [(0/0, t) | ("NaN", t) <- lex r] ++
 370     [(1/0, t) | ("Infinity", t) <- lex r]
 371               where readFix r = [(read (ds++ds'), length ds', t)
 372                                         | (ds,s)  <- lexDigits r,
 373                                           (ds',t) <- lexDotDigits s ]
 374
 375                     readExp (e:s) | e `elem` "eE" = readExp' s
 376                     readExp s                     = [(0,s)]
 377
 378                     readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
 379                     readExp' ('+':s) = readDec s
 380                     readExp' s       = readDec s
 381
 382                     lexDotDigits ('.':s) = lex0Digits s
 383                     lexDotDigits s       = [("",s)]
 384
 385 readRational__ :: String -> Rational -- we export this one (non-std)
 386                                     -- NB: *does* handle a leading "-"
 387 readRational__ top_s
 388   = case top_s of
 389       '-' : xs -> - (read_me xs)
 390       xs       -> read_me xs
 391   where
 392     read_me s
 393       = case [x | (x,t) <- readRational s, ("","") <- lex t] of
 394           [x] -> x
 395           []  -> error ("readRational__: no parse:"        ++ top_s)
 396           _   -> error ("readRational__: ambiguous parse:" ++ top_s)
 397
 398 -- The number of decimal digits m below is chosen to guarantee
 399 -- read (show x) == x.  See
 400 --      Matula, D. W.  A formalization of floating-point numeric base
 401 --      conversion.  IEEE Transactions on Computers C-19, 8 (1970 August),
 402 --      681-692.
 403 \end{code}
 404
 405