module Text.Toml.Parser
( module Text.Toml.Parser
, module Text.Toml.Types
) where
import Control.Applicative hiding (many, optional, (<|>))
import Control.Monad
import qualified Data.HashMap.Strict as M
import qualified Data.List as L
import qualified Data.Set as S
import Data.Text (Text, pack, unpack)
import qualified Data.Vector as V
#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.Parsec
import Text.Toml.Types
import Prelude hiding (concat, takeWhile)
type Parser a = forall s. Parsec Text s a
parseOnly :: Parsec Text (S.Set [Text]) a -> Text -> Either ParseError a
parseOnly p str = runParser (p <* eof) S.empty "test" str
tomlDoc :: Parsec Text (S.Set [Text]) Table
tomlDoc = do
skipBlanks
topTable <- table
namedSections <- many namedSection
eof
foldM (flip (insert Explicit)) topTable namedSections
table :: Parser Table
table = do
pairs <- try (many (assignment <* skipBlanks)) <|> (try skipBlanks >> return [])
case maybeDupe (map fst pairs) of
Just k -> fail $ "Cannot redefine key " ++ (unpack k)
Nothing -> return $ M.fromList pairs
inlineTable :: Parser 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 :: Parser ([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 :: Parser [Text]
tableHeader = between (char '[') (char ']') headerValue
tableArrayHeader :: Parser [Text]
tableArrayHeader = between (twoChar '[') (twoChar ']') headerValue
where
twoChar c = count 2 (char c)
headerValue :: Parser [Text]
headerValue = ((pack <$> many1 keyChar) <|> anyStr') `sepBy1` (char '.')
where
keyChar = alphaNum <|> char '_' <|> char '-'
assignment :: Parser (Text, Node)
assignment = do
k <- (pack <$> many1 keyChar) <|> anyStr'
many (satisfy isSpc) >> char '=' >> skipBlanks
v <- value
return (k, v)
where
keyChar = alphaNum <|> char '_' <|> char '-'
value :: Parser 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 :: Parser 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 :: Parser Node
boolean = VBoolean <$> ( (try . string $ "true") *> return True <|>
(try . string $ "false") *> return False )
anyStr :: Parser Node
anyStr = VString <$> anyStr'
anyStr' :: Parser Text
anyStr' = try multiBasicStr <|> try basicStr <|> try multiLiteralStr <|> try literalStr
basicStr :: Parser Text
basicStr = between dQuote dQuote (fmap pack $ many strChar)
where
strChar = try escSeq <|> try (satisfy (\c -> c /= '"' && c /= '\\'))
dQuote = char '\"'
multiBasicStr :: Parser 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 :: Parser Text
literalStr = between sQuote sQuote (pack <$> many (satisfy (/= '\'')))
where
sQuote = char '\''
multiLiteralStr :: Parser Text
multiLiteralStr = (openSQuote3 *> (fmap pack $ manyTill anyChar sQuote3))
where
openSQuote3 = try (sQuote3 <* char '\n') <|> try sQuote3
sQuote3 = try . count 3 . char $ '\''
datetime :: Parser 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 :: Parser Node
float = VFloat <$> do
n <- intStr <* lookAhead (satisfy (\c -> c == '.' || c == 'e' || c == 'E'))
d <- try (satisfy (== '.') *> uintStr) <|> return "0"
e <- try (satisfy (\c -> c == 'e' || c == 'E') *> intStr) <|> return "0"
return . read . L.concat $ [n, ".", d, "e", e]
where
sign = try (string "-") <|> (try (char '+') >> return "") <|> return ""
uintStr = (:) <$> digit <*> many (optional (char '_') *> digit)
intStr = do s <- sign
u <- uintStr
return . L.concat $ [s, u]
integer :: Parser Node
integer = VInteger <$> (signed $ read <$> uintStr)
where
uintStr :: Parser [Char]
uintStr = (:) <$> digit <*> many (optional (char '_') *> digit)
arrayOf :: Parser Node -> Parser 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 :: Parser Char
escSeq = char '\\' *> escSeqChar
where
escSeqChar = try (char '"') *> return '"'
<|> try (char '\\') *> return '\\'
<|> try (char '/') *> return '/'
<|> try (char 'b') *> return '\b'
<|> try (char 't') *> return '\t'
<|> try (char 'n') *> return '\n'
<|> try (char 'f') *> return '\f'
<|> try (char 'r') *> return '\r'
<|> try (char 'u') *> unicodeHex 4
<|> try (char 'U') *> unicodeHex 8
<?> "escape character"
unicodeHex :: Int -> Parser 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 => Parser a -> Parser a
signed p = try (negate <$> (char '-' *> p))
<|> try (char '+' *> p)
<|> try p
skipBlanks :: Parser ()
skipBlanks = skipMany blank
where
blank = try ((many1 $ satisfy isSpc) >> return ()) <|> try comment <|> try eol
comment = char '#' >> (many $ satisfy (/= '\n')) >> return ()
isSpc :: Char -> Bool
isSpc c = c == ' ' || c == '\t'
eol :: Parser ()
eol = (string "\n" <|> string "\r\n") >> return ()