<commit_before>{-# LANGUAGE OverloadedStrings #-}

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, 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



-- | Convenience function for the test suite and GHCI.
parseOnly :: Parser a -> Text -> Either ParseError a
parseOnly p str = parse (p <* eof) "test" str


-- | Parses a complete document formatted according to the TOML spec.
tomlDoc :: Parser Table
tomlDoc = do
    skipBlanks
    topTable <- table
    namedSections <- many namedSection
    eof  -- ensures input is completely consumed
    case join topTable (reverse namedSections) of
      Left msg -> fail (unpack msg)  -- TODO: allow Text in Parse Errors
      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


-- | Parses a table of key-value pairs.
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)


-- | Parses a 'Table' or 'TableArray' with its header.
-- The resulting tuple has the header's value in the first position, and the
-- 'NTable' or 'NTArray' in the second.
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])


-- | Parses a table header.
tableHeader :: Parser [Text]
tableHeader = between (char '[') (char ']') headerValue


-- | Parses a table array header.
tableArrayHeader :: Parser [Text]
tableArrayHeader = between (twoChar  '[') (twoChar ']') headerValue
  where
    twoChar c = count 2 (char c)


-- | Parses the value of any header (names separated by dots), into a list of 'Text'.
headerValue :: Parser [Text]
headerValue = (pack <$> many1 headerNameChar) `sepBy1` (char '.')
  where
    headerNameChar = satisfy (\c -> c /= ' ' && c /= '\t' && c /= '\n' &&
                                    c /= '[' && c /= ']'  && c /= '.'  && c /= '#')


-- | Parses a key-value assignment.
assignment :: Parser (Text, TValue)
assignment = do
    k <- pack <$> many1 keyChar
    skipBlanks >> char '=' >> skipBlanks
    v <- value
    return (k, v)
  where
    -- TODO: Follow the spec, e.g.: only first char cannot be '['.
    keyChar = satisfy (\c -> c /= ' ' && c /= '\t' && c /= '\n' &&
                             c /= '=' && c /= '#'  && c /= '[')


-- | Parses a value.
value :: Parser TValue
value = (try array    <?> "array")
    <|> (try boolean  <?> "boolean")
    <|> (try anyStr   <?> "string")
    <|> (try datetime <?> "datetime")
    <|> (try float    <?> "float")
    <|> (try integer  <?> "integer")


--
-- | * Toml value parsers
--

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
    -- | Parse the a tripple-double quote, with possibly a newline attached
    openDQuote3 = try (dQuote3 <* char '\n') <|> try dQuote3
    -- | Parse tripple-double quotes
    dQuote3     = count 3 $ char '"'
    -- | Parse a string char, accepting escaped codes, ignoring escaped white space
    strChar     = escWhiteSpc *> (escSeq <|> (satisfy (/= '\\'))) <* escWhiteSpc
    -- | Parse escaped white space, if any
    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
    -- | Parse the a tripple-single quote, with possibly a newline attached
    openSQuote3 = try (sQuote3 <* char '\n') <|> try sQuote3
    -- | Parse tripple-single quotes
    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"


-- | Attoparsec 'double' parses scientific "e" notation; reimplement according to Toml spec.
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))<commit_msg>Fix for GHC 7.10 and for the update of time lib<commit_after>{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

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, pack, unpack)
import           Data.Time.Format    (defaultTimeLocale, iso8601DateFormat,
                                      parseTimeM)
import           Numeric             (readHex)
import           Text.Parsec
import           Text.Parsec.Text

import           Text.Toml.Types



-- | Convenience function for the test suite and GHCI.
parseOnly :: Parser a -> Text -> Either ParseError a
parseOnly p str = parse (p <* eof) "test" str


-- | Parses a complete document formatted according to the TOML spec.
tomlDoc :: Parser Table
tomlDoc = do
    skipBlanks
    topTable <- table
    namedSections <- many namedSection
    eof  -- ensures input is completely consumed
    case join topTable (reverse namedSections) of
      Left msg -> fail (unpack msg)  -- TODO: allow Text in Parse Errors
      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


-- | Parses a table of key-value pairs.
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)


-- | Parses a 'Table' or 'TableArray' with its header.
-- The resulting tuple has the header's value in the first position, and the
-- 'NTable' or 'NTArray' in the second.
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])


-- | Parses a table header.
tableHeader :: Parser [Text]
tableHeader = between (char '[') (char ']') headerValue


-- | Parses a table array header.
tableArrayHeader :: Parser [Text]
tableArrayHeader = between (twoChar '[') (twoChar ']') headerValue
  where
    twoChar c = count 2 (char c)


-- | Parses the value of any header (names separated by dots), into a list of 'Text'.
headerValue :: Parser [Text]
headerValue = (pack <$> many1 headerNameChar) `sepBy1` (char '.')
  where
    headerNameChar = satisfy (\c -> c /= ' ' && c /= '\t' && c /= '\n' &&
                                    c /= '[' && c /= ']'  && c /= '.'  && c /= '#')


-- | Parses a key-value assignment.
assignment :: Parser (Text, TValue)
assignment = do
    k <- pack <$> many1 keyChar
    skipBlanks >> char '=' >> skipBlanks
    v <- value
    return (k, v)
  where
    -- TODO: Follow the spec, e.g.: only first char cannot be '['.
    keyChar = satisfy (\c -> c /= ' ' && c /= '\t' && c /= '\n' &&
                             c /= '=' && c /= '#'  && c /= '[')


-- | Parses a value.
value :: Parser TValue
value = (try array    <?> "array")
    <|> (try boolean  <?> "boolean")
    <|> (try anyStr   <?> "string")
    <|> (try datetime <?> "datetime")
    <|> (try float    <?> "float")
    <|> (try integer  <?> "integer")


--
-- | * Toml value parsers
--

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
    -- | Parse the a tripple-double quote, with possibly a newline attached
    openDQuote3 = try (dQuote3 <* char '\n') <|> try dQuote3
    -- | Parse tripple-double quotes
    dQuote3     = count 3 $ char '"'
    -- | Parse a string char, accepting escaped codes, ignoring escaped white space
    strChar     = escWhiteSpc *> (escSeq <|> (satisfy (/= '\\'))) <* escWhiteSpc
    -- | Parse escaped white space, if any
    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
    -- | Parse the a tripple-single quote, with possibly a newline attached
    openSQuote3 = try (sQuote3 <* char '\n') <|> try sQuote3
    -- | Parse tripple-single quotes
    sQuote3     = try . count 3 . char $ '\''


datetime :: Parser TValue
datetime = do
    d <- manyTill anyChar (try $ char 'Z')
    let  mt = parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%X") d
    case mt of Just t  -> return $ VDatetime t
               Nothing -> fail "parsing datetime failed"


-- | Attoparsec 'double' parses scientific "e" notation; reimplement according to Toml spec.
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))
{'fraction_non_alphanumeric': 0.14496754457957173, 'fraction_numerical': 0.004551219876147131, 'mean_word_length': 2.311264822134387, 'pattern_counts': {'":': 0, '<': 139, '<?xml version=': 0, '>': 177, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 9, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3184362', 'n_tokens_mistral': 4492, 'n_tokens_neox': 4274, 'n_words': 1482}