X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FRead.lhs;h=77daececb7306dfda10659d977d823f7114a3d82;hb=be2750a0a11b919fb03cc070074e430f88bdfa90;hp=1e66f85a96a3f2edddb2e5375af9e4b8f3cd4fa0;hpb=7f1f4e7a695c402ddd3a1dc2cc7114e649a78ebc;p=ghc-base.git diff --git a/GHC/Read.lhs b/GHC/Read.lhs index 1e66f85..77daece 100644 --- a/GHC/Read.lhs +++ b/GHC/Read.lhs @@ -1,608 +1,682 @@ -% ------------------------------------------------------------------------------ -% $Id: Read.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% +\begin{code} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Read +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The 'Read' class and instances for basic data types. +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.Read + ( Read(..) -- class + + -- ReadS type + , ReadS -- :: *; = String -> [(a,String)] + + -- H98 compatibility + , lex -- :: ReadS String + , lexLitChar -- :: ReadS String + , readLitChar -- :: ReadS Char + , lexDigits -- :: ReadS String + + -- defining readers + , lexP -- :: ReadPrec Lexeme + , paren -- :: ReadPrec a -> ReadPrec a + , parens -- :: ReadPrec a -> ReadPrec a + , list -- :: ReadPrec a -> ReadPrec [a] + , choose -- :: [(String, ReadPrec a)] -> ReadPrec a + , readListDefault, readListPrecDefault + + -- Temporary + , readParen + + -- XXX Can this be removed? + , readp + ) + where -\section[GHC.Read]{Module @GHC.Read@} +import qualified Text.ParserCombinators.ReadP as P -Instances of the Read class. +import Text.ParserCombinators.ReadP + ( ReadP + , ReadS + , readP_to_S + ) -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} +import qualified Text.Read.Lex as L +-- Lex exports 'lex', which is also defined here, +-- hence the qualified import. +-- We can't import *anything* unqualified, because that +-- confuses Haddock. -module GHC.Read where +import Text.ParserCombinators.ReadPrec -import {-# SOURCE #-} GHC.Err ( error ) -import GHC.Enum ( Enum(..), maxBound ) +import Data.Maybe + +#ifndef __HADDOCK__ +import {-# SOURCE #-} GHC.Unicode ( isDigit ) +#endif import GHC.Num import GHC.Real -import GHC.Float -import GHC.List -import GHC.Maybe -import GHC.Show -- isAlpha etc +import GHC.Float () +import GHC.Show import GHC.Base +import GHC.Arr \end{code} -%********************************************************* -%* * -\subsection{The @Read@ class} -%* * -%********************************************************* - -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 - - readList :: ReadS [a] - readList = readList__ reads +-- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with +-- parentheses. +-- +-- @'readParen' 'False' p@ parses what @p@ parses, but optionally +-- surrounded with parentheses. +readParen :: Bool -> ReadS a -> ReadS a +-- A Haskell 98 function +readParen b g = if b then mandatory else optional + where optional r = g r ++ mandatory r + mandatory r = do + ("(",s) <- lex r + (x,t) <- optional s + (")",u) <- lex t + return (x,u) \end{code} -In this module we treat [(a,String)] as a monad in Control.MonadPlus -But Control.MonadPlus isn't defined yet, so we simply give local -declarations for mzero and guard suitable for this particular -type. It would also be reasonably to move Control.MonadPlus to GHC.Base -along with Control.Monad and Functor, but that seems overkill for one -example - -\begin{code} -mzero :: [a] -mzero = [] - -guard :: Bool -> [()] -guard True = [()] -guard False = [] -\end{code} %********************************************************* -%* * -\subsection{Utility functions} -%* * +%* * +\subsection{The @Read@ class} +%* * %********************************************************* \begin{code} -reads :: (Read a) => ReadS a -reads = readsPrec 0 - -read :: (Read a) => String -> a -read s = - case read_s s of -#ifndef NEW_READS_REP - [x] -> x - [] -> error "Prelude.read: no parse" - _ -> error "Prelude.read: ambiguous parse" -#else - Just x -> x - Nothing -> error "Prelude.read: no parse" -#endif +------------------------------------------------------------------------ +-- class Read + +-- | Parsing of 'String's, producing values. +-- +-- Minimal complete definition: 'readsPrec' (or, for GHC only, 'readPrec') +-- +-- Derived instances of 'Read' make the following assumptions, which +-- derived instances of 'Text.Show.Show' obey: +-- +-- * If the constructor is defined to be an infix operator, then the +-- derived 'Read' instance will parse only infix applications of +-- the constructor (not the prefix form). +-- +-- * Associativity is not used to reduce the occurrence of parentheses, +-- although precedence may be. +-- +-- * If the constructor is defined using record syntax, the derived 'Read' +-- will parse only the record-syntax form, and furthermore, the fields +-- must be given in the same order as the original declaration. +-- +-- * The derived 'Read' instance allows arbitrary Haskell whitespace +-- between tokens of the input string. Extra parentheses are also +-- allowed. +-- +-- For example, given the declarations +-- +-- > infixr 5 :^: +-- > data Tree a = Leaf a | Tree a :^: Tree a +-- +-- the derived instance of 'Read' in Haskell 98 is equivalent to +-- +-- > instance (Read a) => Read (Tree a) where +-- > +-- > readsPrec d r = readParen (d > app_prec) +-- > (\r -> [(Leaf m,t) | +-- > ("Leaf",s) <- lex r, +-- > (m,t) <- readsPrec (app_prec+1) s]) r +-- > +-- > ++ readParen (d > up_prec) +-- > (\r -> [(u:^:v,w) | +-- > (u,s) <- readsPrec (up_prec+1) r, +-- > (":^:",t) <- lex s, +-- > (v,w) <- readsPrec (up_prec+1) t]) r +-- > +-- > where app_prec = 10 +-- > up_prec = 5 +-- +-- Note that right-associativity of @:^:@ is unused. +-- +-- The derived instance in GHC is equivalent to +-- +-- > instance (Read a) => Read (Tree a) where +-- > +-- > readPrec = parens $ (prec app_prec $ do +-- > Ident "Leaf" <- lexP +-- > m <- step readPrec +-- > return (Leaf m)) +-- > +-- > +++ (prec up_prec $ do +-- > u <- step readPrec +-- > Symbol ":^:" <- lexP +-- > v <- step readPrec +-- > return (u :^: v)) +-- > +-- > where app_prec = 10 +-- > up_prec = 5 +-- > +-- > readListPrec = readListPrecDefault + +class Read a where + -- | attempts to parse a value from the front of the string, returning + -- a list of (parsed value, remaining string) pairs. If there is no + -- successful parse, the returned list is empty. + -- + -- Derived instances of 'Read' and 'Text.Show.Show' satisfy the following: + -- + -- * @(x,\"\")@ is an element of + -- @('readsPrec' d ('Text.Show.showsPrec' d x \"\"))@. + -- + -- That is, 'readsPrec' parses the string produced by + -- 'Text.Show.showsPrec', and delivers the value that + -- 'Text.Show.showsPrec' started with. + + readsPrec :: Int -- ^ the operator precedence of the enclosing + -- context (a number from @0@ to @11@). + -- Function application has precedence @10@. + -> ReadS a + + -- | The method 'readList' is provided to allow the programmer to + -- give a specialised way of parsing lists of values. + -- For example, this is used by the predefined 'Read' instance of + -- the 'Char' type, where values of type 'String' should be are + -- expected to use double quotes, rather than square brackets. + readList :: ReadS [a] + + -- | Proposed replacement for 'readsPrec' using new-style parsers (GHC only). + readPrec :: ReadPrec a + + -- | Proposed replacement for 'readList' using new-style parsers (GHC only). + -- The default definition uses 'readList'. Instances that define 'readPrec' + -- should also define 'readListPrec' as 'readListPrecDefault'. + readListPrec :: ReadPrec [a] + + -- default definitions + readsPrec = readPrec_to_S readPrec + readList = readPrec_to_S (list readPrec) 0 + readPrec = readS_to_Prec readsPrec + readListPrec = readS_to_Prec (\_ -> readList) + +readListDefault :: Read a => ReadS [a] +-- ^ A possible replacement definition for the 'readList' method (GHC only). +-- This is only needed for GHC, and even then only for 'Read' instances +-- where 'readListPrec' isn't defined as 'readListPrecDefault'. +readListDefault = readPrec_to_S readListPrec 0 + +readListPrecDefault :: Read a => ReadPrec [a] +-- ^ A possible replacement definition for the 'readListPrec' method, +-- defined using 'readPrec' (GHC only). +readListPrecDefault = list readPrec + +------------------------------------------------------------------------ +-- H98 compatibility + +-- | The 'lex' function reads a single lexeme from the input, discarding +-- initial white space, and returning the characters that constitute the +-- lexeme. If the input string contains only white space, 'lex' returns a +-- single successful \`lexeme\' consisting of the empty string. (Thus +-- @'lex' \"\" = [(\"\",\"\")]@.) If there is no legal lexeme at the +-- beginning of the input string, 'lex' fails (i.e. returns @[]@). +-- +-- This lexer is not completely faithful to the Haskell lexical syntax +-- in the following respects: +-- +-- * Qualified names are not handled properly +-- +-- * Octal and hexadecimal numerics are not recognized as a single token +-- +-- * Comments are not treated properly +lex :: ReadS String -- As defined by H98 +lex s = readP_to_S L.hsLex s + +-- | Read a string representation of a character, using Haskell +-- source-language escape conventions. For example: +-- +-- > lexLitChar "\\nHello" = [("\\n", "Hello")] +-- +lexLitChar :: ReadS String -- As defined by H98 +lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ; + return s }) + -- There was a skipSpaces before the P.gather L.lexChar, + -- but that seems inconsistent with readLitChar + +-- | Read a string representation of a character, using Haskell +-- source-language escape conventions, and convert it to the character +-- that it encodes. For example: +-- +-- > readLitChar "\\nHello" = [('\n', "Hello")] +-- +readLitChar :: ReadS Char -- As defined by H98 +readLitChar = readP_to_S L.lexChar + +-- | Reads a non-empty string of decimal digits. +lexDigits :: ReadS String +lexDigits = readP_to_S (P.munch1 isDigit) + +------------------------------------------------------------------------ +-- utility parsers + +lexP :: ReadPrec L.Lexeme +-- ^ Parse a single lexeme +lexP = lift L.lex + +paren :: ReadPrec a -> ReadPrec a +-- ^ @(paren p)@ parses \"(P0)\" +-- where @p@ parses \"P0\" in precedence context zero +paren p = do L.Punc "(" <- lexP + x <- reset p + L.Punc ")" <- lexP + return x + +parens :: ReadPrec a -> ReadPrec a +-- ^ @(parens p)@ parses \"P\", \"(P0)\", \"((P0))\", etc, +-- where @p@ parses \"P\" in the current precedence context +-- and parses \"P0\" in precedence context zero +parens p = optional where - read_s str = do - (x,str1) <- reads str - ("","") <- lex str1 - return x + optional = p +++ mandatory + mandatory = paren optional + +list :: ReadPrec a -> ReadPrec [a] +-- ^ @(list p)@ parses a list of things parsed by @p@, +-- using the usual square-bracket syntax. +list readx = + parens + ( do L.Punc "[" <- lexP + (listRest False +++ listNext) + ) + where + listRest started = + do L.Punc c <- lexP + case c of + "]" -> return [] + "," | started -> listNext + _ -> pfail + + listNext = + do x <- reset readx + xs <- listRest True + return (x:xs) + +choose :: [(String, ReadPrec a)] -> ReadPrec a +-- ^ Parse the specified lexeme and continue as specified. +-- Esp useful for nullary constructors; e.g. +-- @choose [(\"A\", return A), (\"B\", return B)]@ +-- We match both Ident and Symbol because the constructor +-- might be an operator eg (:=:) +choose sps = foldr ((+++) . try_one) pfail sps + where + try_one (s,p) = do { token <- lexP ; + case token of + L.Ident s' | s==s' -> p + L.Symbol s' | s==s' -> p + _other -> pfail } \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 = do - ("(",s) <- lex r - (x,t) <- optional s - (")",u) <- lex t - return (x,u) +%********************************************************* +%* * +\subsection{Simple instances of Read} +%* * +%********************************************************* -readList__ :: ReadS a -> ReadS [a] - -readList__ readx - = 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) }) +\begin{code} +instance Read Char where + readPrec = + parens + ( do L.Char c <- lexP + return c + ) + + readListPrec = + parens + ( do L.String s <- lexP -- Looks for "foo" + return s + +++ + readListPrecDefault -- Looks for ['f','o','o'] + ) -- (more generous than H98 spec) + + readList = readListDefault - readl2 s = - (do { ("]",t) <- lex s ; return ([],t) }) ++ - (do { (",",t) <- lex s ; (x,u) <- readx t ; (xs,v) <- readl2 u ; return (x:xs,v) }) +instance Read Bool where + readPrec = + parens + ( do L.Ident s <- lexP + case s of + "True" -> return True + "False" -> return False + _ -> pfail + ) + + readListPrec = readListPrecDefault + readList = readListDefault +instance Read Ordering where + readPrec = + parens + ( do L.Ident s <- lexP + case s of + "LT" -> return LT + "EQ" -> return EQ + "GT" -> return GT + _ -> pfail + ) + + readListPrec = readListPrecDefault + readList = readListDefault \end{code} %********************************************************* -%* * -\subsection{Lexical analysis} -%* * +%* * +\subsection{Structure instances of Read: Maybe, List etc} +%* * %********************************************************* -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 +For structured instances of Read we start using the precedences. The +idea is then that 'parens (prec k p)' will fail immediately when trying +to parse it in a context with a higher precedence level than k. But if +there is one parenthesis parsed, then the required precedence level +drops to 0 again, and parsing inside p may succeed. + +'appPrec' is just the precedence level of function application. So, +if we are parsing function application, we'd better require the +precedence level to be at least 'appPrec'. Otherwise, we have to put +parentheses around it. + +'step' is used to increase the precedence levels inside a +parser, and can be used to express left- or right- associativity. For +example, % is defined to be left associative, so we only increase +precedence on the right hand side. + +Note how step is used in for example the Maybe parser to increase the +precedence beyond appPrec, so that basically only literals and +parenthesis-like objects such as (...) and [...] can be an argument to +'Just'. \begin{code} -lex :: ReadS String - -lex "" = return ("","") -lex (c:s) | isSpace c = lex (dropWhile isSpace s) -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 -{- Removed, 13/03/2000 by SDM. - Doesn't work, and not required by Haskell report. - let - (pred, s', isDec) = - case s of - ('o':rs) -> (isOctDigit, rs, False) - ('O':rs) -> (isOctDigit, rs, False) - ('x':rs) -> (isHexDigit, rs, False) - ('X':rs) -> (isHexDigit, rs, False) - _ -> (isDigit, s, True) --} - (ds,s) <- return (span isDigit s) - (fe,t) <- lexFracExp s - return (c:ds++fe,t) - | otherwise = mzero -- bad character - where - isSingle c = c `elem` ",;()[]{}_`" - isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" - isIdChar c = isAlphaNum c || c `elem` "_'" - - lexFracExp ('.':c:cs) | isDigit c = do - (ds,t) <- lex0Digits cs - (e,u) <- lexExp t - return ('.':c:ds++e,u) - lexFracExp s = return ("",s) - - lexExp (e:s) | e `elem` "eE" = - (do - (c:t) <- return s - guard (c `elem` "+-") - (ds,u) <- lexDecDigits t - return (e:c:ds,u)) ++ - (do - (ds,t) <- lexDecDigits s - return (e:ds,t)) - - lexExp s = return ("",s) - -lexDigits :: ReadS String -lexDigits = lexDecDigits - -lexDecDigits :: ReadS String -lexDecDigits = nonnull isDigit - -lexOctDigits :: ReadS String -lexOctDigits = nonnull isOctDigit - -lexHexDigits :: ReadS String -lexHexDigits = nonnull isHexDigit - --- 0 or more digits -lex0Digits :: ReadS String -lex0Digits s = return (span isDigit s) - -nonnull :: (Char -> Bool) -> ReadS String -nonnull p s = do - (cs@(_:_),t) <- return (span p s) - return (cs,t) - -lexLitChar :: ReadS String -lexLitChar ('\\':s) = do - (esc,t) <- lexEsc s - return ('\\':esc, t) - where - lexEsc (c:s) | c `elem` escChars = return ([c],s) - lexEsc s@(d:_) | isDigit d = checkSize 10 lexDecDigits s - lexEsc ('o':d:s) | isOctDigit d = checkSize 8 lexOctDigits (d:s) - lexEsc ('O':d:s) | isOctDigit d = checkSize 8 lexOctDigits (d:s) - lexEsc ('x':d:s) | isHexDigit d = checkSize 16 lexHexDigits (d:s) - lexEsc ('X':d:s) | isHexDigit d = checkSize 16 lexHexDigits (d:s) - lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] -- cf. cntrl in 2.6 of H. report. - lexEsc s@(c:_) | isUpper c = fromAsciiLab s - lexEsc _ = mzero - - escChars = "abfnrtv\\\"'" - - fromAsciiLab (x:y:z:ls) | isUpper y && (isUpper z || isDigit z) && - [x,y,z] `elem` asciiEscTab = return ([x,y,z], ls) - fromAsciiLab (x:y:ls) | isUpper y && - [x,y] `elem` asciiEscTab = return ([x,y], ls) - fromAsciiLab _ = mzero - - asciiEscTab = "DEL" : asciiTab - - {- - Check that the numerically escaped char literals are - within accepted boundaries. - - Note: this allows char lits with leading zeros, i.e., - \0000000000000000000000000000001. - -} - checkSize base f str = do - (num, res) <- f str - if toAnInteger base num > toInteger (ord maxBound) then - mzero - else - case base of - 8 -> return ('o':num, res) - 16 -> return ('x':num, res) - _ -> return (num, res) - - toAnInteger base = foldl (\ acc n -> acc*base + toInteger (digitToInt n)) 0 - - -lexLitChar (c:s) = return ([c],s) -lexLitChar "" = mzero - -digitToInt :: Char -> Int -digitToInt c - | isDigit c = fromEnum c - fromEnum '0' - | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10 - | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10 - | otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh +instance Read a => Read (Maybe a) where + readPrec = + parens + (do L.Ident "Nothing" <- lexP + return Nothing + +++ + prec appPrec ( + do L.Ident "Just" <- lexP + x <- step readPrec + return (Just x)) + ) + + readListPrec = readListPrecDefault + readList = readListDefault + +instance Read a => Read [a] where + readPrec = readListPrec + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Ix a, Read a, Read b) => Read (Array a b) where + readPrec = parens $ prec appPrec $ + do L.Ident "array" <- lexP + theBounds <- step readPrec + vals <- step readPrec + return (array theBounds vals) + + readListPrec = readListPrecDefault + readList = readListDefault + +instance Read L.Lexeme where + readPrec = lexP + readListPrec = readListPrecDefault + readList = readListDefault \end{code} + %********************************************************* -%* * -\subsection{Instances of @Read@} -%* * +%* * +\subsection{Numeric instances of Read} +%* * %********************************************************* \begin{code} -instance Read Char where - readsPrec _ = readParen False - (\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 = do - (c,t) <- readLitChar s - (cs,u) <- readl t - return (c:cs,u) - -instance Read Bool where - readsPrec _ = readParen False - (\r -> - lex r >>= \ lr -> - (do { ("True", rest) <- return lr ; return (True, rest) }) ++ - (do { ("False", rest) <- return lr ; return (False, rest) })) - +readNumber :: Num a => (L.Lexeme -> ReadPrec a) -> ReadPrec a +-- Read a signed number +readNumber convert = + parens + ( do x <- lexP + case x of + L.Symbol "-" -> do y <- lexP + n <- convert y + return (negate n) + + _ -> convert x + ) + + +convertInt :: Num a => L.Lexeme -> ReadPrec a +convertInt (L.Int i) = return (fromInteger i) +convertInt _ = pfail + +convertFrac :: Fractional a => L.Lexeme -> ReadPrec a +convertFrac (L.Int i) = return (fromInteger i) +convertFrac (L.Rat r) = return (fromRational r) +convertFrac _ = pfail + +instance Read Int where + readPrec = readNumber convertInt + readListPrec = readListPrecDefault + readList = readListDefault + +instance Read Integer where + readPrec = readNumber convertInt + readListPrec = readListPrecDefault + readList = readListDefault + +instance Read Float where + readPrec = readNumber convertFrac + readListPrec = readListPrecDefault + readList = readListDefault + +instance Read Double where + readPrec = readNumber convertFrac + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Integral a, Read a) => Read (Ratio a) where + readPrec = + parens + ( prec ratioPrec + ( do x <- step readPrec + L.Symbol "%" <- lexP + y <- step readPrec + return (x % y) + ) + ) + + readListPrec = readListPrecDefault + readList = readListDefault +\end{code} -instance Read Ordering where - readsPrec _ = readParen False - (\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 _ = readParen False - (\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 _ = readParen False - (\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 _ x = readSigned readDec x - -instance Read Integer where - readsPrec _ x = readSigned readDec x - -instance Read Float where - readsPrec _ x = readSigned readFloat x - -instance Read Double where - readsPrec _ x = readSigned readFloat x - -instance (Integral a, Read a) => Read (Ratio a) where - readsPrec p = readParen (p > ratio_prec) - (\r -> do - (x,s) <- reads r - ("%",t) <- lex s - (y,u) <- reads t - return (x%y,u)) - -instance (Read a) => Read [a] where - readsPrec _ = readList +%********************************************************* +%* * + Tuple instances of Read, up to size 15 +%* * +%********************************************************* +\begin{code} instance Read () where - readsPrec _ = readParen False - (\r -> do - ("(",s) <- lex r - (")",t) <- lex s - return ((),t)) - -instance (Read a, Read b) => Read (a,b) where - readsPrec _ = readParen False - (\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)) + readPrec = + parens + ( paren + ( return () + ) + ) -instance (Read a, Read b, Read c) => Read (a, b, c) where - readsPrec _ = readParen False - (\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)) + readListPrec = readListPrecDefault + readList = readListDefault -instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where - readsPrec _ = readParen False - (\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 (a,b) where + readPrec = wrap_tup read_tup2 + readListPrec = readListPrecDefault + readList = readListDefault -instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where - readsPrec _ = readParen False - (\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} +wrap_tup :: ReadPrec a -> ReadPrec a +wrap_tup p = parens (paren p) +read_comma :: ReadPrec () +read_comma = do { L.Punc "," <- lexP; return () } -%********************************************************* -%* * -\subsection{Reading characters} -%* * -%********************************************************* +read_tup2 :: (Read a, Read b) => ReadPrec (a,b) +-- Reads "a , b" no parens! +read_tup2 = do x <- readPrec + read_comma + y <- readPrec + return (x,y) -\begin{code} -readLitChar :: ReadS Char - -readLitChar [] = mzero -readLitChar ('\\':s) = readEsc s - where - 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 <= '_' - = return (chr (ord c - ord '@'), s) - readEsc s@(d:_) | isDigit d - = 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:_) -> return pr - [] -> mzero - readEsc _ = mzero - -readLitChar (c:s) = return (c,s) - -match :: (Eq a) => [a] -> [a] -> ([a],[a]) -match (x:xs) (y:ys) | x == y = match xs ys -match xs ys = (xs,ys) +read_tup4 :: (Read a, Read b, Read c, Read d) => ReadPrec (a,b,c,d) +read_tup4 = do (a,b) <- read_tup2 + read_comma + (c,d) <- read_tup2 + return (a,b,c,d) -\end{code} +read_tup8 :: (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h) + => ReadPrec (a,b,c,d,e,f,g,h) +read_tup8 = do (a,b,c,d) <- read_tup4 + read_comma + (e,f,g,h) <- read_tup4 + return (a,b,c,d,e,f,g,h) -%********************************************************* -%* * -\subsection{Reading numbers} -%* * -%********************************************************* -Note: reading numbers at bases different than 10, does not -include lexing common prefixes such as '0x' or '0o' etc. +instance (Read a, Read b, Read c) => Read (a, b, c) where + readPrec = wrap_tup (do { (a,b) <- read_tup2; read_comma + ; c <- readPrec + ; return (a,b,c) }) + readListPrec = readListPrecDefault + readList = readListDefault -\begin{code} -{-# SPECIALISE readDec :: - ReadS Int, - ReadS Integer #-} -readDec :: (Integral a) => ReadS a -readDec = readInt 10 isDigit (\d -> ord d - ord '0') - -{-# SPECIALISE readOct :: - ReadS Int, - ReadS Integer #-} -readOct :: (Integral a) => ReadS a -readOct = readInt 8 isOctDigit (\d -> ord d - ord '0') - -{-# 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) - -readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a -readInt radix isDig digToInt s = do - (ds,r) <- nonnull isDig s - return (foldl1 (\n d -> n * radix + d) - (map (fromInteger . toInteger . 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 ++ - (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} +instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where + readPrec = wrap_tup read_tup4 + readListPrec = readListPrecDefault + readList = readListDefault -The functions readFloat below uses rational arithmetic -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. +instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where + readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma + ; e <- readPrec + ; return (a,b,c,d,e) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f) + => Read (a, b, c, d, e, f) where + readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma + ; (e,f) <- read_tup2 + ; return (a,b,c,d,e,f) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g) + => Read (a, b, c, d, e, f, g) where + readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma + ; (e,f) <- read_tup2; read_comma + ; g <- readPrec + ; return (a,b,c,d,e,f,g) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h) + => Read (a, b, c, d, e, f, g, h) where + readPrec = wrap_tup read_tup8 + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, + Read i) + => Read (a, b, c, d, e, f, g, h, i) where + readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma + ; i <- readPrec + ; return (a,b,c,d,e,f,g,h,i) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, + Read i, Read j) + => Read (a, b, c, d, e, f, g, h, i, j) where + readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma + ; (i,j) <- read_tup2 + ; return (a,b,c,d,e,f,g,h,i,j) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, + Read i, Read j, Read k) + => Read (a, b, c, d, e, f, g, h, i, j, k) where + readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma + ; (i,j) <- read_tup2; read_comma + ; k <- readPrec + ; return (a,b,c,d,e,f,g,h,i,j,k) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, + Read i, Read j, Read k, Read l) + => Read (a, b, c, d, e, f, g, h, i, j, k, l) where + readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma + ; (i,j,k,l) <- read_tup4 + ; return (a,b,c,d,e,f,g,h,i,j,k,l) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, + Read i, Read j, Read k, Read l, Read m) + => Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where + readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma + ; (i,j,k,l) <- read_tup4; read_comma + ; m <- readPrec + ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, + Read i, Read j, Read k, Read l, Read m, Read n) + => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where + readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma + ; (i,j,k,l) <- read_tup4; read_comma + ; (m,n) <- read_tup2 + ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) }) + readListPrec = readListPrecDefault + readList = readListDefault + +instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, + Read i, Read j, Read k, Read l, Read m, Read n, Read o) + => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where + readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma + ; (i,j,k,l) <- read_tup4; read_comma + ; (m,n) <- read_tup2; read_comma + ; o <- readPrec + ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) }) + readListPrec = readListPrecDefault + readList = readListDefault +\end{code} \begin{code} -{-# SPECIALISE readFloat :: - ReadS Double, - ReadS Float #-} -readFloat :: (RealFloat a) => ReadS a -readFloat r = do - (x,t) <- readRational r - return (fromRational x,t) - -readRational :: ReadS Rational -- NB: doesn't handle leading "-" - -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) <- lexDecDigits 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 "-" -readRational__ top_s - = case top_s of - '-' : xs -> - (read_me xs) - xs -> read_me xs - where - read_me s - = 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 +-- XXX Can this be removed? +readp :: Read a => ReadP a +readp = readPrec_to_P readPrec minPrec \end{code} +