{-# LANGUAGE TypeFamilies #-}
module Text.GitConfig.Parser (
Parser,
Section(..),
GitConfig,
spaceConsumer,
lexeme,
symbol,
brackets,
quotes,
escSeq,
sectionName,
sectionHeader,
variableName,
variableValue,
mapping,
section,
config,
parseConfig
) where
import Control.Applicative (empty)
import Control.Monad (void)
import Data.Functor (($>))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import Text.Megaparsec (ParseErrorBundle, Parsec, between,
eof, many, parse, satisfy, sepBy, some,
(<?>), (<|>))
import Text.Megaparsec.Char (alphaNumChar, char, eol,
letterChar, printChar,
space1)
import qualified Text.Megaparsec.Char.Lexer as Lexer
type GitConfigError = ParseErrorBundle Text Void
type Parser = Parsec Void Text
data Section = Section [Text] (HashMap Text Text)
deriving (Eq, Show)
type GitConfig = [Section]
spaceConsumer :: Parser ()
spaceConsumer = Lexer.space space1 lineComment empty
where lineComment = Lexer.skipLineComment "#" <|> Lexer.skipLineComment ";"
lexeme :: Parser a -> Parser a
lexeme = Lexer.lexeme spaceConsumer
symbol :: Text -> Parser Text
symbol = Lexer.symbol spaceConsumer
brackets :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
quotes :: Parser a -> Parser a
quotes = between (symbol "\"") (symbol "\"")
escSeq :: Parser Char
escSeq = char '\\' *> escSeqChar
where
escSeqChar = char '"'
<|> char '\\'
<|> char '/'
<|> (char 'n' $> '\n')
<|> (char 't' $> '\t')
<|> (char 'r' $> '\r')
<|> (char 'b' $> '\b')
<|> (char 'f' $> '\f')
<?> "escaped character"
sectionName :: Parser [Text]
sectionName = (section <|> subSection) `sepBy` spaceConsumer
where
sectionChar = alphaNumChar <|> char '.' <|> char '-'
section = fmap T.pack . some $ sectionChar
subSection = fmap T.pack . quotes . many $
escSeq <|> satisfy (\x -> x `notElem` ['"', '\\'])
sectionHeader :: Parser [Text]
sectionHeader = brackets sectionName
variableName :: Parser Text
variableName = fmap (T.toLower . T.pack) . lexeme $ p
where
p = (:) <$> letterChar <*> many (alphaNumChar <|> char '-')
variableValue :: Parser Text
variableValue = T.pack <$> between spaceConsumer eol (many printChar)
mapping :: Parser (Text, Text)
mapping = do
varName <- variableName
varValue <- do void (symbol "=")
variableValue <|> pure ""
<|> pure "true"
return (varName, varValue)
section :: Parser Section
section = do
header <- sectionHeader
void spaceConsumer
sectionValues <- mapping `sepBy` spaceConsumer
return $ Section header (M.fromList sectionValues)
config :: Parser GitConfig
config = between spaceConsumer eof $ many section
parseConfig :: Text -> Either GitConfigError GitConfig
parseConfig = parse config "noSrc"