module Text.Parse
(
TextParser
, Parse(..)
, parseByRead
, word
, isWord
, optionalParens
, field
, constructors
, enumeration
, module Text.ParserCombinators.Poly
) where
import Char (isSpace)
import List (intersperse)
import Text.ParserCombinators.Poly
type TextParser a = Parser Char a
class Parse a where
parse :: TextParser a
parseList :: TextParser [a]
parseList = do { isWord "[]"; return [] }
`onFail`
do { isWord "["; isWord "]"; return [] }
`onFail`
bracketSep (isWord "[") (isWord ",") (isWord "]") parse
`adjustErr` ("Expected a list, but\n"++)
parseByRead :: Read a => String -> TextParser a
parseByRead name =
P (\s-> case reads s of
[] -> (Left (False,"no parse, expected a "++name), s)
[(a,s')] -> (Right a, s')
_ -> (Left (False,"ambiguous parse, expected a "++name), s)
)
word :: TextParser String
word = P (\s-> case lex s of
[] -> (Left (False,"no input? (impossible)"), s)
[("",s')] -> (Left (False,"no input?"), s')
((x,s'):_) -> (Right x, s') )
isWord :: String -> TextParser String
isWord w = do { w' <- word
; if w'==w then return w else fail ("expected "++w++" got "++w')
}
optionalParens :: TextParser a -> TextParser a
optionalParens p = bracket (isWord "(") (isWord ")") p `onFail` p
field :: Parse a => String -> TextParser a
field name = do { isWord name; commit $ do { isWord "="; parse } }
constructors :: [(String,TextParser a)] -> TextParser a
constructors cs = oneOf' (map cons cs)
where cons (name,p) =
( name
, do { isWord name
; p `adjustErrBad` (("got constructor, but within "
++name++",\n")++)
}
)
enumeration :: (Show a) => String -> [a] -> TextParser a
enumeration typ cs = oneOf (map (\c-> do { isWord (show c); return c }) cs)
`adjustErr`
(++("\n expected "++typ++" value ("++e++")"))
where e = concat (intersperse ", " (map show (init cs)))
++ ", or " ++ show (last cs)
instance Parse Int where
parse = parseByRead "Int"
instance Parse Integer where
parse = parseByRead "Integer"
instance Parse Float where
parse = parseByRead "Float"
instance Parse Double where
parse = parseByRead "Double"
instance Parse Char where
parse = parseByRead "Char"
parseList = do { w <- word; if head w == '"' then return (init (tail w))
else fail "not a string" }
instance Parse Bool where
parse = enumeration "Bool" [False,True]
instance Parse Ordering where
parse = enumeration "Ordering" [LT,EQ,GT]
instance Parse () where
parse = P p
where p [] = (Left (False,"no input: expected a ()"), [])
p ('(':cs) = case dropWhile isSpace cs of
(')':s) -> (Right (), s)
_ -> (Left (False,"Expected ) after ("), cs)
p (c:cs) | isSpace c = p cs
| otherwise = ( Left (False,"Expected a (), got "++show c)
, (c:cs))
instance (Parse a, Parse b) => Parse (a,b) where
parse = do{ isWord "(" `adjustErr` ("Opening a 2-tuple\n"++)
; x <- parse `adjustErr` ("In 1st item of a 2-tuple\n"++)
; 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 = do{ isWord "(" `adjustErr` ("Opening a 3-tuple\n"++)
; x <- parse `adjustErr` ("In 1st item of a 3-tuple\n"++)
; 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
parse = do { isWord "Nothing"; return Nothing }
`onFail`
do { isWord "Just"
; fmap Just $ optionalParens parse
`adjustErrBad` ("but within Just, "++)
}
`adjustErr` (("expected a Maybe (Just or Nothing)\n"++).indent 2)
instance (Parse a, Parse b) => Parse (Either a b) where
parse = constructors [ ("Left", do { fmap Left $ optionalParens parse } )
, ("Right", do { fmap Right $ optionalParens parse } )
]
instance Parse a => Parse [a] where
parse = parseList