ghc/lib/ghc/PrelRead.lhs

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