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