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