From 3da2ca70fcd6c1123a906c879d9343b77b0d3e27 Mon Sep 17 00:00:00 2001 From: sof Date: Thu, 27 Aug 1998 13:04:25 +0000 Subject: [PATCH] [project @ 1998-08-27 13:04:25 by sof] * Added (compile-time conditional) experimental change of making ReadS return a Maybe value instead of a list of possible parses. * Reworked to use do notation instead of list/monad comprehension syntax. (this makes switching between different ReadS representation a great deal easier.) This change relies on Haskell-1.4's failure-free patterns to work. --- ghc/lib/std/PrelRead.lhs | 492 +++++++++++++++++++++++++++++----------------- 1 file changed, 314 insertions(+), 178 deletions(-) diff --git a/ghc/lib/std/PrelRead.lhs b/ghc/lib/std/PrelRead.lhs index fd5ffaf..600bde0 100644 --- a/ghc/lib/std/PrelRead.lhs +++ b/ghc/lib/std/PrelRead.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1998 % \section[PrelRead]{Module @PrelRead@} @@ -18,6 +18,11 @@ import PrelTup import PrelMaybe import PrelEither import PrelBase +import Monad + +-- needed for readIO. +import PrelIOBase ( IO, fail, userError ) + \end{code} %********************************************************* @@ -26,8 +31,23 @@ import PrelBase %* * %********************************************************* +Note: if you compile this with -DNEW_READS_REP, you'll get +a (simpler) ReadS representation that only allow one valid +parse of a string of characters, instead of a list of +possible ones. + +[changing the ReadS rep has implications for the deriving +machinery for Read, a change that hasn't been made, so you +probably won't want to compile in this new rep. except +when in an experimental mood.] + \begin{code} + +#ifndef NEW_READS_REP type ReadS a = String -> [(a,String)] +#else +type ReadS a = String -> Maybe (a,String) +#endif class Read a where readsPrec :: Int -> ReadS a @@ -47,31 +67,61 @@ reads :: (Read a) => ReadS a reads = readsPrec 0 read :: (Read a) => String -> a -read s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> x - [] -> error "PreludeText.read: no parse" - _ -> error "PreludeText.read: ambiguous parse" +read s = + case read_s s of +#ifndef NEW_READS_REP + [x] -> x + [] -> error "PreludeText.read: no parse" + _ -> error "PreludeText.read: ambiguous parse" +#else + Just x -> x + Nothing -> error "PreludeText.read: no parse" +#endif + where + read_s s = do + (x,t) <- reads s + ("","") <- lex t + return x + + -- raises an exception instead of an error +readIO :: Read a => String -> IO a +readIO s = case (do { (x,t) <- reads s ; ("","") <- lex t ; return x }) of +#ifndef NEW_READS_REP + [x] -> return x + [] -> fail (userError "PreludeIO.readIO: no parse") + _ -> fail (userError "PreludeIO.readIO: ambiguous parse") +#else + Just x -> return x + Nothing -> fail (userError "PreludeIO.readIO: no parse") +#endif +\end{code} + +\begin{code} readParen :: Bool -> ReadS a -> ReadS a readParen b g = if b then mandatory else optional where optional r = g r ++ mandatory r - mandatory r = [(x,u) | ("(",s) <- lex r, - (x,t) <- optional s, - (")",u) <- lex t ] + mandatory r = do + ("(",s) <- lex r + (x,t) <- optional s + (")",u) <- lex t + return (x,u) -{-# GENERATE_SPECS readList__ a #-} readList__ :: ReadS a -> ReadS [a] readList__ readx - = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) - where readl s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,u) | (x,t) <- readx s, - (xs,u) <- readl2 t] - readl2 s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,v) | (",",t) <- lex s, - (x,u) <- readx t, - (xs,v) <- readl2 u] + = readParen False (\r -> do + ("[",s) <- lex r + readl s) + where readl s = + (do { ("]",t) <- lex s ; return ([],t) }) ++ + (do { (x,t) <- readx s ; (xs,u) <- readl2 t ; return (x:xs,u) }) + + readl2 s = + (do { ("]",t) <- lex s ; return ([],t) }) ++ + (do { (",",t) <- lex s ; (x,u) <- readx t ; (xs,v) <- readl2 u ; return (x:xs,v) }) + \end{code} @@ -90,61 +140,88 @@ Current limitations: \begin{code} lex :: ReadS String -lex "" = [("","")] +lex "" = return ("","") lex (c:s) | isSpace c = lex (dropWhile isSpace s) -lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, - ch /= "'" ] -lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] - where - lexString ('"':s) = [("\"",s)] - lexString s = [(ch++str, u) - | (ch,t) <- lexStrItem s, - (str,u) <- lexString t ] - - lexStrItem ('\\':'&':s) = [("\\&",s)] - lexStrItem ('\\':c:s) | isSpace c - = [("\\&",t) | '\\':t <- [dropWhile isSpace s]] - lexStrItem s = lexLitChar s - -lex (c:s) | isSingle c = [([c],s)] - | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]] - | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] - | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], - (fe,t) <- lexFracExp s ] - | otherwise = [] -- bad character +lex ('\'':s) = do + (ch, '\'':t) <- lexLitChar s + guard (ch /= "'") + return ('\'':ch++"'", t) +lex ('"':s) = do + (str,t) <- lexString s + return ('"':str, t) + + where + lexString ('"':s) = return ("\"",s) + lexString s = do + (ch,t) <- lexStrItem s + (str,u) <- lexString t + return (ch++str, u) + + + lexStrItem ('\\':'&':s) = return ("\\&",s) + lexStrItem ('\\':c:s) | isSpace c = do + ('\\':t) <- return (dropWhile isSpace s) + return ("\\&",t) + lexStrItem s = lexLitChar s + +lex (c:s) | isSingle c = return ([c],s) + | isSym c = do + (sym,t) <- return (span isSym s) + return (c:sym,t) + | isAlpha c = do + (nam,t) <- return (span isIdChar s) + return (c:nam, t) + | isDigit c = do + (ds,s) <- return (span isDigit s) + (fe,t) <- lexFracExp s + return (c:ds++fe,t) + | otherwise = zero -- bad character where isSingle c = c `elem` ",;()[]{}_`" isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" isIdChar c = isAlphanum c || c `elem` "_'" - lexFracExp ('.':cs) = [('.':ds++e,u) | (ds,t) <- lex0Digits cs, - (e,u) <- lexExp t] - lexFracExp s = [("",s)] + lexFracExp ('.':cs) = do + (ds,t) <- lex0Digits cs + (e,u) <- lexExp t + return ('.':ds++e,u) + lexFracExp s = return ("",s) + + lexExp (e:s) | e `elem` "eE" = + (do + (c:t) <- return s + guard (c `elem` "+-") + (ds,u) <- lexDigits t + return (e:c:ds,u)) ++ + (do + (ds,t) <- lexDigits s + return (e:ds,t)) - lexExp (e:s) | e `elem` "eE" - = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", - (ds,u) <- lexDigits t] ++ - [(e:ds,t) | (ds,t) <- lexDigits s] - lexExp s = [("",s)] + lexExp s = return ("",s) lexDigits :: ReadS String lexDigits = nonnull isDigit -- 0 or more digits lex0Digits :: ReadS String -lex0Digits s = [span isDigit s] +lex0Digits s = return (span isDigit s) nonnull :: (Char -> Bool) -> ReadS String -nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] +nonnull p s = do + (cs@(_:_),t) <- return (span p s) + return (cs,t) lexLitChar :: ReadS String -lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] +lexLitChar ('\\':s) = do + (esc,t) <- lexEsc s + return ('\\':esc, t) where - lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = return ([c],s) lexEsc s@(d:_) | isDigit d = lexDigits s - lexEsc _ = [] -lexLitChar (c:s) = [([c],s)] -lexLitChar "" = [] + lexEsc _ = zero + +lexLitChar (c:s) = return ([c],s) +lexLitChar "" = zero \end{code} %********************************************************* @@ -156,48 +233,60 @@ lexLitChar "" = [] \begin{code} instance Read Char where readsPrec p = readParen False - (\r -> [(c,t) | ('\'':s,t)<- lex r, - (c,_) <- readLitChar s]) - - readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, - (l,_) <- readl s ]) - where readl ('"':s) = [("",s)] + (\r -> do + ('\'':s,t) <- lex r + (c,_) <- readLitChar s + return (c,t)) + + readList = readParen False (\r -> do + ('"':s,t) <- lex r + (l,_) <- readl s + return (l,t)) + where readl ('"':s) = return ("",s) readl ('\\':'&':s) = readl s - readl s = [(c:cs,u) | (c ,t) <- readLitChar s, - (cs,u) <- readl t ] + readl s = do + (c,t) <- readLitChar s + (cs,u) <- readl t + return (c:cs,u) instance Read Bool where readsPrec p = readParen False - (\r -> let lr = lex r - in - [(True, rest) | ("True", rest) <- lr] ++ - [(False,rest) | ("False",rest) <- lr]) + (\r -> + lex r >>= \ lr -> + (do { ("True", rest) <- return lr ; return (True, rest) }) ++ + (do { ("False", rest) <- return lr ; return (False, rest) })) instance Read Ordering where readsPrec p = readParen False - (\r -> let lr = lex r - in - [(LT, rest) | ("LT", rest) <- lr] ++ - [(EQ, rest) | ("EQ", rest) <- lr] ++ - [(GT, rest) | ("GT", rest) <- lr]) + (\r -> + lex r >>= \ lr -> + (do { ("LT", rest) <- return lr ; return (LT, rest) }) ++ + (do { ("EQ", rest) <- return lr ; return (EQ, rest) }) ++ + (do { ("GT", rest) <- return lr ; return (GT, rest) })) instance Read a => Read (Maybe a) where readsPrec p = readParen False - (\r -> let lr = lex r - in - [(Nothing, rest) | ("Nothing", rest) <- lr] ++ - [(Just x, rest2) | ("Just", rest1) <- lr, - (x, rest2) <- reads rest1]) + (\r -> + lex r >>= \ lr -> + (do { ("Nothing", rest) <- return lr ; return (Nothing, rest)}) ++ + (do + ("Just", rest1) <- return lr + (x, rest2) <- reads rest1 + return (Just x, rest2))) instance (Read a, Read b) => Read (Either a b) where readsPrec p = readParen False - (\r -> let lr = lex r - in - [(Left x, rest2) | ("Left", rest1) <- lr, - (x, rest2) <- reads rest1] ++ - [(Right x, rest2) | ("Right", rest1) <- lr, - (x, rest2) <- reads rest1]) + (\r -> + lex r >>= \ lr -> + (do + ("Left", rest1) <- return lr + (x, rest2) <- reads rest1 + return (Left x, rest2)) ++ + (do + ("Right", rest1) <- return lr + (x, rest2) <- reads rest1 + return (Right x, rest2))) instance Read Int where readsPrec p x = readSigned readDec x @@ -213,61 +302,73 @@ instance Read Double where instance (Integral a, Read a) => Read (Ratio a) where readsPrec p = readParen (p > ratio_prec) - (\r -> [(x%y,u) | (x,s) <- reads r, - ("%",t) <- lex s, - (y,u) <- reads t ]) + (\r -> do + (x,s) <- reads r + ("%",t) <- lex s + (y,u) <- reads t + return (x%y,u)) instance (Read a) => Read [a] where readsPrec p = readList instance Read () where readsPrec p = readParen False - (\r -> [((),t) | ("(",s) <- lex r, - (")",t) <- lex s ] ) + (\r -> do + ("(",s) <- lex r + (")",t) <- lex s + return ((),t)) instance (Read a, Read b) => Read (a,b) where readsPrec p = readParen False - (\r -> [((x,y), w) | ("(",s) <- lex r, - (x,t) <- reads s, - (",",u) <- lex t, - (y,v) <- reads u, - (")",w) <- lex v ] ) + (\r -> do + ("(",s) <- lex r + (x,t) <- readsPrec 0 s + (",",u) <- lex t + (y,v) <- readsPrec 0 u + (")",w) <- lex v + return ((x,y), w)) instance (Read a, Read b, Read c) => Read (a, b, c) where readsPrec p = readParen False - (\a -> [((x,y,z), h) | ("(",b) <- lex a, - (x,c) <- readsPrec 0 b, - (",",d) <- lex c, - (y,e) <- readsPrec 0 d, - (",",f) <- lex e, - (z,g) <- readsPrec 0 f, - (")",h) <- lex g ] ) + (\a -> do + ("(",b) <- lex a + (x,c) <- readsPrec 0 b + (",",d) <- lex c + (y,e) <- readsPrec 0 d + (",",f) <- lex e + (z,g) <- readsPrec 0 f + (")",h) <- lex g + return ((x,y,z), h)) instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where readsPrec p = readParen False - (\a -> [((w,x,y,z), j) | ("(",b) <- lex a, - (w,c) <- readsPrec 0 b, - (",",d) <- lex c, - (x,e) <- readsPrec 0 d, - (",",f) <- lex e, - (y,g) <- readsPrec 0 f, - (",",h) <- lex g, - (z,i) <- readsPrec 0 h, - (")",j) <- lex i ] ) + (\a -> do + ("(",b) <- lex a + (w,c) <- readsPrec 0 b + (",",d) <- lex c + (x,e) <- readsPrec 0 d + (",",f) <- lex e + (y,g) <- readsPrec 0 f + (",",h) <- lex g + (z,h) <- readsPrec 0 h + (")",i) <- lex h + return ((w,x,y,z), i)) instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where readsPrec p = readParen False - (\a -> [((w,x,y,z,v), l) | ("(",b) <- lex a, - (w,c) <- readsPrec 0 b, - (",",d) <- lex c, - (x,e) <- readsPrec 0 d, - (",",f) <- lex e, - (y,g) <- readsPrec 0 f, - (",",h) <- lex g, - (z,i) <- readsPrec 0 h, - (",",j) <- lex i, - (v,k) <- readsPrec 0 j, - (")",l) <- lex k ] ) + (\a -> do + ("(",b) <- lex a + (v,c) <- readsPrec 0 b + (",",d) <- lex c + (w,e) <- readsPrec 0 d + (",",f) <- lex e + (x,g) <- readsPrec 0 f + (",",h) <- lex g + (y,i) <- readsPrec 0 h + (",",j) <- lex i + (z,k) <- readsPrec 0 j + (")",l) <- lex k + return ((v,w,x,y,z), l)) \end{code} @@ -282,30 +383,38 @@ readLitChar :: ReadS Char readLitChar ('\\':s) = readEsc s where - readEsc ('a':s) = [('\a',s)] - readEsc ('b':s) = [('\b',s)] - readEsc ('f':s) = [('\f',s)] - readEsc ('n':s) = [('\n',s)] - readEsc ('r':s) = [('\r',s)] - readEsc ('t':s) = [('\t',s)] - readEsc ('v':s) = [('\v',s)] - readEsc ('\\':s) = [('\\',s)] - readEsc ('"':s) = [('"',s)] - readEsc ('\'':s) = [('\'',s)] + readEsc ('a':s) = return ('\a',s) + readEsc ('b':s) = return ('\b',s) + readEsc ('f':s) = return ('\f',s) + readEsc ('n':s) = return ('\n',s) + readEsc ('r':s) = return ('\r',s) + readEsc ('t':s) = return ('\t',s) + readEsc ('v':s) = return ('\v',s) + readEsc ('\\':s) = return ('\\',s) + readEsc ('"':s) = return ('"',s) + readEsc ('\'':s) = return ('\'',s) readEsc ('^':c:s) | c >= '@' && c <= '_' - = [(chr (ord c - ord '@'), s)] + = return (chr (ord c - ord '@'), s) readEsc s@(d:_) | isDigit d - = [(chr n, t) | (n,t) <- readDec s] - readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s] - readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s] + = do + (n,t) <- readDec s + return (chr n,t) + readEsc ('o':s) = do + (n,t) <- readOct s + return (chr n,t) + readEsc ('x':s) = do + (n,t) <- readHex s + return (chr n,t) + readEsc s@(c:_) | isUpper c = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab in case [(c,s') | (c, mne) <- table, ([],s') <- [match mne s]] - of (pr:_) -> [pr] - [] -> [] - readEsc _ = [] -readLitChar (c:s) = [(c,s)] + of (pr:_) -> return pr + [] -> zero + readEsc _ = zero + +readLitChar (c:s) = return (c,s) match :: (Eq a) => [a] -> [a] -> ([a],[a]) match (x:xs) (y:ys) | x == y = match xs ys @@ -320,67 +429,96 @@ match xs ys = (xs,ys) %* * %********************************************************* +Note: reading numbers at bases different than 10, does not +include lexing common prefixes such as '0x' or '0o' etc. + \begin{code} -{-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-} +{-# SPECIALISE readDec :: + ReadS Int, + ReadS Integer #-} readDec :: (Integral a) => ReadS a readDec = readInt 10 isDigit (\d -> ord d - ord_0) -{-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-} +{-# SPECIALISE readOct :: + ReadS Int, + ReadS Integer #-} readOct :: (Integral a) => ReadS a readOct = readInt 8 isOctDigit (\d -> ord d - ord_0) -{-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-} +{-# SPECIALISE readHex :: + ReadS Int, + ReadS Integer #-} readHex :: (Integral a) => ReadS a readHex = readInt 16 isHexDigit hex where hex d = ord d - (if isDigit d then ord_0 else ord (if isUpper d then 'A' else 'a') - 10) -{-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-} readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a -readInt radix isDig digToInt s = - [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r) - | (ds,r) <- nonnull isDig s ] - -{-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-} +readInt radix isDig digToInt s = do + (ds,r) <- nonnull isDig s + return (foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r) + +{-# SPECIALISE readSigned :: + ReadS Int -> ReadS Int, + ReadS Integer -> ReadS Integer, + ReadS Double -> ReadS Double #-} readSigned :: (Real a) => ReadS a -> ReadS a readSigned readPos = readParen False read' where read' r = read'' r ++ - [(-x,t) | ("-",s) <- lex r, - (x,t) <- read'' s] - read'' r = [(n,s) | (str,s) <- lex r, - (n,"") <- readPos str] + (do + ("-",s) <- lex r + (x,t) <- read'' s + return (-x,t)) + read'' r = do + (str,s) <- lex r + (n,"") <- readPos str + return (n,s) \end{code} The functions readFloat below uses rational arithmetic -to insure correct conversion between the floating-point radix and +to ensure correct conversion between the floating-point radix and decimal. It is often possible to use a higher-precision floating- point type to obtain the same results. \begin{code} -{-# GENERATE_SPECS readFloat a{Double#,Double} #-} +{-# SPECIALISE readFloat :: + ReadS Double, + ReadS Float #-} readFloat :: (RealFloat a) => ReadS a -readFloat r = [(fromRational x, t) | (x, t) <- readRational r] +readFloat r = do + (x,t) <- readRational r + return (fromRational x,t) readRational :: ReadS Rational -- NB: doesn't handle leading "-" -readRational r - = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r, - (k,t) <- readExp s] ++ - [(0/0, t) | ("NaN", t) <- lex r] ++ - [(1/0, t) | ("Infinity", t) <- lex r] - where readFix r = [(read (ds++ds'), length ds', t) - | (ds,s) <- lexDigits r, - (ds',t) <- lexDotDigits s ] - - readExp (e:s) | e `elem` "eE" = readExp' s - readExp s = [(0,s)] - - readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] - readExp' ('+':s) = readDec s - readExp' s = readDec s - - lexDotDigits ('.':s) = lex0Digits s - lexDotDigits s = [("",s)] +readRational r = + (do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t )) ++ + (do + ("NaN",t) <- lex r + return (0/0,t) ) ++ + (do + ("Infinity",t) <- lex r + return (1/0,t) ) + where + readFix r = do + (ds,s) <- lexDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do + (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + lexDotDigits ('.':s) = lex0Digits s + lexDotDigits s = return ("",s) readRational__ :: String -> Rational -- we export this one (non-std) -- NB: *does* handle a leading "-" @@ -390,16 +528,14 @@ readRational__ top_s xs -> read_me xs where read_me s - = case [x | (x,t) <- readRational s, ("","") <- lex t] of + = case (do { (x,t) <- readRational s ; ("","") <- lex t ; return x }) of +#ifndef NEW_READS_REP [x] -> x [] -> error ("readRational__: no parse:" ++ top_s) _ -> error ("readRational__: ambiguous parse:" ++ top_s) +#else + Just x -> x + Nothing -> error ("readRational__: no parse:" ++ top_s) +#endif --- The number of decimal digits m below is chosen to guarantee --- read (show x) == x. See --- Matula, D. W. A formalization of floating-point numeric base --- conversion. IEEE Transactions on Computers C-19, 8 (1970 August), --- 681-692. \end{code} - - -- 1.7.10.4