module ConfigParser
( OptParser
, parseConfig
, parseConfigFile
, option
, customOption
, parserDefault
, parserExample
, ConfParseError
, Option
, OptionArgument()
) where
import Control.Applicative
import Control.Applicative.Free
import Control.Arrow
import Control.Monad
import Data.Char
import Data.Functor.Identity
import Data.Monoid
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Set as S
import qualified Text.Megaparsec as P
import Text.Megaparsec hiding ((<|>), many, option, optional)
import Text.Megaparsec.Char
import Text.Megaparsec.Error
import Text.Megaparsec.Text
parseConfig :: FilePath
-> Text
-> OptParser a
-> Either ConfParseError a
parseConfig path input parser = case parse (assignmentList <* eof) path input of
Left err -> Left $ SyntaxError err
Right res -> runOptionParser res parser
parseConfigFile :: FilePath
-> OptParser a
-> IO (Either ConfParseError a)
parseConfigFile path parser = do
input <- T.readFile path
return $ parseConfig path input parser
data Option a = Option
{ optParser :: Parser a
, optType :: Text
, optName :: Text
, optHelp :: Text
, optDefault :: a
, optDefaultTxt :: Text
} deriving (Functor)
type OptParser a = Ap Option a
data ConfParseError = SyntaxError (ParseError Char Dec)
| UnknownOption SourcePos Text
| TypeError (ParseError Char Dec)
deriving (Eq)
instance Show ConfParseError where
show (SyntaxError e) = parseErrorPretty e
show (UnknownOption pos key) =
show pos ++ ": Unknown option " ++ T.unpack key
show (TypeError e) = parseErrorPretty e
class OptionArgument a where
mkParser :: (Text, Parser a)
printArgument :: a -> Text
option :: OptionArgument a
=> Text
-> a
-> Text
-> OptParser a
option name def help = liftAp $ Option parser typename name help def (printArgument def)
where (typename, parser) = mkParser
customOption :: Text
-> a
-> Text
-> Text
-> Text
-> Parser a
-> OptParser a
customOption optName optDefault optDefaultTxt optHelp optType optParser = liftAp $ Option {..}
instance OptionArgument Int where
mkParser = ("integer", parseNumber)
printArgument = T.pack . show
instance OptionArgument Integer where
mkParser = ("integer", parseNumber)
printArgument = T.pack . show
instance OptionArgument String where
mkParser = ("string", many anyChar)
printArgument = quote . T.pack
instance OptionArgument Text where
mkParser = ("string", T.pack <$> many anyChar)
printArgument = quote
quote :: Text -> Text
quote x = "\"" <> escape x <> "\""
where
escape = T.replace "\"" "\\\"" . T.replace "\\" "\\\\"
runOptionParser :: [Assignment] -> OptParser a -> Either ConfParseError a
runOptionParser (a:as) parser = parseOption parser a >>= runOptionParser as
runOptionParser [] parser = Right $ parserDefault parser
parserDefault :: OptParser a -> a
parserDefault = runIdentity . runAp (Identity . optDefault)
parserExample :: OptParser a -> Text
parserExample = T.strip . runAp_ example1
where example1 a = commentify (optHelp a) <> optName a <> " = " <> optDefaultTxt a <> "\n\n"
commentify = T.unlines . map ("# " <>) . T.lines
parseOption :: OptParser a -> Assignment -> Either ConfParseError (OptParser a)
parseOption (Pure _) ass =
Left $ UnknownOption (assignmentPosition ass) (assignmentKey ass)
parseOption (Ap opt rest) ass
| optName opt == assignmentKey ass =
let content = (valueContent $ assignmentValue ass)
pos = (valuePosition $ assignmentValue ass)
in case parseWithStart (optParser opt <* eof) pos content of
Left e -> Left $ TypeError $ addErrorMessage e $
"in " ++ T.unpack (optType opt) ++ " argument for option " ++ T.unpack (assignmentKey ass)
Right res -> Right $ fmap ($ res) rest
| otherwise = fmap (Ap opt) $ parseOption rest ass
where testParse = Nothing
data Assignment = Assignment
{ assignmentPosition :: SourcePos
, assignmentKey :: Text
, assignmentValue :: AssignmentValue
} deriving (Show)
data AssignmentValue = AssignmentValue
{ valuePosition :: SourcePos
, valueContent :: Text
} deriving (Show)
assignmentList :: Parser [Assignment]
assignmentList = whitespace *> many (assignment <* whitespace)
assignment :: Parser Assignment
assignment = do
Assignment
<$> getPosition <*> key <* whitespaceNoComment
<* char '=' <* whitespaceNoComment
<*> value
key :: Parser Text
key = T.pack <$> some (alphaNumChar <|> char '_' <|> char '-')
value :: Parser AssignmentValue
value = AssignmentValue <$> getPosition <*> content <* whitespaceNoEOL <* (void eol <|> eof)
content :: Parser Text
content = escapedString
<|> bareString
bareString :: Parser Text
bareString = (T.strip . T.pack <$> some (noneOf ("#\n" :: String)))
<?> "bare string"
escapedString :: Parser Text
escapedString = (T.pack <$> (char '"' *> many escapedChar <* char '"'))
<?> "quoted string"
where escapedChar = char '\\' *> anyChar
<|> noneOf ("\"" :: String)
whitespace :: Parser ()
whitespace = skipMany $ (void $ oneOf (" \t\n" :: String)) <|> comment
whitespaceNoEOL :: Parser ()
whitespaceNoEOL = skipMany $ (void $ oneOf (" \t" :: String)) <|> comment
whitespaceNoComment :: Parser ()
whitespaceNoComment = skipMany $ oneOf (" \t" :: String)
comment :: Parser ()
comment = char '#' >> skipMany (noneOf ("\n" :: String))
parseWithStart :: (Stream s, ErrorComponent e)
=> Parsec e s a -> SourcePos -> s -> Either (ParseError (Token s) e) a
parseWithStart p pos = parse p' (sourceName pos)
where p' = do setPosition pos; p
parseNumber :: Read a => Parser a
parseNumber = read <$> ((<>) <$> (P.option "" $ string "-") <*> some digitChar)
addErrorMessage :: ParseError t Dec -> String -> ParseError t Dec
addErrorMessage e errorMsg = e { errorCustom = S.insert (DecFail errorMsg) (errorCustom e) }