module Text.Parse
  ( -- * The Parse class is a replacement for the standard Read class.
    -- $parser
    TextParser  -- synonym for Parser Char, i.e. string input, no state
  , Parse(..)   -- instances: (), (a,b), (a,b,c), Maybe a, Either a, [a],
                --            Int, Integer, Float, Double, Char, Bool
  , parseByRead -- :: Read a => String -> TextParser a
  , readByParse -- :: TextParser a -> ReadS a
  , readsPrecByParsePrec -- :: (Int->TextParser a) -> Int -> ReadS a
    -- ** Combinators specific to string input, lexed haskell-style
  , word        -- :: TextParser String
  , isWord      -- :: String -> TextParser ()
  , literal     -- :: String -> TextParser ()
  , optionalParens      -- :: TextParser a -> TextParser a
  , parens      -- :: Bool -> TextParser a -> TextParser a
  , field       -- :: Parse a => String -> TextParser a
  , constructors-- :: [(String,TextParser a)] -> TextParser a
  , enumeration -- :: Show a => String -> [a] -> TextParser a
    -- ** Parsers for literal numerics and characters
  , parseSigned
  , parseInt
  , parseDec
  , parseOct
  , parseHex
  , parseFloat
  , parseLitChar
  , parseLitChar'
    -- ** Re-export all the more general combinators from Poly too
  , module Text.ParserCombinators.Poly
    -- ** Strings as whole entities
  , allAsString
  ) where

import Data.Char as Char (isSpace,toLower,isUpper,isDigit,isOctDigit
                         ,isHexDigit,digitToInt,isAlpha,isAlphaNum,ord,chr)
import Data.List (intersperse)
import Data.Ratio
import Text.ParserCombinators.Poly

------------------------------------------------------------------------
-- $parser
-- The Parse class is a replacement for the standard Read class.  It is a
-- specialisation of the (poly) Parser monad for String input.
-- There are instances defined for all Prelude types.
-- For user-defined types, you can write your own instance, or use
-- DrIFT to generate them automatically, e.g. {-! derive : Parse !-}

-- | A synonym for Parser Char, i.e. string input (no state)
type TextParser a = Parser Char a

-- | The class @Parse@ is a replacement for @Read@, operating over String input.
--   Essentially, it permits better error messages for why something failed to
--   parse.  It is rather important that @parse@ can read back exactly what
--   is generated by the corresponding instance of @show@.  To apply a parser
--   to some text, use @runParser@.
class Parse a where
    -- | A straightforward parser for an item.  (A minimal definition of
    --   a class instance requires either |parse| or |parsePrec|.)
    parse     :: TextParser a
    parse       = Int -> TextParser a
forall a. Parse a => Int -> TextParser a
parsePrec Int
0
    -- | A straightforward parser for an item, given the precedence of
    --   any surrounding expression.  (Precedence determines whether
    --   parentheses are mandatory or optional.)
    parsePrec :: Int -> TextParser a
    parsePrec Int
_ = TextParser a -> TextParser a
forall a. TextParser a -> TextParser a
optionalParens TextParser a
forall a. Parse a => TextParser a
parse
    -- | Parsing a list of items by default accepts the [] and comma syntax,
    --   except when the list is really a character string using \"\".
    parseList :: TextParser [a] -- only to distinguish [] and ""
    parseList  = do { [Char] -> TextParser [Char]
isWord [Char]
"[]"; [a] -> TextParser [a]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [] }
                   TextParser [a] -> TextParser [a] -> TextParser [a]
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                 do { [Char] -> TextParser [Char]
isWord [Char]
"["; [Char] -> TextParser [Char]
isWord [Char]
"]"; [a] -> TextParser [a]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [] }
                   TextParser [a] -> TextParser [a] -> TextParser [a]
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                 TextParser [Char]
-> TextParser [Char]
-> TextParser [Char]
-> TextParser a
-> TextParser [a]
forall (p :: * -> *) bra sep ket a.
PolyParse p =>
p bra -> p sep -> p ket -> p a -> p [a]
bracketSep ([Char] -> TextParser [Char]
isWord [Char]
"[") ([Char] -> TextParser [Char]
isWord [Char]
",") ([Char] -> TextParser [Char]
isWord [Char]
"]")
                            (TextParser a -> TextParser a
forall a. TextParser a -> TextParser a
optionalParens TextParser a
forall a. Parse a => TextParser a
parse)
                   TextParser [a] -> ([Char] -> [Char]) -> TextParser [a]
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char]
"Expected a list, but\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

-- | If there already exists a Read instance for a type, then we can make
--   a Parser for it, but with only poor error-reporting.  The string argument
--   is the expected type or value (for error-reporting only).
parseByRead :: Read a => String -> TextParser a
parseByRead :: forall a. Read a => [Char] -> TextParser a
parseByRead [Char]
name =
    ([Char] -> Result [Char] a) -> Parser Char a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[Char]
s-> case ReadS a
forall a. Read a => ReadS a
reads [Char]
s of
                []       -> [Char] -> [Char] -> Result [Char] a
forall z a. z -> [Char] -> Result z a
Failure [Char]
s ([Char]
"no parse, expected a "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
name)
                [(a
a,[Char]
s')] -> [Char] -> a -> Result [Char] a
forall z a. z -> a -> Result z a
Success [Char]
s' a
a
                [(a, [Char])]
_        -> [Char] -> [Char] -> Result [Char] a
forall z a. z -> [Char] -> Result z a
Failure [Char]
s ([Char]
"ambiguous parse, expected a "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
name)
      )

-- | If you have a TextParser for a type, you can easily make it into
--   a Read instance, by throwing away any error messages.
readByParse :: TextParser a -> ReadS a
readByParse :: forall a. TextParser a -> ReadS a
readByParse TextParser a
p = \[Char]
inp->
    case TextParser a -> [Char] -> (Either [Char] a, [Char])
forall t a. Parser t a -> [t] -> (Either [Char] a, [t])
runParser TextParser a
p [Char]
inp of
        (Left [Char]
err,  [Char]
rest) -> []
        (Right a
val, [Char]
rest) -> [(a
val,[Char]
rest)]

-- | If you have a TextParser for a type, you can easily make it into
--   a Read instance, by throwing away any error messages.
readsPrecByParsePrec :: (Int -> TextParser a) -> Int -> ReadS a
readsPrecByParsePrec :: forall a. (Int -> TextParser a) -> Int -> ReadS a
readsPrecByParsePrec Int -> TextParser a
p = \Int
prec [Char]
inp->
    case TextParser a -> [Char] -> (Either [Char] a, [Char])
forall t a. Parser t a -> [t] -> (Either [Char] a, [t])
runParser (Int -> TextParser a
p Int
prec) [Char]
inp of
        (Left [Char]
err,  [Char]
rest) -> []
        (Right a
val, [Char]
rest) -> [(a
val,[Char]
rest)]

-- | One lexical chunk.  This is Haskell'98-style lexing - the result
--   should match Prelude.lex apart from better error-reporting.
word :: TextParser String
word :: TextParser [Char]
word = ([Char] -> Result [Char] [Char]) -> TextParser [Char]
forall t a. ([t] -> Result [t] a) -> Parser t a
P [Char] -> Result [Char] [Char]
p
  where
    p :: [Char] -> Result [Char] [Char]
p [Char]
""       = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure [Char]
"" [Char]
"end of input"
    p (Char
c:[Char]
s)    | Char -> Bool
isSpace Char
c = [Char] -> Result [Char] [Char]
p ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
s)
    p (Char
'\'':[Char]
s) = let (P [Char] -> Result [Char] Char
lit) = Parser Char Char
parseLitChar' in (Char -> [Char]) -> Result [Char] Char -> Result [Char] [Char]
forall a b. (a -> b) -> Result [Char] a -> Result [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> Result [Char] Char
lit (Char
'\''Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
s))
    p (Char
'"':[Char]
s)  = [Char] -> [Char] -> Result [Char] [Char]
lexString [Char]
"\"" [Char]
s
             where lexString :: [Char] -> [Char] -> Result [Char] [Char]
lexString [Char]
acc (Char
'"':[Char]
s)      = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
s ([Char] -> [Char]
forall a. [a] -> [a]
reverse (Char
'"'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
acc))
                   lexString [Char]
acc []           = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure [] ([Char]
"end of input in "
                                                           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"string literal "
                                                           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
acc)
                   lexString [Char]
acc [Char]
s = let (P [Char] -> Result [Char] Char
lit) = Parser Char Char
parseLitChar
                                     in case [Char] -> Result [Char] Char
lit [Char]
s of
                                          Failure [Char]
a [Char]
b -> [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure [Char]
a [Char]
b
                                          Success [Char]
t Char
c -> [Char] -> [Char] -> Result [Char] [Char]
lexString (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
acc) [Char]
t
    p (Char
'0':Char
'x':[Char]
s) = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
t (Char
'0'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
'x'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds) where ([Char]
ds,[Char]
t) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit [Char]
s
    p (Char
'0':Char
'X':[Char]
s) = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
t (Char
'0'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
'X'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds) where ([Char]
ds,[Char]
t) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit [Char]
s
    p (Char
'0':Char
'o':[Char]
s) = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
t (Char
'0'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
'o'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds) where ([Char]
ds,[Char]
t) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isOctDigit [Char]
s
    p (Char
'0':Char
'O':[Char]
s) = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
t (Char
'0'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
'O'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds) where ([Char]
ds,[Char]
t) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isOctDigit [Char]
s
    p (Char
c:[Char]
s) | Char -> Bool
isSingle Char
c = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
s [Char
c]
            | Char -> Bool
isSym    Char
c = let ([Char]
sym,[Char]
t) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSym [Char]
s in [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
t (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
sym)
            | Char -> Bool
isIdInit Char
c = let ([Char]
nam,[Char]
t) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isIdChar [Char]
s in [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
t (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
nam)
            | Char -> Bool
isDigit  Char
c = let ([Char]
ds,[Char]
t)  = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
s in
                           [Char] -> [Char] -> Result [Char] [Char]
lexFracExp (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds) [Char]
t
            | Bool
otherwise  = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
s) ([Char]
"Bad character: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c)
             where isSingle :: Char -> Bool
isSingle Char
c  =  Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
",;()[]{}`"
                   isSym :: Char -> Bool
isSym    Char
c  =  Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"!@#$%&*+./<=>?\\^|:-~"
                   isIdInit :: Char -> Bool
isIdInit Char
c  =  Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
                   isIdChar :: Char -> Bool
isIdChar Char
c  =  Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"_'"
                   lexFracExp :: [Char] -> [Char] -> Result [Char] [Char]
lexFracExp [Char]
acc (Char
'.':Char
d:[Char]
s) | Char -> Bool
isDigit Char
d   =
                                      [Char] -> [Char] -> Result [Char] [Char]
lexExp ([Char]
acc[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char
'.'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
dChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds) [Char]
t
                                              where ([Char]
ds,[Char]
t) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
s
                   lexFracExp [Char]
acc [Char]
s = [Char] -> [Char] -> Result [Char] [Char]
lexExp [Char]
acc [Char]
s
                   lexExp :: [Char] -> [Char] -> Result [Char] [Char]
lexExp     [Char]
acc (Char
e:[Char]
s) | Char
eChar -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`[Char]
"eE" =
                                      case [Char]
s of
                                        (Char
'+':Char
d:[Char]
t) | Char -> Bool
isDigit Char
d ->
                                                    let ([Char]
ds,[Char]
u)=(Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
t in
                                                    [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
u ([Char]
acc[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"e+"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char
dChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds)
                                        (Char
'-':Char
d:[Char]
t) | Char -> Bool
isDigit Char
d ->
                                                    let ([Char]
ds,[Char]
u)=(Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
t in
                                                    [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
u ([Char]
acc[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"e-"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char
dChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds)
                                        (Char
d:[Char]
t) |Char -> Bool
isDigit Char
d ->
                                                    let ([Char]
ds,[Char]
u)=(Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
t in
                                                    [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
u ([Char]
acc[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"e"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char
dChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ds)
                                        [Char]
_ -> [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure [Char]
s ([Char]
"missing +/-/digit "
                                                       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"after e in float "
                                                       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"literal: "
                                                       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char] -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
acc[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"e"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"..."))
                   lexExp     [Char]
acc [Char]
s     = [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
s [Char]
acc



-- | One lexical chunk (Haskell'98-style lexing - the result should match
--   Prelude.lex apart from error-reporting).
oldword :: TextParser String
oldword :: TextParser [Char]
oldword = ([Char] -> Result [Char] [Char]) -> TextParser [Char]
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[Char]
s-> case ReadS [Char]
lex [Char]
s of
                   []         -> [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure [Char]
s  ([Char]
"no input? (impossible)")
                   [([Char]
"",[Char]
"")]  -> [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure [Char]
"" ([Char]
"no input?")
                   [([Char]
"",[Char]
s')]  -> [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> [Char] -> Result z a
Failure [Char]
s  ([Char]
"lexing failed?")
                   (([Char]
x,[Char]
s'):[([Char], [Char])]
_) -> [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [Char]
s' [Char]
x
         )

-- | Ensure that the next input word is the given string.  (Note the input
--   is lexed as haskell, so wordbreaks at spaces, symbols, etc.)
isWord :: String -> TextParser String
isWord :: [Char] -> TextParser [Char]
isWord [Char]
w = do { w' <- TextParser [Char]
word
              ; if w'==w then return w else fail ("expected "++w++" got "++w')
              }

-- | Ensure that the next input word is the given string.  (No
--   lexing, so mixed spaces, symbols, are accepted.)
literal :: String -> TextParser String
literal :: [Char] -> TextParser [Char]
literal [Char]
w = do { w' <- [Char] -> TextParser [Char]
forall {a}. Eq a => [a] -> Parser a [Char]
walk [Char]
w
               ; if w'==w then return w else fail ("expected "++w++" got "++w')
               }
  where walk :: [a] -> Parser a [Char]
walk []     = [Char] -> Parser a [Char]
forall a. a -> Parser a a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
w
        walk (a
c:[a]
cs) = do { x <- Parser a a
forall t. Parser t t
next
                         ; if x==c then walk cs
                                   else return []
                         }

-- | Allow nested parens around an item.
optionalParens :: TextParser a -> TextParser a
optionalParens :: forall a. TextParser a -> TextParser a
optionalParens TextParser a
p = Bool -> TextParser a -> TextParser a
forall a. Bool -> TextParser a -> TextParser a
parens Bool
False TextParser a
p

-- | Allow nested parens around an item (one set required when Bool is True).
parens :: Bool -> TextParser a -> TextParser a
parens :: forall a. Bool -> TextParser a -> TextParser a
parens Bool
True  TextParser a
p = TextParser [Char]
-> TextParser [Char] -> TextParser a -> TextParser a
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket ([Char] -> TextParser [Char]
isWord [Char]
"(") ([Char] -> TextParser [Char]
isWord [Char]
")") (Bool -> TextParser a -> TextParser a
forall a. Bool -> TextParser a -> TextParser a
parens Bool
False TextParser a
p)
parens Bool
False TextParser a
p = Bool -> TextParser a -> TextParser a
forall a. Bool -> TextParser a -> TextParser a
parens Bool
True TextParser a
p TextParser a -> TextParser a -> TextParser a
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` TextParser a
p

-- | Deal with named field syntax.  The string argument is the field name,
--   and the parser returns the value of the field.
field :: Parse a => String -> TextParser a
field :: forall a. Parse a => [Char] -> TextParser a
field [Char]
name = do { [Char] -> TextParser [Char]
isWord [Char]
name; Parser Char a -> Parser Char a
forall a. TextParser a -> TextParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (Parser Char a -> Parser Char a) -> Parser Char a -> Parser Char a
forall a b. (a -> b) -> a -> b
$ do { [Char] -> TextParser [Char]
isWord [Char]
"="; Parser Char a
forall a. Parse a => TextParser a
parse } }

-- | Parse one of a bunch of alternative constructors.  In the list argument,
--   the first element of the pair is the constructor name, and
--   the second is the parser for the rest of the value.  The first matching
--   parse is returned.
constructors :: [(String,TextParser a)] -> TextParser a
constructors :: forall a. [([Char], TextParser a)] -> TextParser a
constructors [([Char], TextParser a)]
cs = [([Char], TextParser a)] -> TextParser a
forall a. [([Char], TextParser a)] -> TextParser a
forall (p :: * -> *) a. Commitment p => [([Char], p a)] -> p a
oneOf' ((([Char], TextParser a) -> ([Char], TextParser a))
-> [([Char], TextParser a)] -> [([Char], TextParser a)]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], TextParser a) -> ([Char], TextParser a)
forall {b}. ([Char], Parser Char b) -> ([Char], Parser Char b)
cons [([Char], TextParser a)]
cs)
    where cons :: ([Char], Parser Char b) -> ([Char], Parser Char b)
cons ([Char]
name,Parser Char b
p) =
               ( [Char]
name
               , do { [Char] -> TextParser [Char]
isWord [Char]
name
                    ; Parser Char b
p Parser Char b -> ([Char] -> [Char]) -> Parser Char b
forall (p :: * -> *) a.
PolyParse p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErrBad` (([Char]
"got constructor, but within "
                                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
name[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
",\n")[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
                    }
               )

-- | Parse one of the given nullary constructors (an enumeration).
--   The string argument is the name of the type, and the list argument
--   should contain all of the possible enumeration values.
enumeration :: (Show a) => String -> [a] -> TextParser a
enumeration :: forall a. Show a => [Char] -> [a] -> TextParser a
enumeration [Char]
typ [a]
cs = [Parser Char a] -> Parser Char a
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf ((a -> Parser Char a) -> [a] -> [Parser Char a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
c-> do { [Char] -> TextParser [Char]
isWord (a -> [Char]
forall a. Show a => a -> [Char]
show a
c); a -> Parser Char a
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return a
c }) [a]
cs)
                         Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr`
                     ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++([Char]
"\n  expected "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
typ[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" value ("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
e[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
")"))
    where e :: [Char]
e = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
", " ((a -> [Char]) -> [a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
cs)))
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", or " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> a
forall a. HasCallStack => [a] -> a
last [a]
cs)

------------------------------------------------------------------------
-- Instances for all the Standard Prelude types.

-- Numeric types
parseSigned :: Real a => TextParser a -> TextParser a
parseSigned :: forall a. Real a => TextParser a -> TextParser a
parseSigned TextParser a
p = do Char -> TextParser a
'-' <- Parser Char Char
forall t. Parser t t
next; commit (fmap negate p)
                TextParser a -> TextParser a -> TextParser a
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                do p

parseInt :: (Integral a) => String ->
                            a -> (Char -> Bool) -> (Char -> Int) ->
                            TextParser a
parseInt :: forall a.
Integral a =>
[Char] -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a
parseInt [Char]
base a
radix Char -> Bool
isDigit Char -> Int
digitToInt =
                 do cs <- Parser Char Char -> TextParser [Char]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isDigit)
                    return (foldl1 (\a
n a
d-> a
na -> a -> a
forall a. Num a => a -> a -> a
*a
radixa -> a -> a
forall a. Num a => a -> a -> a
+a
d)
                                   (map (fromIntegral . digitToInt) cs))
                 Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++([Char]
"\nexpected one or more "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
base[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" digits"))
parseDec, parseOct, parseHex :: (Integral a) => TextParser a
parseDec :: forall a. Integral a => TextParser a
parseDec = [Char] -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a
forall a.
Integral a =>
[Char] -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a
parseInt [Char]
"decimal" a
10 Char -> Bool
Char.isDigit    Char -> Int
Char.digitToInt
parseOct :: forall a. Integral a => TextParser a
parseOct = [Char] -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a
forall a.
Integral a =>
[Char] -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a
parseInt [Char]
"octal"    a
8 Char -> Bool
Char.isOctDigit Char -> Int
Char.digitToInt
parseHex :: forall a. Integral a => TextParser a
parseHex = [Char] -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a
forall a.
Integral a =>
[Char] -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a
parseInt [Char]
"hex"     a
16 Char -> Bool
Char.isHexDigit Char -> Int
Char.digitToInt

parseFloat :: (RealFrac a) => TextParser a
parseFloat :: forall a. RealFrac a => TextParser a
parseFloat = do ds   <- Parser Char Char -> TextParser [Char]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isDigit)
                frac <- (do '.' <- next
                            many (satisfy isDigit)
                              `adjustErrBad` (++"expected digit after .")
                         `onFail` return [] )
                exp  <- exponent `onFail` return 0
                ( return . fromRational . (* (10^^(exp - length frac)))
                  . (% 1) .  (\ (Right Integer
x) -> Integer
x) . fst
                  . runParser parseDec ) (ds++frac)
             Parser Char a -> Parser Char a -> Parser Char a
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             do w <- Parser Char Char -> TextParser [Char]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace))
                case map toLower w of
                  [Char]
"nan"      -> a -> Parser Char a
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
0a -> a -> a
forall a. Fractional a => a -> a -> a
/a
0)
                  [Char]
"infinity" -> a -> Parser Char a
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
0)
                  [Char]
_          -> [Char] -> Parser Char a
forall a. HasCallStack => [Char] -> Parser Char a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"expected a floating point number"
  where exponent :: Parser Char Int
exponent = do Char -> Parser Char Int
'e' <- (Char -> Char) -> Parser Char Char -> Parser Char Char
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower Parser Char Char
forall t. Parser t t
next
                      commit (do '+' <- next; parseDec
                              `onFail`
                              parseSigned parseDec )

-- | Parse a Haskell character literal, including the surrounding single quotes.
parseLitChar' :: TextParser Char
parseLitChar' :: Parser Char Char
parseLitChar' = do Char -> Parser Char Char
'\'' <- Parser Char Char
forall t. Parser t t
next Parser Char Char -> ([Char] -> [Char]) -> Parser Char Char
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"expected a literal char")
                   char <- parseLitChar
                   '\'' <- next `adjustErrBad` (++"literal char has no final '")
                   return char

-- | Parse a Haskell character literal, excluding the surrounding single quotes.
parseLitChar :: TextParser Char
parseLitChar :: Parser Char Char
parseLitChar = do c <- Parser Char Char
forall t. Parser t t
next
                  char <- case c of
                            Char
'\\' -> Parser Char Char
forall t. Parser t t
next Parser Char Char -> (Char -> Parser Char Char) -> Parser Char Char
forall a b. Parser Char a -> (a -> Parser Char b) -> Parser Char b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> Parser Char Char
escape
                            Char
'\'' -> [Char] -> Parser Char Char
forall a. HasCallStack => [Char] -> Parser Char a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"expected a literal char, got ''"
                            Char
_    -> Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
                  return char

  where
    escape :: Char -> Parser Char Char
escape Char
'a'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\a'
    escape Char
'b'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\b'
    escape Char
'f'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\f'
    escape Char
'n'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
    escape Char
'r'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\r'
    escape Char
't'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\t'
    escape Char
'v'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\v'
    escape Char
'\\' = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\\'
    escape Char
'"'  = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'"'
    escape Char
'\'' = Char -> Parser Char Char
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\''
    escape Char
'^'  = do ctrl <- Parser Char Char
forall t. Parser t t
next
                     if ctrl >= '@' && ctrl <= '_'
                       then return (chr (ord ctrl - ord '@'))
                       else fail ("literal char ctrl-escape malformed: \\^"
                                   ++[ctrl])
    escape Char
d | Char -> Bool
isDigit Char
d
                = (Int -> Char) -> Parser Char Int -> Parser Char Char
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
chr (Parser Char Int -> Parser Char Char)
-> Parser Char Int -> Parser Char Char
forall a b. (a -> b) -> a -> b
$  ([Char] -> Parser Char ()
forall t. [t] -> Parser t ()
reparse [Char
d] Parser Char () -> Parser Char Int -> Parser Char Int
forall a b. Parser Char a -> Parser Char b -> Parser Char b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char Int
forall a. Integral a => TextParser a
parseDec)
    escape Char
'o'  = (Int -> Char) -> Parser Char Int -> Parser Char Char
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
chr (Parser Char Int -> Parser Char Char)
-> Parser Char Int -> Parser Char Char
forall a b. (a -> b) -> a -> b
$  Parser Char Int
forall a. Integral a => TextParser a
parseOct
    escape Char
'x'  = (Int -> Char) -> Parser Char Int -> Parser Char Char
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
chr (Parser Char Int -> Parser Char Char)
-> Parser Char Int -> Parser Char Char
forall a b. (a -> b) -> a -> b
$  Parser Char Int
forall a. Integral a => TextParser a
parseHex
    escape Char
c | Char -> Bool
isUpper Char
c
                = Char -> Parser Char Char
mnemonic Char
c
    escape Char
c    = [Char] -> Parser Char Char
forall a. HasCallStack => [Char] -> Parser Char a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char]
"unrecognised escape sequence in literal char: \\"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char
c])

    mnemonic :: Char -> Parser Char Char
mnemonic Char
'A' = do Char -> Parser Char Char
'C' <- Parser Char Char
forall t. Parser t t
next; 'K' <- next; return '\ACK'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\ACK'"
    mnemonic Char
'B' = do Char -> Parser Char Char
'E' <- Parser Char Char
forall t. Parser t t
next; 'L' <- next; return '\BEL'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'S' <- Parser Char Char
forall t. Parser t t
next; return '\BS'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\BEL' or '\\BS'"
    mnemonic Char
'C' = do Char -> Parser Char Char
'R' <- Parser Char Char
forall t. Parser t t
next; return '\CR'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'A' <- Parser Char Char
forall t. Parser t t
next; 'N' <- next; return '\CAN'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\CR' or '\\CAN'"
    mnemonic Char
'D' = do Char -> Parser Char Char
'E' <- Parser Char Char
forall t. Parser t t
next; 'L' <- next; return '\DEL'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'L' <- Parser Char Char
forall t. Parser t t
next; 'E' <- next; return '\DLE'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'C' <- Parser Char Char
forall t. Parser t t
next; ( do '1' <- next; return '\DC1'
                                     `onFail`
                                     do '2' <- next; return '\DC2'
                                     `onFail`
                                     do '3' <- next; return '\DC3'
                                     `onFail`
                                     do '4' <- next; return '\DC4' )
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\DEL' or '\\DLE' or '\\DC[1..4]'"
    mnemonic Char
'E' = do Char -> Parser Char Char
'T' <- Parser Char Char
forall t. Parser t t
next; 'X' <- next; return '\ETX'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'O' <- Parser Char Char
forall t. Parser t t
next; 'T' <- next; return '\EOT'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'N' <- Parser Char Char
forall t. Parser t t
next; 'Q' <- next; return '\ENQ'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'T' <- Parser Char Char
forall t. Parser t t
next; 'B' <- next; return '\ETB'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'M' <- Parser Char Char
forall t. Parser t t
next; return '\EM'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'S' <- Parser Char Char
forall t. Parser t t
next; 'C' <- next; return '\ESC'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"one of '\\ETX' '\\EOT' '\\ENQ' '\\ETB' '\\EM' or '\\ESC'"
    mnemonic Char
'F' = do Char -> Parser Char Char
'F' <- Parser Char Char
forall t. Parser t t
next; return '\FF'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'S' <- Parser Char Char
forall t. Parser t t
next; return '\FS'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\FF' or '\\FS'"
    mnemonic Char
'G' = do Char -> Parser Char Char
'S' <- Parser Char Char
forall t. Parser t t
next; return '\GS'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\GS'"
    mnemonic Char
'H' = do Char -> Parser Char Char
'T' <- Parser Char Char
forall t. Parser t t
next; return '\HT'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\HT'"
    mnemonic Char
'L' = do Char -> Parser Char Char
'F' <- Parser Char Char
forall t. Parser t t
next; return '\LF'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\LF'"
    mnemonic Char
'N' = do Char -> Parser Char Char
'U' <- Parser Char Char
forall t. Parser t t
next; 'L' <- next; return '\NUL'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'A' <- Parser Char Char
forall t. Parser t t
next; 'K' <- next; return '\NAK'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\NUL' or '\\NAK'"
    mnemonic Char
'R' = do Char -> Parser Char Char
'S' <- Parser Char Char
forall t. Parser t t
next; return '\RS'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\RS'"
    mnemonic Char
'S' = do Char -> Parser Char Char
'O' <- Parser Char Char
forall t. Parser t t
next; 'H' <- next; return '\SOH'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'O' <- Parser Char Char
forall t. Parser t t
next; return '\SO'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'T' <- Parser Char Char
forall t. Parser t t
next; 'X' <- next; return '\STX'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'I' <- Parser Char Char
forall t. Parser t t
next; return '\SI'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'Y' <- Parser Char Char
forall t. Parser t t
next; 'N' <- next; return '\SYN'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'U' <- Parser Char Char
forall t. Parser t t
next; 'B' <- next; return '\SUB'
                   Parser Char Char -> Parser Char Char -> Parser Char Char
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   do Char -> Parser Char Char
'P' <- Parser Char Char
forall t. Parser t t
next; return '\SP'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\SOH' '\\SO' '\\STX' '\\SI' '\\SYN' '\\SUB' or '\\SP'"
    mnemonic Char
'U' = do Char -> Parser Char Char
'S' <- Parser Char Char
forall t. Parser t t
next; return '\US'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\US'"
    mnemonic Char
'V' = do Char -> Parser Char Char
'T' <- Parser Char Char
forall t. Parser t t
next; return '\VT'
                   Parser Char Char -> [Char] -> Parser Char Char
forall {t} {a}. Parser t a -> [Char] -> Parser t a
`wrap` [Char]
"'\\VT'"
    wrap :: Parser t a -> [Char] -> Parser t a
wrap Parser t a
p [Char]
s = Parser t a
p Parser t a -> Parser t a -> Parser t a
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` [Char] -> Parser t a
forall a. HasCallStack => [Char] -> Parser t a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char]
"expected literal char "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s)

-- Basic types
instance Parse Int where
 -- parse = parseByRead "Int"   -- convert from Integer, deals with minInt
    parse :: Parser Char Int
parse = (Integer -> Int) -> Parser Char Integer -> Parser Char Int
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Parser Char Integer -> Parser Char Int)
-> Parser Char Integer -> Parser Char Int
forall a b. (a -> b) -> a -> b
$
              do Parser Char Char -> TextParser [Char]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isSpace); Parser Char Integer -> Parser Char Integer
forall a. Real a => TextParser a -> TextParser a
parseSigned Parser Char Integer
forall a. Integral a => TextParser a
parseDec
instance Parse Integer where
 -- parse = parseByRead "Integer"
    parse :: Parser Char Integer
parse = do Parser Char Char -> TextParser [Char]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isSpace); Parser Char Integer -> Parser Char Integer
forall a. Real a => TextParser a -> TextParser a
parseSigned Parser Char Integer
forall a. Integral a => TextParser a
parseDec
instance Parse Float where
 -- parse = parseByRead "Float"
    parse :: TextParser Float
parse = do Parser Char Char -> TextParser [Char]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isSpace); TextParser Float -> TextParser Float
forall a. Real a => TextParser a -> TextParser a
parseSigned TextParser Float
forall a. RealFrac a => TextParser a
parseFloat
instance Parse Double where
 -- parse = parseByRead "Double"
    parse :: TextParser Double
parse = do Parser Char Char -> TextParser [Char]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isSpace); TextParser Double -> TextParser Double
forall a. Real a => TextParser a -> TextParser a
parseSigned TextParser Double
forall a. RealFrac a => TextParser a
parseFloat
instance Parse Char where
--  parse = parseByRead "Char"
    parse :: Parser Char Char
parse = do Parser Char Char -> TextParser [Char]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isSpace); Parser Char Char
parseLitChar'
 -- parse = do { w <- word; if head w == '\'' then readLitChar (tail w)
 --                                           else fail "expected a char" }
 -- parseList = bracket (isWord "\"") (satisfy (=='"'))
 --                     (many (satisfy (/='"')))
        -- not totally correct for strings...
    parseList :: TextParser [Char]
parseList = do { w <- TextParser [Char]
word; if head w == '"' then return (init (tail w))
                                else fail "not a string" }

instance Parse Bool where
    parse :: TextParser Bool
parse = [Char] -> [Bool] -> TextParser Bool
forall a. Show a => [Char] -> [a] -> TextParser a
enumeration [Char]
"Bool" [Bool
False,Bool
True]

instance Parse Ordering where
    parse :: TextParser Ordering
parse = [Char] -> [Ordering] -> TextParser Ordering
forall a. Show a => [Char] -> [a] -> TextParser a
enumeration [Char]
"Ordering" [Ordering
LT,Ordering
EQ,Ordering
GT]

-- Structural types
instance Parse () where
    parse :: Parser Char ()
parse = ([Char] -> Result [Char] ()) -> Parser Char ()
forall t a. ([t] -> Result [t] a) -> Parser t a
P [Char] -> Result [Char] ()
p
      where p :: [Char] -> Result [Char] ()
p []       = [Char] -> [Char] -> Result [Char] ()
forall z a. z -> [Char] -> Result z a
Failure [] [Char]
"no input: expected a ()"
            p (Char
'(':[Char]
cs) = case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
cs of
                             (Char
')':[Char]
s) -> [Char] -> () -> Result [Char] ()
forall z a. z -> a -> Result z a
Success [Char]
s ()
                             [Char]
_       -> [Char] -> [Char] -> Result [Char] ()
forall z a. z -> [Char] -> Result z a
Failure [Char]
cs [Char]
"Expected ) after ("
            p (Char
c:[Char]
cs) | Char -> Bool
isSpace Char
c = [Char] -> Result [Char] ()
p [Char]
cs
                     | Bool
otherwise = [Char] -> [Char] -> Result [Char] ()
forall z a. z -> [Char] -> Result z a
Failure (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs) ([Char]
"Expected a (), got "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c)

instance (Parse a, Parse b) => Parse (a,b) where
    parse :: TextParser (a, b)
parse = do{ [Char] -> TextParser [Char]
isWord [Char]
"(" TextParser [Char] -> ([Char] -> [Char]) -> TextParser [Char]
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char]
"Opening a 2-tuple\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
              ; x <- TextParser a
forall a. Parse a => TextParser a
parse TextParser a -> ([Char] -> [Char]) -> TextParser a
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char]
"In 1st item of a 2-tuple\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
              ; isWord "," `adjustErr` ("Separating a 2-tuple\n"++)
              ; y <- parse `adjustErr` ("In 2nd item of a 2-tuple\n"++)
              ; isWord ")" `adjustErr` ("Closing a 2-tuple\n"++)
              ; return (x,y) }

instance (Parse a, Parse b, Parse c) => Parse (a,b,c) where
    parse :: TextParser (a, b, c)
parse = do{ [Char] -> TextParser [Char]
isWord [Char]
"(" TextParser [Char] -> ([Char] -> [Char]) -> TextParser [Char]
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char]
"Opening a 3-tuple\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
              ; x <- TextParser a
forall a. Parse a => TextParser a
parse TextParser a -> ([Char] -> [Char]) -> TextParser a
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char]
"In 1st item of a 3-tuple\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
              ; isWord "," `adjustErr` ("Separating(1) a 3-tuple\n"++)
              ; y <- parse `adjustErr` ("In 2nd item of a 3-tuple\n"++)
              ; isWord "," `adjustErr` ("Separating(2) a 3-tuple\n"++)
              ; z <- parse `adjustErr` ("In 3rd item of a 3-tuple\n"++)
              ; isWord ")" `adjustErr` ("Closing a 3-tuple\n"++)
              ; return (x,y,z) }

instance Parse a => Parse (Maybe a) where
    parsePrec :: Int -> TextParser (Maybe a)
parsePrec Int
p =
            TextParser (Maybe a) -> TextParser (Maybe a)
forall a. TextParser a -> TextParser a
optionalParens (do { [Char] -> TextParser [Char]
isWord [Char]
"Nothing"; Maybe a -> TextParser (Maybe a)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing })
            TextParser (Maybe a)
-> TextParser (Maybe a) -> TextParser (Maybe a)
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
            Bool -> TextParser (Maybe a) -> TextParser (Maybe a)
forall a. Bool -> TextParser a -> TextParser a
parens (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
9)   (do { [Char] -> TextParser [Char]
isWord [Char]
"Just"
                               ; (a -> Maybe a) -> Parser Char a -> TextParser (Maybe a)
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Parser Char a -> TextParser (Maybe a))
-> Parser Char a -> TextParser (Maybe a)
forall a b. (a -> b) -> a -> b
$ Int -> Parser Char a
forall a. Parse a => Int -> TextParser a
parsePrec Int
10
                                     Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
PolyParse p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErrBad` ([Char]
"but within Just, "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) })
            TextParser (Maybe a) -> ([Char] -> [Char]) -> TextParser (Maybe a)
forall a. Parser Char a -> ([Char] -> [Char]) -> Parser Char a
forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` (([Char]
"expected a Maybe (Just or Nothing)\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
indent Int
2)

instance (Parse a, Parse b) => Parse (Either a b) where
    parsePrec :: Int -> TextParser (Either a b)
parsePrec Int
p =
            Bool -> TextParser (Either a b) -> TextParser (Either a b)
forall a. Bool -> TextParser a -> TextParser a
parens (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
9) (TextParser (Either a b) -> TextParser (Either a b))
-> TextParser (Either a b) -> TextParser (Either a b)
forall a b. (a -> b) -> a -> b
$
            [([Char], TextParser (Either a b))] -> TextParser (Either a b)
forall a. [([Char], TextParser a)] -> TextParser a
constructors [ ([Char]
"Left",  do { (a -> Either a b) -> Parser Char a -> TextParser (Either a b)
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left  (Parser Char a -> TextParser (Either a b))
-> Parser Char a -> TextParser (Either a b)
forall a b. (a -> b) -> a -> b
$ Int -> Parser Char a
forall a. Parse a => Int -> TextParser a
parsePrec Int
10 } )
                         , ([Char]
"Right", do { (b -> Either a b) -> Parser Char b -> TextParser (Either a b)
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right (Parser Char b -> TextParser (Either a b))
-> Parser Char b -> TextParser (Either a b)
forall a b. (a -> b) -> a -> b
$ Int -> Parser Char b
forall a. Parse a => Int -> TextParser a
parsePrec Int
10 } )
                         ]

instance Parse a => Parse [a] where
    parse :: TextParser [a]
parse = TextParser [a]
forall a. Parse a => TextParser [a]
parseList

-- | Simply return the entire remaining input String.
allAsString :: TextParser String
allAsString :: TextParser [Char]
allAsString =  ([Char] -> Result [Char] [Char]) -> TextParser [Char]
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[Char]
s-> [Char] -> [Char] -> Result [Char] [Char]
forall z a. z -> a -> Result z a
Success [] [Char]
s)

------------------------------------------------------------------------