[project @ 2002-04-13 14:59:06 by panne]
[packages/base.git] / GHC / Read.lhs
1 % ------------------------------------------------------------------------------
2 % $Id: Read.lhs,v 1.6 2002/04/13 14:59:06 panne 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 
15   ( Read(..)   -- class
16   
17   -- ReadS type
18   , ReadS      -- :: *; = String -> [(a,String)]
19   
20   -- utility functions
21   , reads      -- :: Read a => ReadS a
22   , readp      -- :: Read a => ReadP a
23   , readEither -- :: Read a => String -> Either String a
24   , read       -- :: Read a => String -> a
25
26   -- H98 compatibility
27   , lex         -- :: ReadS String
28   , lexLitChar  -- :: ReadS String
29   , readLitChar -- :: ReadS Char
30   , lexDigits   -- :: ReadS String
31   
32   -- defining readers
33   , lexP       -- :: ReadPrec Lexeme
34   , paren      -- :: ReadPrec a -> ReadPrec a
35   , parens     -- :: ReadPrec a -> ReadPrec a
36   , list       -- :: ReadPrec a -> ReadPrec [a]
37   , choose     -- :: [(String, ReadPrec a)] -> ReadPrec a
38
39   -- Temporary
40   , readList__
41   , readParen
42   )
43  where
44
45 import qualified Text.ParserCombinators.ReadP as P
46
47 import Text.ParserCombinators.ReadP
48   ( ReadP
49   , readP_to_S
50   , readS_to_P
51   )
52
53 import qualified Text.Read.Lex as L
54
55 import Text.Read.Lex
56   ( Lexeme(..)
57   , Number(..)
58   , numberToInt
59   , numberToInteger
60   , numberToFloat
61   , numberToDouble
62   )
63
64 import Text.ParserCombinators.ReadPrec
65
66 import Data.Maybe
67 import Data.Either
68
69 import {-# SOURCE #-} GHC.Err           ( error )
70 import GHC.Num
71 import GHC.Real
72 import GHC.Float
73 import GHC.List
74 import GHC.Show         -- isAlpha etc
75 import GHC.Base
76
77 ratioPrec = 7   -- Precedence of ':%' constructor
78 appPrec   = 10  -- Precedence of applictaion
79 \end{code}
80 -------------------------------------------------------
81         TEMPORARY UNTIL I DO DERIVED READ
82
83 \begin{code}
84 readParen       :: Bool -> ReadS a -> ReadS a
85 readParen b g   =  if b then mandatory else optional
86                    where optional r  = g r ++ mandatory r
87                          mandatory r = do
88                                 ("(",s) <- lex r
89                                 (x,t)   <- optional s
90                                 (")",u) <- lex t
91                                 return (x,u)
92
93
94 readList__ :: ReadS a -> ReadS [a]
95
96 readList__ readx
97   = readParen False (\r -> do
98                        ("[",s) <- lex r
99                        readl s)
100   where readl  s = 
101            (do { ("]",t) <- lex s ; return ([],t) }) ++
102            (do { (x,t) <- readx s ; (xs,u) <- readl2 t ; return (x:xs,u) })
103
104         readl2 s = 
105            (do { ("]",t) <- lex s ; return ([],t) }) ++
106            (do { (",",t) <- lex s ; (x,u) <- readx t ; (xs,v) <- readl2 u ; return (x:xs,v) })
107 \end{code}
108
109
110 %*********************************************************
111 %*                                                      *
112 \subsection{The @Read@ class and @ReadS@ type}
113 %*                                                      *
114 %*********************************************************
115
116 \begin{code}
117 ------------------------------------------------------------------------
118 -- ReadS
119
120 type ReadS a = String -> [(a,String)]
121
122 ------------------------------------------------------------------------
123 -- class Read
124
125 class Read a where
126   readsPrec    :: Int -> ReadS a
127   readList     :: ReadS [a]
128   readPrec     :: ReadPrec a
129   readListPrec :: ReadPrec [a]
130   
131   -- default definitions
132   readsPrec    = readPrec_to_S readPrec
133   readList     = readPrec_to_S (list readPrec) 0
134   readPrec     = readS_to_Prec readsPrec
135   readListPrec = readS_to_Prec (\_ -> readList)
136
137 readListDefault :: Read a => ReadS [a]
138 readListDefault = readPrec_to_S readListPrec 0
139
140 readListPrecDefault :: Read a => ReadPrec [a]
141 readListPrecDefault = list readPrec
142
143 ------------------------------------------------------------------------
144 -- utility functions
145
146 reads :: Read a => ReadS a
147 reads = readsPrec minPrec
148
149 readp :: Read a => ReadP a
150 readp = readPrec_to_P readPrec minPrec
151
152 readEither :: Read a => String -> Either String a
153 readEither s =
154   case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
155     [x] -> Right x
156     []  -> Left "Prelude.read: no parse"
157     _   -> Left "Prelude.read: ambiguous parse"
158  where
159   read' =
160     do x <- readPrec
161        lift P.skipSpaces
162        return x
163
164 read :: Read a => String -> a
165 read s = either error id (readEither s)
166
167 ------------------------------------------------------------------------
168 -- H98 compatibility
169
170 lex :: ReadS String             -- As defined by H98
171 lex "" = [("","")] -- ugly hack
172 lex s  = readP_to_S (do { lexeme <- L.lex ;
173                           return (show lexeme) }) s
174
175 lexLitChar :: ReadS String      -- As defined by H98
176 lexLitChar = readP_to_S (do { lexeme <- L.lexLitChar ;
177                               return (show lexeme) })
178
179 readLitChar :: ReadS Char       -- As defined by H98
180 readLitChar = readP_to_S (do { Char c <- L.lexLitChar ;
181                                return c })
182
183 lexDigits :: ReadS String
184 lexDigits = readP_to_S (P.munch1 isDigit)
185
186 ------------------------------------------------------------------------
187 -- utility parsers
188
189 lexP :: ReadPrec Lexeme
190 lexP = lift L.lex
191
192 paren :: ReadPrec a -> ReadPrec a
193 -- (paren p) parses (P0) 
194 --      where p parses P0 in precedence context zero
195 paren p =
196   do Single '(' <- lexP
197      x          <- reset p
198      Single ')' <- lexP
199      return x
200
201 parens :: ReadPrec a -> ReadPrec a
202 -- (parens p) parses P, (P0), ((P0)), etc, 
203 --      where p parses P  in the current precedence context
204 --              parses P0 in precedence context zero
205 parens p = optional
206  where
207   optional  = p +++ mandatory
208   mandatory = paren optional
209
210 list :: ReadPrec a -> ReadPrec [a]
211 list readx =
212   parens
213   ( do Single '[' <- lexP
214        (listRest False +++ listNext)
215   )
216  where
217   listRest started =
218     do Single c <- lexP
219        case c of
220          ']'           -> return []
221          ',' | started -> listNext
222          _             -> pfail
223   
224   listNext =
225     do x  <- reset readx
226        xs <- listRest True
227        return (x:xs)
228
229 choose :: [(String, ReadPrec a)] -> ReadPrec a
230 -- Parse the specified lexeme and continue as specified
231 -- Esp useful for nullary constructors
232 choose sps = foldr ((+++) . try_one) pfail sps
233            where
234              try_one (s,p) = do { Ident s' <- lexP ;
235                                   if s == s' then p else pfail }
236 \end{code}
237
238
239 %*********************************************************
240 %*                                                      *
241 \subsection{Simple instances of Read}
242 %*                                                      *
243 %*********************************************************
244
245 \begin{code}
246 instance Read Char where
247   readPrec =
248     parens
249     ( do Char c <- lexP
250          return c
251     )
252
253   readListPrec =
254     parens
255     ( do String s <- lexP       -- Looks for "foo"
256          return s
257      +++
258       readListPrecDefault       -- Looks for ['f','o','o']
259     )                           -- (more generous than H98 spec)
260
261   readList = readListDefault
262
263 instance Read Bool where
264   readPrec =
265     parens
266     ( do Ident s <- lexP
267          case s of
268            "True"  -> return True
269            "False" -> return False
270            _       -> pfail
271     )
272
273   readListPrec = readListPrecDefault
274   readList     = readListDefault
275
276 instance Read Ordering where
277   readPrec =
278     parens
279     ( do Ident s <- lexP
280          case s of
281            "LT" -> return LT
282            "EQ" -> return EQ
283            "GT" -> return GT
284            _    -> pfail
285     )
286
287   readListPrec = readListPrecDefault
288   readList     = readListDefault
289 \end{code}
290
291
292 %*********************************************************
293 %*                                                      *
294 \subsection{Structure instances of Read: Maybe, List etc}
295 %*                                                      *
296 %*********************************************************
297
298 For structured instances of Read we start using the precedences.  The
299 idea is then that 'parens (prec k p)' will fail immediately when trying
300 to parse it in a context with a higher precedence level than k. But if
301 there is one parenthesis parsed, then the required precedence level
302 drops to 0 again, and parsing inside p may succeed.
303
304 'appPrec' is just the precedence level of function application (maybe
305 it should be called 'appPrec' instead).  So, if we are parsing
306 function application, we'd better require the precedence level to be
307 at least 'appPrec'. Otherwise, we have to put parentheses around it.
308
309 'step' is used to increase the precedence levels inside a
310 parser, and can be used to express left- or right- associativity. For
311 example, % is defined to be left associative, so we only increase
312 precedence on the right hand side.
313
314 Note how step is used in for example the Maybe parser to increase the
315 precedence beyond appPrec, so that basically only literals and
316 parenthesis-like objects such as (...) and [...] can be an argument to
317 'Just'.
318
319 \begin{code}
320 instance Read a => Read (Maybe a) where
321   readPrec =
322     parens
323     ( prec appPrec
324       ( do Ident "Nothing" <- lexP
325            return Nothing
326        +++
327         do Ident "Just" <- lexP
328            x            <- step readPrec
329            return (Just x)
330       )
331     )
332
333   readListPrec = readListPrecDefault
334   readList     = readListDefault
335
336 instance (Read a, Read b) => Read (Either a b) where
337   readPrec =
338     parens
339     ( prec appPrec
340       ( do Ident "Left" <- lexP
341            x            <- step readPrec
342            return (Left x)
343        +++
344         do Ident "Right" <- lexP
345            y             <- step readPrec
346            return (Right y)
347       )
348     )
349
350   readListPrec = readListPrecDefault
351   readList     = readListDefault
352
353 instance Read a => Read [a] where
354   readPrec     = readListPrec
355   readListPrec = readListPrecDefault
356   readList     = readListDefault
357
358 instance Read Lexeme where
359   readPrec     = lexP
360   readListPrec = readListPrecDefault
361   readList     = readListDefault
362 \end{code}
363
364
365 %*********************************************************
366 %*                                                      *
367 \subsection{Numeric instances of Read}
368 %*                                                      *
369 %*********************************************************
370
371 \begin{code}
372 readNumber :: Num a => (Number -> Maybe a) -> ReadPrec a
373 -- Read a signed number
374 readNumber convert =
375   parens
376   ( do x <- lexP
377        case x of
378          Symbol "-" -> do n <- readNumber convert
379                           return (negate n)
380        
381          Number y   -> case convert y of
382                          Just n  -> return n
383                          Nothing -> pfail
384          
385          _          -> pfail
386   )
387
388 readIEEENumber :: (RealFloat a) => (Number -> Maybe a) -> ReadPrec a
389 -- Read a Float/Double.
390 readIEEENumber convert =
391   parens
392   ( do x <- lexP
393        case x of
394          Ident "NaN"      -> return (0/0)
395          Ident "Infinity" -> return (1/0)
396          Symbol "-" -> do n <- readIEEENumber convert
397                           return (negate n)
398        
399          Number y   -> case convert y of
400                          Just n  -> return n
401                          Nothing -> pfail
402          
403          _          -> pfail
404   )
405
406 instance Read Int where
407   readPrec     = readNumber numberToInt
408   readListPrec = readListPrecDefault
409   readList     = readListDefault
410
411 instance Read Integer where
412   readPrec     = readNumber numberToInteger
413   readListPrec = readListPrecDefault
414   readList     = readListDefault
415
416 instance Read Float where
417   readPrec     = readIEEENumber numberToFloat
418   readListPrec = readListPrecDefault
419   readList     = readListDefault
420
421 instance Read Double where
422   readPrec     = readIEEENumber numberToDouble
423   readListPrec = readListPrecDefault
424   readList     = readListDefault
425
426 instance (Integral a, Read a) => Read (Ratio a) where
427   readPrec =
428     parens
429     ( prec ratioPrec
430       ( do x          <- step readPrec
431            Symbol "%" <- lexP
432            y          <- step readPrec
433            return (x % y)
434       )
435     )
436
437   readListPrec = readListPrecDefault
438   readList     = readListDefault
439 \end{code}
440
441
442 %*********************************************************
443 %*                                                      *
444 \subsection{Tuple instances of Read}
445 %*                                                      *
446 %*********************************************************
447
448 \begin{code}
449 instance Read () where
450   readPrec =
451     parens
452     ( paren
453       ( return ()
454       )
455     )
456
457   readListPrec = readListPrecDefault
458   readList     = readListDefault
459
460 instance (Read a, Read b) => Read (a,b) where
461   readPrec =
462     parens
463     ( paren
464       ( do x <- readPrec
465            Single ',' <- lexP
466            y <- readPrec
467            return (x,y)
468       )
469     )
470
471   readListPrec = readListPrecDefault
472   readList     = readListDefault
473
474
475 instance (Read a, Read b, Read c) => Read (a, b, c) where
476   readPrec =
477     parens
478     ( paren
479       ( do x <- readPrec
480            Single ',' <- lexP
481            y <- readPrec
482            Single ',' <- lexP
483            z <- readPrec
484            return (x,y,z)
485       )
486     )
487
488   readListPrec = readListPrecDefault
489   readList     = readListDefault
490
491 instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
492   readPrec =
493     parens
494     ( paren
495       ( do w <- readPrec
496            Single ',' <- lexP
497            x <- readPrec
498            Single ',' <- lexP
499            y <- readPrec
500            Single ',' <- lexP
501            z <- readPrec
502            return (w,x,y,z)
503       )
504     )
505
506   readListPrec = readListPrecDefault
507   readList     = readListDefault
508
509 instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
510   readPrec =
511     parens
512     ( paren
513       ( do v <- readPrec
514            Single ',' <- lexP
515            w <- readPrec
516            Single ',' <- lexP
517            x <- readPrec
518            Single ',' <- lexP
519            y <- readPrec
520            Single ',' <- lexP
521            z <- readPrec
522            return (v,w,x,y,z)
523       )
524     )
525
526   readListPrec = readListPrecDefault
527   readList     = readListDefault
528 \end{code}