-% ------------------------------------------------------------------------------
-% $Id: Read.lhs,v 1.3 2001/12/21 15:07:25 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 Data.Maybe
-import Data.Either
-import {-# SOURCE #-} GHC.Err ( error )
-import GHC.Enum ( Enum(..), maxBound )
+#ifndef __HADDOCK__
+import {-# SOURCE #-} GHC.Unicode ( isDigit )
+#endif
import GHC.Num
import GHC.Real
-import GHC.Float
-import GHC.List
-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
+ 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
- read_s str = do
- (x,str1) <- reads str
- ("","") <- lex str1
- return x
+ 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)
-
-readList__ :: ReadS a -> ReadS [a]
+%*********************************************************
+%* *
+\subsection{Simple instances of Read}
+%* *
+%*********************************************************
-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)
+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 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) }))
-
-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
+
+instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
+ readPrec = wrap_tup read_tup4
+ 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)
+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}
-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.
-
\begin{code}
-{-# SPECIALISE readFloat ::
- ReadS Double,
- ReadS Float #-}
-readFloat :: (RealFloat a) => ReadS a
-readFloat r =
- (do
- (x,t) <- readRational r
- return (fromRational x,t) ) ++
- (do
- ("NaN",t) <- lex r
- return (0/0,t) ) ++
- (do
- ("Infinity",t) <- lex r
- return (1/0,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)
- 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}
+
projects / ghc-base.git / blobdiff