X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fghc%2FPrelRead.lhs;fp=ghc%2Flib%2Fghc%2FPrelRead.lhs;h=0000000000000000000000000000000000000000;hb=28139aea50376444d56f43f0914291348a51a7e7;hp=3b3e4c8eaf3440c357e0db4e8b2acf73f38fa8dc;hpb=98a1ebecb6d22d793b1d9f8e1d24ecbb5a2d130f;p=ghc-hetmet.git diff --git a/ghc/lib/ghc/PrelRead.lhs b/ghc/lib/ghc/PrelRead.lhs deleted file mode 100644 index 3b3e4c8..0000000 --- a/ghc/lib/ghc/PrelRead.lhs +++ /dev/null @@ -1,405 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1996 -% - -\section[PrelRead]{Module @PrelRead@} - -Instances of the Read class. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelRead where - -import {-# SOURCE #-} GHCerr ( error ) -import PrelNum -import PrelList -import PrelTup -import PrelMaybe -import PrelEither -import PrelBase -\end{code} - -%********************************************************* -%* * -\subsection{The @Read@ class} -%* * -%********************************************************* - -\begin{code} -type ReadS a = String -> [(a,String)] - -class Read a where - readsPrec :: Int -> ReadS a - - readList :: ReadS [a] - readList = readList__ reads -\end{code} - -%********************************************************* -%* * -\subsection{Utility functions} -%* * -%********************************************************* - -\begin{code} -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" - -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 ] - - -{-# 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] -\end{code} - - -%********************************************************* -%* * -\subsection{Lexical analysis} -%* * -%********************************************************* - -This lexer is not completely faithful to the Haskell lexical syntax. -Current limitations: - Qualified names are not handled properly - A `--' does not terminate a symbol - Octal and hexidecimal numerics are not recognized as a single token - -\begin{code} -lex :: ReadS String - -lex "" = [("","")] -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 - 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)] - - 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)] - -lexDigits :: ReadS String -lexDigits = nonnull isDigit - --- 0 or more digits -lex0Digits :: ReadS String -lex0Digits s = [span isDigit s] - -nonnull :: (Char -> Bool) -> ReadS String -nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] - -lexLitChar :: ReadS String -lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] - where - lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] - lexEsc s@(d:_) | isDigit d = lexDigits s - lexEsc _ = [] -lexLitChar (c:s) = [([c],s)] -lexLitChar "" = [] -\end{code} - -%********************************************************* -%* * -\subsection{Instances of @Read@} -%* * -%********************************************************* - -\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)] - readl ('\\':'&':s) = readl s - readl s = [(c:cs,u) | (c ,t) <- readLitChar s, - (cs,u) <- readl t ] - -instance Read Bool where - readsPrec p = readParen False - (\r -> let lr = lex r - in - [(True, rest) | ("True", rest) <- lr] ++ - [(False,rest) | ("False",rest) <- lr]) - - -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]) - -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]) - -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]) - -instance Read Int where - readsPrec p x = readSigned readDec x - -instance Read Integer where - readsPrec p x = readSigned readDec x - -instance Read Float where - readsPrec p x = readSigned readFloat x - -instance Read Double where - readsPrec p x = readSigned readFloat x - -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 ]) - -instance (Read a) => Read [a] where - readsPrec p = readList - -instance Read () where - readsPrec p = readParen False - (\r -> [((),t) | ("(",s) <- lex r, - (")",t) <- lex s ] ) - -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 ] ) - -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 ] ) - -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 ] ) - -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 ] ) -\end{code} - - -%********************************************************* -%* * -\subsection{Reading characters} -%* * -%********************************************************* - -\begin{code} -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 ('^':c:s) | c >= '@' && c <= '_' - = [(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] - 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)] - -match :: (Eq a) => [a] -> [a] -> ([a],[a]) -match (x:xs) (y:ys) | x == y = match xs ys -match xs ys = (xs,ys) - -\end{code} - - -%********************************************************* -%* * -\subsection{Reading numbers} -%* * -%********************************************************* - -\begin{code} -{-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-} -readDec :: (Integral a) => ReadS a -readDec = readInt 10 isDigit (\d -> ord d - ord_0) - -{-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-} -readOct :: (Integral a) => ReadS a -readOct = readInt 8 isOctDigit (\d -> ord d - ord_0) - -{-# GENERATE_SPECS readHex a{Int#,Int,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} #-} -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] -\end{code} - -The functions readFloat below uses rational arithmetic -to insure 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} #-} -readFloat :: (RealFloat a) => ReadS a -readFloat r = [(fromRational x, t) | (x, t) <- readRational r] - -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__ :: String -> Rational -- we export this one (non-std) - -- NB: *does* handle a leading "-" -readRational__ top_s - = case top_s of - '-' : xs -> - (read_me xs) - xs -> read_me xs - where - read_me s - = case [x | (x,t) <- readRational s, ("","") <- lex t] of - [x] -> x - [] -> error ("readRational__: no parse:" ++ top_s) - _ -> error ("readRational__: ambiguous parse:" ++ top_s) - --- 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} - -