-- A simple attempt to provide the facilities of the Haskell Text -- class for reading values. If you really want to use this, I -- would suggest combining it with the Text class in a modified -- version of the prelude. -- -- Based, not surprisingly, on the definitions in the Haskell report -- version 1.2: type ReadS a = String -> [(a,String)] class Read a where readsPrec :: Int -> ReadS a readList :: ReadS [a] readList = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) where readl s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,u) | (x,t) <- reads s, (xs,u) <- readl' t] readl' s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- reads t, (xs,v) <- readl' u] instance Read () where readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r, (")",t) <- lex s ] ) 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 Int where readsPrec p = readSigned readDec instance (Read a) => Read [a] where readsPrec p = readList 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 ] ) 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 "read{PreludeRead}: no parse" _ -> error "read{PreludeRead}: 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 ] lex :: ReadS String lex "" = [("","")] lex (c:s) | isSpace c = lex (dropWhile isSpace s) lex ('-':'-':s) = case dropWhile (/= '\n') s of '\n':t -> lex t _ -> [] -- unterminated end-of-line -- comment lex ('{':'-':s) = lexNest lex s where lexNest f ('-':'}':s) = f s lexNest f ('{':'-':s) = lexNest (lexNest f) s lexNest f (c:s) = lexNest f s lexNest _ "" = [] -- unterminated -- nested comment lex ('<':'-':s) = [("<-",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)] | isSym1 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` ",;()[]{}_" isSym1 c = c `elem` "-~" || isSym c isSym c = c `elem` "!@#$%&*+./<=>?\\^|:" isIdChar c = isAlphanum c || c `elem` "_'" lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, (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 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 ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] lexEsc s@(d:_) | isDigit d = lexDigits s lexEsc ('o':s) = [('o':os, t) | (os,t) <- nonnull isOctDigit s] lexEsc ('x':s) = [('x':xs, t) | (xs,t) <- nonnull isHexDigit s] lexEsc s@(c:_) | isUpper c = case [(mne,s') | mne <- "DEL" : asciiTab, ([],s') <- [match mne s] ] of (pr:_) -> [pr] [] -> [] lexEsc _ = [] lexLitChar (c:s) = [([c],s)] lexLitChar "" = [] isOctDigit c = c >= '0' && c <= '7' isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' match :: (Eq a) => [a] -> [a] -> ([a],[a]) match (x:xs) (y:ys) | x == y = match xs ys match xs ys = (xs,ys) asciiTab = ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", "SP"] 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)] readDec, readOct, readHex :: ReadS Int readDec = readInt 10 isDigit (\d -> ord d - ord '0') readOct = readInt 8 isOctDigit (\d -> ord d - ord '0') 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) readInt :: Int -> (Char -> Bool) -> (Char -> Int) -> ReadS Int readInt radix isDig digToInt s = [(foldl1 (\n d -> n * radix + d) (map (fromInteger . digToInt) ds), r) | (ds,r) <- nonnull isDig s ] readSigned:: ReadS Int -> ReadS Int 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]