module Database.TxtSushi.ParseUtil (
parseInt,
maybeReadInt,
maybeReadReal,
parseReal,
withoutTrailing,
withTrailing,
eatSpacesAfter,
quotedText,
escapedQuote,
ifParseThen,
preservingIfParseThen,
ifParseThenElse,
genExcept,
genNotFollowedBy,
maybeParse,
sepByExactly,
sepByAtLeast) where
import Text.ParserCombinators.Parsec
parseInt :: GenParser Char st Int
parseInt = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do
digitTxt <- anyParseTxt
return $ read digitTxt
where
anyParseTxt = signedParseTxt <|> unsignedParseTxt <?> "integer"
unsignedParseTxt = many1 digit
signedParseTxt = do
_ <- char '-'
unsignedDigitTxt <- unsignedParseTxt
return $ '-' : unsignedDigitTxt
maybeReadInt :: String -> Maybe Int
maybeReadInt intStr =
case parse (withTrailing (spaces >> eof) (spaces >> parseInt)) "" intStr of
Left _ -> Nothing
Right int -> Just int
maybeReadReal :: String -> Maybe Double
maybeReadReal realStr =
case parse (withTrailing (spaces >> eof) (spaces >> parseReal)) "" realStr of
Left _ -> maybeReadInt realStr >>= (\int -> Just $ fromIntegral int)
Right real -> Just real
parseReal :: GenParser Char st Double
parseReal = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do
realTxt <- anyParseTxt <?> "real"
return $ read realTxt
where
anyParseTxt = do
txtWithoutExp <- txtWithoutExponent
expPart <- try exponentPart <|> return ""
return $ txtWithoutExp ++ expPart
exponentPart = do
e <- (char 'e' <|> char 'E')
negPart <- (char '-' >> return "-") <|> return ""
numPart <- many1 digit
return $ (e:negPart) ++ numPart
txtWithoutExponent = signedTxt <|> unsignedTxt <?> "real"
unsignedTxt = do
intTxt <- many1 digit
_ <- char '.'
fracTxt <- many1 digit
return $ intTxt ++ "." ++ fracTxt
signedTxt = do
_ <- char '-'
unsignedDigitTxt <- unsignedTxt
return ('-':unsignedDigitTxt)
withoutTrailing :: (Show s) => GenParser tok st s -> GenParser tok st a -> GenParser tok st a
withoutTrailing end p = p >>= (\x -> genNotFollowedBy end >> return x)
withTrailing :: (Monad m) => m a -> m b -> m b
withTrailing end p = p >>= (\x -> end >> return x)
eatSpacesAfter :: GenParser Char st a -> GenParser Char st a
eatSpacesAfter p = p >>= (\x -> spaces >> return x)
quotedText :: Bool -> Char -> GenParser Char st String
quotedText allowEmpty quoteChar = do
let quote = char quoteChar
manyFunc = if allowEmpty then many else many1
_ <- quote
textValue <- manyFunc $ (anyChar `genExcept` quote) <|>
try (escapedQuote quoteChar)
_ <- quote
spaces
return textValue
escapedQuote :: Char -> GenParser Char st Char
escapedQuote quoteChar = string [quoteChar, quoteChar] >> return quoteChar
ifParseThen :: GenParser tok st a -> GenParser tok st b -> GenParser tok st (Maybe b)
ifParseThen ifParse = fmap (fmap snd) . preservingIfParseThen ifParse
preservingIfParseThen :: GenParser tok st a -> GenParser tok st b -> GenParser tok st (Maybe (a, b))
preservingIfParseThen ifParse thenPart = do
ifResult <- maybeParse ifParse
case ifResult of
Just x -> thenPart >>= (\y -> return $ Just (x, y))
Nothing -> return Nothing
ifParseThenElse :: GenParser tok st a -> GenParser tok st b -> GenParser tok st b -> GenParser tok st b
ifParseThenElse ifParse thenPart elsePart = do
ifResult <- maybeParse ifParse
case ifResult of
Just _ -> thenPart
Nothing -> elsePart
genExcept :: (Show b) => GenParser tok st a -> GenParser tok st b -> GenParser tok st a
genExcept parser theException = do
genNotFollowedBy theException
parser
genNotFollowedBy :: (Show a) => GenParser tok st a -> GenParser tok st ()
genNotFollowedBy theParser = try $ do
mayParseResult <- maybeParse theParser
case mayParseResult of
Nothing -> return ()
Just x -> unexpected $ show x
maybeParse :: GenParser tok st a -> GenParser tok st (Maybe a)
maybeParse parser =
(try parser >>= return . Just) <|> return Nothing
sepByExactly :: Int -> GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a]
sepByExactly itemCount itemParser sepParser =
let itemParsers = replicate itemCount itemParser
in parseEach itemParsers
where
parseEach [] = return []
parseEach [lastParser] = lastParser >>= (\x -> return [x])
parseEach (headParser:parserTail) = do
resultHead <- headParser
_ <- sepParser
resultTail <- parseEach parserTail
return $ resultHead:resultTail
sepByAtLeast :: Int -> GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a]
sepByAtLeast 0 itemParser sepParser = sepBy itemParser sepParser
sepByAtLeast minCount itemParser sepParser = do
minResults <- sepByExactly minCount itemParser sepParser
tailResults <-
ifParseThenElse sepParser (sepBy itemParser sepParser) (return [])
return $ minResults ++ tailResults