module Text.ConfigParser.Parser where
import Control.Monad (void)
import Data.String (IsString(..))
import Text.Parsec (SourceName, ParseError, State(..))
import Text.Parsec (getParserState, setParserState, unexpected, newline)
import Text.Parsec (manyTill, char, choice, digit, sepBy, many, many1, try)
import Text.Parsec (spaces, eof, parse, (<|>), (<?>))
import Text.Parsec.Char (noneOf, oneOf, anyChar)
import Text.Parsec.Text (Parser)
import qualified Text.Parsec as P (string)
import Text.ConfigParser.Util
import Text.ConfigParser.Types
string :: IsString s => Parser s
string = char '"' *> fmap fromString (many stringChar) <* char '"'
<?> "string in quotes"
where
stringChar = noneOf "\"\n\\" <|> char '\\' *> escapeSeq
escapeSeq = char '"' <|> char '\\' <|> '\n' <$ char 'n'
integer :: Parser Integer
integer = read .: (++) <$> sign <*> many1 digit <?> "integer"
where
sign = P.string "-" <|> P.string ""
boundedIntegral :: forall n. (Show n, Bounded n, Integral n) => Parser n
boundedIntegral = bound =<< integer
<?> "integer between " ++ show intMin ++ " and " ++ show intMax
where
intMin = minBound :: n
intMax = maxBound :: n
bound n | n > fromIntegral intMax = unexpected $ "integer above " ++ show intMax
| n < fromIntegral intMin = unexpected $ "integer below " ++ show intMin
| otherwise = return $ fromIntegral n
bool :: Parser Bool
bool = True <$ try truthy <|> False <$ try falsey
where
truthy = choice $ fmap P.string ["true", "True", "yes", "Yes", "on", "On"]
falsey = choice $ fmap P.string ["false", "False", "no", "No", "off", "Off"]
list :: (Parser a) -> Parser [a]
list p = initial *> (p `sepBy` separator) <* terminator <?> "list in brackets"
where
initial = try $ char '[' <* spaces
separator = try $ spaces *> char ',' <* spaces
terminator = try $ spaces *> char ']'
whitespace :: Parser ()
whitespace = () <$ many (oneOf " \t\v\r") <?> "whitespace"
actionParser :: ConfigParser c -> ConfigOption c -> Parser (c -> c)
actionParser c ConfigOption {..} =
whitespace *> keyValue c key (action <$> parser)
replaceParserInput :: Parser String -> Parser ()
replaceParserInput p = do
s <- getParserState
i <- p
void $ setParserState s {stateInput = fromString i}
removeLineComments :: ConfigParser c -> Parser ()
removeLineComments ConfigParser {..} = replaceParserInput $
mconcat <$> many (escapedComment <|> comment <|> content)
where
startComment = choice $ try . P.string <$> lineCommentInit
terminator = void newline <|> eof
comment = '\n':[] <$ startComment <* anyChar `manyTill` terminator
escapedComment = try $ char '\\' *> startComment
content = (:[]) <$> anyChar
removeExtraSpaces :: Parser ()
removeExtraSpaces = replaceParserInput $
whitespace *> contentChar `manyTill` try (whitespace *> eof)
where
contentChar = try strippedNL <|> anyChar
strippedNL = whitespace *> newline <* whitespace
removeExtraLines :: Parser ()
removeExtraLines = replaceParserInput $
optionalNLs *> contentChar `manyTill` try (optionalNLs *> eof)
where
contentChar = combinedNLs <|> anyChar
optionalNLs = () <$ many newline
combinedNLs = '\n' <$ many1 newline
config :: ConfigParser c -> Parser c
config p = foldr ($) (defaults p) <$> do
removeLineComments p
removeExtraSpaces
removeExtraLines
optionParsers `sepBy` newline <* eof
where
optionParsers = choice $ try . actionParser p <$> options p
parseFromFile :: ConfigParser c -> SourceName -> IO (Either ParseError c)
parseFromFile p f = parse (config p) f . fromString <$> readFile f