2 % (c) The AQUA Project, Glasgow University, 1994-1996
5 \section[PrelRead]{Module @Prelread@}
7 The @Read@ class and many of its instances.
10 {-# OPTIONS -fno-implicit-prelude #-}
14 import {-# SOURCE #-} IOBase ( error )
21 %*********************************************************
23 \subsection{The @Read@ class}
25 %*********************************************************
28 type ReadS a = String -> [(a,String)]
31 readsPrec :: Int -> ReadS a
34 readList = readList__ reads
37 %*********************************************************
39 \subsection{Instances of @Read@}
41 %*********************************************************
44 instance Read Char where
45 readsPrec p = readParen False
46 (\r -> [(c,t) | ('\'':s,t)<- lex r,
47 (c,_) <- readLitChar s])
49 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
51 where readl ('"':s) = [("",s)]
52 readl ('\\':'&':s) = readl s
53 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
56 instance Read Bool where
57 readsPrec p = readParen False
60 [(True, rest) | ("True", rest) <- lr] ++
61 [(False,rest) | ("False",rest) <- lr])
64 instance Read Ordering where
65 readsPrec p = readParen False
68 [(LT, rest) | ("LT", rest) <- lr] ++
69 [(EQ, rest) | ("EQ", rest) <- lr] ++
70 [(GT, rest) | ("GT", rest) <- lr])
72 instance Read a => Read (Maybe a) where
73 readsPrec p = readParen False
76 [(Nothing, rest) | ("Nothing", rest) <- lr] ++
77 [(Just x, rest2) | ("Just", rest1) <- lr,
78 (x, rest2) <- reads rest1])
80 instance (Read a, Read b) => Read (Either a b) where
81 readsPrec p = readParen False
84 [(Left x, rest2) | ("Left", rest1) <- lr,
85 (x, rest2) <- reads rest1] ++
86 [(Right x, rest2) | ("Right", rest1) <- lr,
87 (x, rest2) <- reads rest1])
89 instance Read Int where
90 readsPrec p x = readSigned readDec x
92 instance Read Integer where
93 readsPrec p x = readSigned readDec x
95 instance Read Float where
96 readsPrec p x = readSigned readFloat x
98 instance Read Double where
99 readsPrec p x = readSigned readFloat x
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,
107 instance (Read a) => Read [a] where
108 readsPrec p = readList
110 instance Read () where
111 readsPrec p = readParen False
112 (\r -> [((),t) | ("(",s) <- lex r,
115 instance (Read a, Read b) => Read (a,b) where
116 readsPrec p = readParen False
117 (\r -> [((x,y), w) | ("(",s) <- lex r,
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,
128 (y,e) <- readsPrec 0 d,
130 (z,g) <- readsPrec 0 f,
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,
138 (x,e) <- readsPrec 0 d,
140 (y,g) <- readsPrec 0 f,
142 (z,i) <- readsPrec 0 h,
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,
150 (x,e) <- readsPrec 0 d,
152 (y,g) <- readsPrec 0 f,
154 (z,i) <- readsPrec 0 h,
156 (v,k) <- readsPrec 0 j,
162 %*********************************************************
164 \subsection{Utility functions}
166 %*********************************************************
169 reads :: (Read a) => ReadS a
172 read :: (Read a) => String -> a
173 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
175 [] -> error "PreludeText.read: no parse"
176 _ -> error "PreludeText.read: ambiguous parse"
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,
185 {-# GENERATE_SPECS readList__ a #-}
186 readList__ :: ReadS a -> ReadS [a]
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,
193 readl2 s = [([],t) | ("]",t) <- lex s] ++
194 [(x:xs,v) | (",",t) <- lex s,
201 %*********************************************************
203 \subsection{Reading characters}
205 %*********************************************************
208 readLitChar :: ReadS Char
210 readLitChar ('\\':s) = readEsc s
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]]
235 readLitChar (c:s) = [(c,s)]
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)
244 %*********************************************************
246 \subsection{Reading numbers}
248 %*********************************************************
251 {-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
252 readDec :: (Integral a) => ReadS a
253 readDec = readInt 10 isDigit (\d -> ord d - ord_0)
255 {-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
256 readOct :: (Integral a) => ReadS a
257 readOct = readInt 8 isOctDigit (\d -> ord d - ord_0)
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)
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 ]
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,
277 read'' r = [(n,s) | (str,s) <- lex r,
278 (n,"") <- readPos str]
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.
287 {-# GENERATE_SPECS readFloat a{Double#,Double} #-}
288 readFloat :: (RealFloat a) => ReadS a
289 readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
291 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
294 = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
295 (k,t) <- readExp s] ++
296 [(0/0, t) | ("NaN", t) <- lex r] ++
297 [(1/0, t) | ("Infinity", t) <- lex r]
298 where readFix r = [(read (ds++ds'), length ds', t)
299 | (ds,s) <- lexDigits r,
300 (ds',t) <- lexDotDigits s ]
302 readExp (e:s) | e `elem` "eE" = readExp' s
305 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
306 readExp' ('+':s) = readDec s
307 readExp' s = readDec s
309 lexDotDigits ('.':s) = lex0Digits s
310 lexDotDigits s = [("",s)]
312 {- ToDo: remove completely
314 readRational__ :: String -> Rational -- we export this one (non-std)
315 -- NB: *does* handle a leading "-"
318 '-' : xs -> - (read_me xs)
322 = case [x | (x,t) <- readRational s, ("","") <- lex t] of
324 [] -> error ("readRational__: no parse:" ++ top_s)
325 _ -> error ("readRational__: ambiguous parse:" ++ top_s)
327 -- The number of decimal digits m below is chosen to guarantee
328 -- read (show x) == x. See
329 -- Matula, D. W. A formalization of floating-point numeric base
330 -- conversion. IEEE Transactions on Computers C-19, 8 (1970 August),
335 %*********************************************************
337 \subsection{Lexical analysis}
339 %*********************************************************
341 This lexer is not completely faithful to the Haskell lexical syntax.
343 Qualified names are not handled properly
344 A `--' does not terminate a symbol
345 Octal and hexidecimal numerics are not recognized as a single token
351 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
352 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
354 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
356 lexString ('"':s) = [("\"",s)]
357 lexString s = [(ch++str, u)
358 | (ch,t) <- lexStrItem s,
359 (str,u) <- lexString t ]
361 lexStrItem ('\\':'&':s) = [("\\&",s)]
362 lexStrItem ('\\':c:s) | isSpace c
363 = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
364 lexStrItem s = lexLitChar s
366 lex (c:s) | isSingle c = [([c],s)]
367 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
368 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
369 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
370 (fe,t) <- lexFracExp s ]
371 | otherwise = [] -- bad character
373 isSingle c = c `elem` ",;()[]{}_`"
374 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
375 isIdChar c = isAlphanum c || c `elem` "_'"
377 lexFracExp ('.':cs) = [('.':ds++e,u) | (ds,t) <- lex0Digits cs,
379 lexFracExp s = [("",s)]
381 lexExp (e:s) | e `elem` "eE"
382 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
383 (ds,u) <- lexDigits t] ++
384 [(e:ds,t) | (ds,t) <- lexDigits s]
387 lexDigits :: ReadS String
388 lexDigits = nonnull isDigit
391 lex0Digits :: ReadS String
392 lex0Digits s = [span isDigit s]
394 nonnull :: (Char -> Bool) -> ReadS String
395 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
397 lexLitChar :: ReadS String
398 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
400 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
401 lexEsc s@(d:_) | isDigit d = lexDigits s
403 lexLitChar (c:s) = [([c],s)]