2 % (c) The AQUA Project, Glasgow University, 1994-1996
5 \section[PrelRead]{Module @PrelRead@}
7 Instances of the Read class.
10 {-# OPTIONS -fno-implicit-prelude #-}
14 import {-# SOURCE #-} PrelErr ( error )
23 %*********************************************************
25 \subsection{The @Read@ class}
27 %*********************************************************
30 type ReadS a = String -> [(a,String)]
33 readsPrec :: Int -> ReadS a
36 readList = readList__ reads
39 %*********************************************************
41 \subsection{Utility functions}
43 %*********************************************************
46 reads :: (Read a) => ReadS a
49 read :: (Read a) => String -> a
50 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
52 [] -> error "PreludeText.read: no parse"
53 _ -> error "PreludeText.read: ambiguous parse"
55 readParen :: Bool -> ReadS a -> ReadS a
56 readParen b g = if b then mandatory else optional
57 where optional r = g r ++ mandatory r
58 mandatory r = [(x,u) | ("(",s) <- lex r,
63 {-# GENERATE_SPECS readList__ a #-}
64 readList__ :: ReadS a -> ReadS [a]
67 = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])
68 where readl s = [([],t) | ("]",t) <- lex s] ++
69 [(x:xs,u) | (x,t) <- readx s,
71 readl2 s = [([],t) | ("]",t) <- lex s] ++
72 [(x:xs,v) | (",",t) <- lex s,
78 %*********************************************************
80 \subsection{Lexical analysis}
82 %*********************************************************
84 This lexer is not completely faithful to the Haskell lexical syntax.
86 Qualified names are not handled properly
87 A `--' does not terminate a symbol
88 Octal and hexidecimal numerics are not recognized as a single token
94 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
95 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
97 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
99 lexString ('"':s) = [("\"",s)]
100 lexString s = [(ch++str, u)
101 | (ch,t) <- lexStrItem s,
102 (str,u) <- lexString t ]
104 lexStrItem ('\\':'&':s) = [("\\&",s)]
105 lexStrItem ('\\':c:s) | isSpace c
106 = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
107 lexStrItem s = lexLitChar s
109 lex (c:s) | isSingle c = [([c],s)]
110 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
111 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
112 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
113 (fe,t) <- lexFracExp s ]
114 | otherwise = [] -- bad character
116 isSingle c = c `elem` ",;()[]{}_`"
117 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
118 isIdChar c = isAlphanum c || c `elem` "_'"
120 lexFracExp ('.':cs) = [('.':ds++e,u) | (ds,t) <- lex0Digits cs,
122 lexFracExp s = [("",s)]
124 lexExp (e:s) | e `elem` "eE"
125 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
126 (ds,u) <- lexDigits t] ++
127 [(e:ds,t) | (ds,t) <- lexDigits s]
130 lexDigits :: ReadS String
131 lexDigits = nonnull isDigit
134 lex0Digits :: ReadS String
135 lex0Digits s = [span isDigit s]
137 nonnull :: (Char -> Bool) -> ReadS String
138 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
140 lexLitChar :: ReadS String
141 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
143 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
144 lexEsc s@(d:_) | isDigit d = lexDigits s
146 lexLitChar (c:s) = [([c],s)]
150 %*********************************************************
152 \subsection{Instances of @Read@}
154 %*********************************************************
157 instance Read Char where
158 readsPrec p = readParen False
159 (\r -> [(c,t) | ('\'':s,t)<- lex r,
160 (c,_) <- readLitChar s])
162 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
164 where readl ('"':s) = [("",s)]
165 readl ('\\':'&':s) = readl s
166 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
169 instance Read Bool where
170 readsPrec p = readParen False
171 (\r -> let lr = lex r
173 [(True, rest) | ("True", rest) <- lr] ++
174 [(False,rest) | ("False",rest) <- lr])
177 instance Read Ordering where
178 readsPrec p = readParen False
179 (\r -> let lr = lex r
181 [(LT, rest) | ("LT", rest) <- lr] ++
182 [(EQ, rest) | ("EQ", rest) <- lr] ++
183 [(GT, rest) | ("GT", rest) <- lr])
185 instance Read a => Read (Maybe a) where
186 readsPrec p = readParen False
187 (\r -> let lr = lex r
189 [(Nothing, rest) | ("Nothing", rest) <- lr] ++
190 [(Just x, rest2) | ("Just", rest1) <- lr,
191 (x, rest2) <- reads rest1])
193 instance (Read a, Read b) => Read (Either a b) where
194 readsPrec p = readParen False
195 (\r -> let lr = lex r
197 [(Left x, rest2) | ("Left", rest1) <- lr,
198 (x, rest2) <- reads rest1] ++
199 [(Right x, rest2) | ("Right", rest1) <- lr,
200 (x, rest2) <- reads rest1])
202 instance Read Int where
203 readsPrec p x = readSigned readDec x
205 instance Read Integer where
206 readsPrec p x = readSigned readDec x
208 instance Read Float where
209 readsPrec p x = readSigned readFloat x
211 instance Read Double where
212 readsPrec p x = readSigned readFloat x
214 instance (Integral a, Read a) => Read (Ratio a) where
215 readsPrec p = readParen (p > ratio_prec)
216 (\r -> [(x%y,u) | (x,s) <- reads r,
220 instance (Read a) => Read [a] where
221 readsPrec p = readList
223 instance Read () where
224 readsPrec p = readParen False
225 (\r -> [((),t) | ("(",s) <- lex r,
228 instance (Read a, Read b) => Read (a,b) where
229 readsPrec p = readParen False
230 (\r -> [((x,y), w) | ("(",s) <- lex r,
236 instance (Read a, Read b, Read c) => Read (a, b, c) where
237 readsPrec p = readParen False
238 (\a -> [((x,y,z), h) | ("(",b) <- lex a,
239 (x,c) <- readsPrec 0 b,
241 (y,e) <- readsPrec 0 d,
243 (z,g) <- readsPrec 0 f,
246 instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
247 readsPrec p = readParen False
248 (\a -> [((w,x,y,z), j) | ("(",b) <- lex a,
249 (w,c) <- readsPrec 0 b,
251 (x,e) <- readsPrec 0 d,
253 (y,g) <- readsPrec 0 f,
255 (z,i) <- readsPrec 0 h,
258 instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
259 readsPrec p = readParen False
260 (\a -> [((w,x,y,z,v), l) | ("(",b) <- lex a,
261 (w,c) <- readsPrec 0 b,
263 (x,e) <- readsPrec 0 d,
265 (y,g) <- readsPrec 0 f,
267 (z,i) <- readsPrec 0 h,
269 (v,k) <- readsPrec 0 j,
274 %*********************************************************
276 \subsection{Reading characters}
278 %*********************************************************
281 readLitChar :: ReadS Char
283 readLitChar ('\\':s) = readEsc s
285 readEsc ('a':s) = [('\a',s)]
286 readEsc ('b':s) = [('\b',s)]
287 readEsc ('f':s) = [('\f',s)]
288 readEsc ('n':s) = [('\n',s)]
289 readEsc ('r':s) = [('\r',s)]
290 readEsc ('t':s) = [('\t',s)]
291 readEsc ('v':s) = [('\v',s)]
292 readEsc ('\\':s) = [('\\',s)]
293 readEsc ('"':s) = [('"',s)]
294 readEsc ('\'':s) = [('\'',s)]
295 readEsc ('^':c:s) | c >= '@' && c <= '_'
296 = [(chr (ord c - ord '@'), s)]
297 readEsc s@(d:_) | isDigit d
298 = [(chr n, t) | (n,t) <- readDec s]
299 readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s]
300 readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s]
301 readEsc s@(c:_) | isUpper c
302 = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
303 in case [(c,s') | (c, mne) <- table,
304 ([],s') <- [match mne s]]
308 readLitChar (c:s) = [(c,s)]
310 match :: (Eq a) => [a] -> [a] -> ([a],[a])
311 match (x:xs) (y:ys) | x == y = match xs ys
312 match xs ys = (xs,ys)
317 %*********************************************************
319 \subsection{Reading numbers}
321 %*********************************************************
324 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
325 readDec :: (Integral a) => ReadS a
326 readDec = readInt 10 isDigit (\d -> ord d - ord_0)
328 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
329 readOct :: (Integral a) => ReadS a
330 readOct = readInt 8 isOctDigit (\d -> ord d - ord_0)
332 {-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-}
333 readHex :: (Integral a) => ReadS a
334 readHex = readInt 16 isHexDigit hex
335 where hex d = ord d - (if isDigit d then ord_0
336 else ord (if isUpper d then 'A' else 'a') - 10)
338 {-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-}
339 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
340 readInt radix isDig digToInt s =
341 [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r)
342 | (ds,r) <- nonnull isDig s ]
344 {-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-}
345 readSigned :: (Real a) => ReadS a -> ReadS a
346 readSigned readPos = readParen False read'
347 where read' r = read'' r ++
348 [(-x,t) | ("-",s) <- lex r,
350 read'' r = [(n,s) | (str,s) <- lex r,
351 (n,"") <- readPos str]
354 The functions readFloat below uses rational arithmetic
355 to insure correct conversion between the floating-point radix and
356 decimal. It is often possible to use a higher-precision floating-
357 point type to obtain the same results.
360 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
361 readFloat :: (RealFloat a) => ReadS a
362 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
364 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
367 = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
368 (k,t) <- readExp s] ++
369 [(0/0, t) | ("NaN", t) <- lex r] ++
370 [(1/0, t) | ("Infinity", t) <- lex r]
371 where readFix r = [(read (ds++ds'), length ds', t)
372 | (ds,s) <- lexDigits r,
373 (ds',t) <- lexDotDigits s ]
375 readExp (e:s) | e `elem` "eE" = readExp' s
378 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
379 readExp' ('+':s) = readDec s
380 readExp' s = readDec s
382 lexDotDigits ('.':s) = lex0Digits s
383 lexDotDigits s = [("",s)]
385 readRational__ :: String -> Rational -- we export this one (non-std)
386 -- NB: *does* handle a leading "-"
389 '-' : xs -> - (read_me xs)
393 = case [x | (x,t) <- readRational s, ("","") <- lex t] of
395 [] -> error ("readRational__: no parse:" ++ top_s)
396 _ -> error ("readRational__: ambiguous parse:" ++ top_s)
398 -- The number of decimal digits m below is chosen to guarantee
399 -- read (show x) == x. See
400 -- Matula, D. W. A formalization of floating-point numeric base
401 -- conversion. IEEE Transactions on Computers C-19, 8 (1970 August),