module Text.Toml.Parser
( module Text.Toml.Parser
, module Text.Toml.Types
) where
import Control.Applicative hiding (many, optional, (<|>))
import Control.Monad
import Control.Monad.State (evalState)
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Void
import Text.Megaparsec.Char
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale, iso8601DateFormat,
parseTimeM)
#else
import Data.Time.Format (parseTime)
import System.Locale (defaultTimeLocale, iso8601DateFormat)
#endif
import Numeric (readHex)
import Text.Megaparsec hiding (runParser)
import Text.Toml.Types
import Prelude hiding (concat, takeWhile)
type TomlError = ParseError (Token Text) Void
parseOnly :: Parser Toml a -> Text -> Either TomlError a
parseOnly parser = flip evalState mempty . runParserT parser "noneSrc"
tomlDoc :: (TomlM m) => Parser m Table
tomlDoc = do
skipBlanks
topTable <- table
namedSections <- many namedSection
eof
foldM (flip (insert Explicit)) topTable namedSections
table :: (TomlM m) => Parser m Table
table = do
pairs <- (many (assignment <* skipBlanks) <|> (skipBlanks >> return []))
case maybeDupe (map fst pairs) of
Just k -> fail $ "Cannot redefine key " ++ unpack k
Nothing -> return $ M.fromList pairs
inlineTable :: (TomlM m) => Parser m Node
inlineTable = do
pairs <- between (char '{') (char '}') (skipSpaces *> separatedValues <* skipSpaces)
case maybeDupe (map fst pairs) of
Just k -> fail $ "Cannot redefine key " ++ (unpack k)
Nothing -> return $ VTable $ M.fromList pairs
where
skipSpaces = many (satisfy isSpc)
separatedValues = sepBy (skipSpaces *> assignment <* skipSpaces) comma
comma = skipSpaces >> char ',' >> skipSpaces
maybeDupe :: Ord a => [a] -> Maybe a
maybeDupe xx = dup xx S.empty
where
dup [] _ = Nothing
dup (x:xs) s = if S.member x s then Just x else dup xs (S.insert x s)
namedSection :: (TomlM m) => Parser m ([Text], Node)
namedSection = do
eitherHdr <- try (Left <$> tableHeader) <|> try (Right <$> tableArrayHeader)
skipBlanks
tbl <- table
skipBlanks
return $ case eitherHdr of Left ns -> (ns, VTable tbl )
Right ns -> (ns, VTArray $ V.singleton tbl)
tableHeader :: (TomlM m) => Parser m [Text]
tableHeader = between (char '[') (char ']') headerValue
tableArrayHeader :: (TomlM m) => Parser m [Text]
tableArrayHeader = between (twoChar '[') (twoChar ']') headerValue
where
twoChar c = count 2 (char c)
headerValue :: (TomlM m) => Parser m [Text]
headerValue = ((pack <$> some keyChar) <|> anyStr') `sepBy1` (char '.')
where
keyChar = alphaNumChar <|> char '_' <|> char '-'
assignment :: (TomlM m) => Parser m (Text, Node)
assignment = do
k <- (pack <$> some keyChar) <|> anyStr'
many (satisfy isSpc) >> char '=' >> skipBlanks
v <- value
return (k, v)
where
keyChar = alphaNumChar <|> char '_' <|> char '-'
value :: (TomlM m) => Parser m Node
value = (try array <?> "array")
<|> (try boolean <?> "boolean")
<|> (try anyStr <?> "string")
<|> (try datetime <?> "datetime")
<|> (try float <?> "float")
<|> (try integer <?> "integer")
<|> (try inlineTable <?> "inline table")
array :: (TomlM m) => Parser m Node
array = (try (arrayOf array) <?> "array of arrays")
<|> (try (arrayOf boolean) <?> "array of booleans")
<|> (try (arrayOf anyStr) <?> "array of strings")
<|> (try (arrayOf datetime) <?> "array of datetimes")
<|> (try (arrayOf float) <?> "array of floats")
<|> (try (arrayOf integer) <?> "array of integers")
boolean :: (TomlM m) => Parser m Node
boolean = VBoolean <$> ( (string $ "true") *> return True <|>
(string $ "false") *> return False )
anyStr :: (TomlM m) => Parser m Node
anyStr = VString <$> anyStr'
anyStr' :: (TomlM m) => Parser m Text
anyStr' = try multiBasicStr <|> try basicStr <|> try multiLiteralStr <|> try literalStr
basicStr :: (TomlM m) => Parser m Text
basicStr = between dQuote dQuote (fmap pack $ many strChar)
where
strChar = escSeq <|> noneOf ("\"\\" :: String)
dQuote = char '\"'
multiBasicStr :: (TomlM m) => Parser m Text
multiBasicStr = (openDQuote3 *> escWhiteSpc *> (pack <$> manyTill strChar (try dQuote3)))
where
openDQuote3 = try (dQuote3 <* char '\n') <|> try dQuote3
dQuote3 = count 3 $ char '"'
strChar = (escSeq <|> (satisfy (/= '\\'))) <* escWhiteSpc
escWhiteSpc = many $ char '\\' >> char '\n' >> (many $ satisfy (\c -> isSpc c || c == '\n'))
literalStr :: (TomlM m) => Parser m Text
literalStr = between sQuote sQuote (pack <$> many (satisfy (/= '\'')))
where
sQuote = char '\''
multiLiteralStr :: (TomlM m) => Parser m Text
multiLiteralStr = (openSQuote3 *> (fmap pack $ manyTill anyChar sQuote3))
where
openSQuote3 = try (sQuote3 <* char '\n') <|> try sQuote3
sQuote3 = try . count 3 . char $ '\''
datetime :: (TomlM m) => Parser m Node
datetime = do
d <- try $ manyTill anyChar (char 'Z')
#if MIN_VERSION_time(1,5,0)
let mt = parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%X") d
#else
let mt = parseTime defaultTimeLocale (iso8601DateFormat $ Just "%X") d
#endif
case mt of Just t -> return $ VDatetime t
Nothing -> fail "parsing datetime failed"
float :: (TomlM m) => Parser m Node
float = VFloat <$> do
n <- intStr <* lookAhead (oneOf (".eE" :: String))
d <- (char '.' *> uintStr) <|> return "0"
e <- (oneOf ("eE" :: String) *> intStr) <|> return "0"
return . read . join $ [n, ".", d, "e", e]
where
sign = string "-" <|> (char '+' >> return "") <|> return ""
uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar)
intStr = do s <- T.unpack <$> sign
u <- uintStr
return . join $ [s, u]
integer :: (TomlM m) => Parser m Node
integer = VInteger <$> (signed $ read <$> uintStr)
where
uintStr :: (TomlM m) => Parser m [Char]
uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar)
arrayOf :: (TomlM m) => Parser m Node -> Parser m Node
arrayOf p = (VArray . V.fromList) <$>
between (char '[') (char ']') (skipBlanks *> separatedValues)
where
separatedValues = sepEndBy (skipBlanks *> try p <* skipBlanks) comma <* skipBlanks
comma = skipBlanks >> char ',' >> skipBlanks
escSeq :: (TomlM m) => Parser m Char
escSeq = char '\\' *> escSeqChar
where
escSeqChar = (char '"') *> return '"'
<|> (char '\\') *> return '\\'
<|> (char '/') *> return '/'
<|> (char 'b') *> return '\b'
<|> (char 't') *> return '\t'
<|> (char 'n') *> return '\n'
<|> (char 'f') *> return '\f'
<|> (char 'r') *> return '\r'
<|> (char 'u') *> unicodeHex 4
<|> (char 'U') *> unicodeHex 8
<?> "escape character"
unicodeHex :: (TomlM m) => Int -> Parser m Char
unicodeHex n = do
h <- count n (satisfy isHex)
let v = fst . head . readHex $ h
return $ if v <= maxChar then toEnum v else '_'
where
isHex c = (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
maxChar = fromEnum (maxBound :: Char)
signed :: (Num a, TomlM m) => Parser m a -> Parser m a
signed p = (negate <$> (char '-' *> p))
<|> (char '+' *> p)
<|> p
skipBlanks :: (TomlM m) => Parser m ()
skipBlanks = skipMany blank
where
blank = try ((some $ satisfy isSpc) >> return ()) <|> comment <|> (void eol)
comment = char '#' >> (many $ (noneOf ("\n" :: String))) >> return ()
isSpc :: Char -> Bool
isSpc ' ' = True
isSpc '\t' = True
isSpc _ = False