-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
+------------------------------------------------------------------------
+-- 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' is equivalent to
+--
+-- > instance (Read a) => Read (Tree a) where
+-- >
+-- > readsPrec d 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
+-- >
+-- > ++ readParen (d > app_prec)
+-- > (\r -> [(Leaf m,t) |
+-- > ("Leaf",s) <- lex r,
+-- > (m,t) <- readsPrec (app_prec+1) s]) r
+-- >
+-- > where up_prec = 5
+-- > app_prec = 10
+--
+-- Note that right-associativity of @:^:@ is unused.
+
+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).
+ 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]
+-- ^ Use this to define the 'readList' method, if you don't want a special
+-- case (GHC only; for other systems the default suffices).
+readListDefault = readPrec_to_S readListPrec 0
+
+readListPrecDefault :: Read a => ReadPrec [a]
+-- ^ Use this to define the 'readListPrec' method, if you
+-- don't want a special case (GHC only).
+readListPrecDefault = list readPrec
+
+------------------------------------------------------------------------
+-- utility functions
+
+-- | equivalent to 'readsPrec' with a precedence of 0.
+reads :: Read a => ReadS a
+reads = readsPrec minPrec
+
+readp :: Read a => ReadP a
+readp = readPrec_to_P readPrec minPrec
+
+readEither :: Read a => String -> Either String a
+readEither s =
+ case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
+ [x] -> Right x
+ [] -> Left "Prelude.read: no parse"
+ _ -> Left "Prelude.read: ambiguous parse"
+ where
+ read' =
+ do x <- readPrec
+ lift P.skipSpaces
+ return x
+
+-- | The 'read' function reads input from a string, which must be
+-- completely consumed by the input process.
+read :: Read a => String -> a
+read s = either error id (readEither s)
+
+------------------------------------------------------------------------
+-- 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
+-- 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
+ 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)]@
+choose sps = foldr ((+++) . try_one) pfail sps
+ where
+ try_one (s,p) = do { L.Ident s' <- lexP ;
+ if s == s' then p else pfail }