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