module Text.Toml.Parser
( module Text.Toml.Parser
, module Text.Toml.Types
) where
import Prelude hiding (concat, takeWhile)
import Control.Applicative hiding (many, optional, (<|>))
import qualified Data.HashMap.Strict as M
import qualified Data.List as L
import qualified Data.Set as S
import Data.Text (Text, concat, pack, unpack)
import Data.Time.Format (parseTime)
import Numeric (readHex)
import System.Locale (defaultTimeLocale, iso8601DateFormat)
import Text.Parsec
import Text.Parsec.Text
import Text.Toml.Types
parseOnly :: Parser a -> Text -> Either ParseError a
parseOnly p str = parse (p <* eof) "test" str
tomlDoc :: Parser Table
tomlDoc = do
skipBlanks
topTable <- table
namedSections <- many namedSection
eof
case join topTable (reverse namedSections) of
Left msg -> fail (unpack msg)
Right r -> return $ r
where
join tbl [] = Right tbl
join tbl (x:xs) = case join tbl xs of Left msg -> Left msg
Right r -> insert x r
table :: Parser Table
table = do
pairs <- try (many (assignment <* skipBlanks)) <|> (try skipBlanks >> return [])
case hasDup (map fst pairs) of
Just k -> fail $ "Cannot redefine key " ++ (unpack k)
Nothing -> return $ M.fromList (map (\(k, v) -> (k, NTValue v)) pairs)
where
hasDup :: Ord a => [a] -> Maybe a
hasDup xs = dup' xs S.empty
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, NTable tbl )
Right ns -> (ns, NTArray [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 headerNameChar) `sepBy1` (char '.')
where
headerNameChar = satisfy (\c -> c /= ' ' && c /= '\t' && c /= '\n' &&
c /= '[' && c /= ']' && c /= '.' && c /= '#')
assignment :: Parser (Text, TValue)
assignment = do
k <- pack <$> many1 keyChar
skipBlanks >> char '=' >> skipBlanks
v <- value
return (k, v)
where
keyChar = satisfy (\c -> c /= ' ' && c /= '\t' && c /= '\n' &&
c /= '=' && c /= '#' && c /= '[')
value :: Parser TValue
value = (try array <?> "array")
<|> (try boolean <?> "boolean")
<|> (try anyStr <?> "string")
<|> (try datetime <?> "datetime")
<|> (try float <?> "float")
<|> (try integer <?> "integer")
array :: Parser TValue
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 TValue
boolean = VBoolean <$> ( (try . string $ "true") *> return True <|>
(try . string $ "false") *> return False )
anyStr :: Parser TValue
anyStr = try multiBasicStr <|> try basicStr <|> try multiLiteralStr <|> try literalStr
basicStr :: Parser TValue
basicStr = VString <$> between dQuote dQuote (fmap pack $ many strChar)
where
strChar = try escSeq <|> try (satisfy (\c -> c /= '"' && c /= '\\'))
dQuote = char '\"'
multiBasicStr :: Parser TValue
multiBasicStr = VString <$> (openDQuote3 *> (fmap pack $ manyTill strChar dQuote3))
where
openDQuote3 = try (dQuote3 <* char '\n') <|> try dQuote3
dQuote3 = count 3 $ char '"'
strChar = escWhiteSpc *> (escSeq <|> (satisfy (/= '\\'))) <* escWhiteSpc
escWhiteSpc = many $ char '\\' >> char '\n' >> (many $ satisfy (\c -> isSpc c || c == '\n'))
literalStr :: Parser TValue
literalStr = VString <$> between sQuote sQuote (pack <$> many (satisfy (/= '\'')))
where
sQuote = char '\''
multiLiteralStr :: Parser TValue
multiLiteralStr = VString <$> (openSQuote3 *> (fmap pack $ manyTill anyChar sQuote3))
where
openSQuote3 = try (sQuote3 <* char '\n') <|> try sQuote3
sQuote3 = try . count 3 . char $ '\''
datetime :: Parser TValue
datetime = do
d <- manyTill anyChar (try $ char 'Z')
let mt = parseTime defaultTimeLocale (iso8601DateFormat $ Just "%X") d
case mt of Just t -> return $ VDatetime t
Nothing -> fail "parsing datetime failed"
float :: Parser TValue
float = VFloat <$> do
n <- intStr
char '.'
d <- uintStr
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 = many1 digit
intStr = do s <- sign
u <- uintStr
return . L.concat $ [s, u]
integer :: Parser TValue
integer = VInteger <$> (signed $ read <$> (many1 digit))
arrayOf :: Parser TValue -> Parser TValue
arrayOf p = VArray <$> between (char '[') (char ']') (skipBlanks *> separatedValues)
where
separatedValues = sepEndBy (skipBlanks *> 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 = satisfy (\c -> c == '\n' || c == '\r') >> return ()