module Text.Toml.Parser
( module Text.Toml.Parser
, module Text.Toml.Types
) where
import Control.Applicative hiding (many, optional, some, (<|>))
import Control.Monad
import Control.Monad.State (evalState)
import qualified Data.HashMap.Lazy 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.CharRW
#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 >> pure [])
case maybeDupe (map fst pairs) of
Just k -> throwParser $ "Cannot redefine key '" ++ unpack k ++ "'"
Nothing -> return $ M.fromList pairs
inlineTable :: (TomlM m) => Parser m (Either (S.Set (ErrorFancy Void)) Node)
inlineTable = do
pairs <- between (char '{') (char '}') (skipSpaces *> separatedValues <* skipSpaces)
case maybeDupe (map fst pairs) of
Just k ->
pure $ Left (S.fromList [ErrorFail $ "Cannot redefine key " ++ unpack k ])
Nothing -> pure $ Right $ 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) <|> (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 (string "[[") (string "]]") headerValue
headerValue :: (TomlM m) => Parser m [Text]
headerValue = ((pack <$> some keyChar) <|> anyStr') `sepBy1` char '.'
where
keyChar = alphaNumChar <|> oneOf ("-_" :: String)
assignment :: (TomlM m) => Parser m (Text, Node)
assignment = do
k <- (pack <$> some keyChar) <|> anyStr'
many (satisfy isSpc) >> char '=' >> skipBlanks
v' <- value
v <- case v' of
Right x -> pure x
Left y -> fancyFailure y
return (k, v)
where
keyChar = alphaNumChar <|> oneOf ("-_" :: String)
value :: (TomlM m) => Parser m (Either (S.Set (ErrorFancy Void)) Node)
value = (pure <$> try array <?> "array")
<|> (pure <$> try boolean <?> "boolean")
<|> (pure <$> try anyStr <?> "string")
<|> (pure <$> try datetime <?> "datetime")
<|> (pure <$> try float <?> "float")
<|> (pure <$> try integer <?> "integer")
<|> (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")
<|> (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 <|> literalStr
basicStr :: (TomlM m) => Parser m Text
basicStr = between dQuote dQuote (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') <|> dQuote3
dQuote3 = count 3 $ char '"'
strChar = escSeq <|> noneOf ("\\" :: String) <* escWhiteSpc
escWhiteSpc = many $ char '\\' >> char '\n' >> many (oneOf ("\n\t " :: String))
literalStr :: (TomlM m) => Parser m Text
literalStr = between sQuote sQuote (pack <$> many (noneOf ("'" :: String)))
where
sQuote = char '\''
multiLiteralStr :: (TomlM m) => Parser m Text
multiLiteralStr = openSQuote3 *> (pack <$> manyTill anyChar sQuote3)
where
openSQuote3 = try (sQuote3 <* char '\n') <|> sQuote3
sQuote3 = try . count 3 . char $ '\''
datetime :: (TomlM m) => Parser m Node
datetime = do
d <- 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 -> throwParser "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 = (T.singleton <$> char '-') <|> (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 String
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 '"'
<|> char '\\'
<|> char '/'
<|> char 'n' *> return '\n'
<|> char 't' *> return '\t'
<|> char 'r' *> return '\r'
<|> char 'b' *> return '\b'
<|> char 'f' *> return '\f'
<|> char 'u' *> unicodeHex 4
<|> char 'U' *> unicodeHex 8
<?> "escaped character"
unicodeHex :: (TomlM m) => Int -> Parser m Char
unicodeHex n = do
h <- count n hexDigitChar
let v = fst . head . readHex $ h
return $ if v <= maxChar then toEnum v else '�'
where
maxChar = fromEnum (maxBound :: Char)
signed :: (Num a, TomlM m) => Parser m a -> Parser m a
signed p = p
<|> (negate <$> (char '-' *> p))
<|> (char '+' *> p)
skipBlanks :: (TomlM m) => Parser m ()
skipBlanks = skipMany blank
where
blank = void (some (satisfy isSpc)) <|> comment <|> void eol
comment = char '#' >> void (many $ noneOf ("\n" :: String))
isSpc :: Char -> Bool
isSpc ' ' = True
isSpc '\t' = True
isSpc _ = False