String.hs

{- |
Module                  : Toml.Parser.String
Copyright               : (c) 2018-2021 Kowainik
SPDX-License-Identifier : MPL-2.0
Maintainer              : Kowainik <xrom.xkov@gmail.com>
Stability               : Stable
Portability             : Portable

Parsers for strings in TOML format, including basic and literal strings
both singleline and multiline.
-}

module Toml.Parser.String
       ( textP
       , basicStringP
       , literalStringP
       ) where

import Control.Applicative (Alternative (..))
import Control.Applicative.Combinators (count, manyTill, optional)
import Data.Char (chr, isControl)
import Data.Text (Text)

import Toml.Parser.Core (Parser, anySingle, char, eol, hexDigitChar, lexeme, satisfy, space, string,
                         tab, try, (<?>))

import qualified Data.Text as Text


{- | Parser for TOML text. Includes:

1. Basic single-line string.
2. Literal single-line string.
3. Basic multiline string.
4. Literal multiline string.
-}
textP :: Parser Text
textP = (multilineBasicStringP   <?> "multiline basic string")
    <|> (multilineLiteralStringP <?> "multiline literal string")
    <|> (literalStringP          <?> "literal string")
    <|> (basicStringP            <?> "basic string")
    <?> "text"

{- | Parse a non-control character (control character is a non-printing
character of the Latin-1 subset of Unicode).
-}
nonControlCharP :: Parser Text
nonControlCharP = Text.singleton <$> satisfy (not . isControl) <?> "non-control char"

-- | Parse escape sequences inside basic strings.
escapeSequenceP :: Parser Text
escapeSequenceP = char '\\' *> anySingle >>= \case
    'b'  -> pure "\b"
    't'  -> pure "\t"
    'n'  -> pure "\n"
    'f'  -> pure "\f"
    'r'  -> pure "\r"
    '"'  -> pure "\""
    '\\' -> pure "\\"
    'u'  -> hexUnicodeP 4
    'U'  -> hexUnicodeP 8
    c    -> fail $ "Invalid escape sequence: " <> "\\" <> [c]
  where
    hexUnicodeP :: Int -> Parser Text
    hexUnicodeP n = count n hexDigitChar >>= \x -> case toUnicode $ hexToInt x of
        Just c  -> pure (Text.singleton c)
        Nothing -> fail $ "Invalid unicode character: \\"
            <> (if n == 4 then "u" else "U")
            <> x
      where
        hexToInt :: String -> Int
        hexToInt xs = read $ "0x" ++ xs

        toUnicode :: Int -> Maybe Char
        toUnicode x
            -- Ranges from "The Unicode Standard".
            -- See definition D76 in Section 3.9, Unicode Encoding Forms.
            | x >= 0      && x <= 0xD7FF   = Just (chr x)
            | x >= 0xE000 && x <= 0x10FFFF = Just (chr x)
            | otherwise                    = Nothing

-- | Parser for basic string in double quotes.
basicStringP :: Parser Text
basicStringP = lexeme $ mconcat <$> (char '"' *> charP `manyTill` char '"')
  where
    charP :: Parser Text
    charP = escapeSequenceP <|> nonControlCharP

-- | Parser for literal string in single quotes.
literalStringP :: Parser Text
literalStringP = lexeme $ Text.pack <$> (char '\'' *> nonEolCharP `manyTill` char '\'')
  where
    nonEolCharP :: Parser Char
    nonEolCharP = satisfy (\c -> c /= '\n' && c /= '\r')

-- | Generic parser for multiline string. Used in 'multilineBasicStringP' and
-- 'multilineLiteralStringP'.
multilineP :: Parser Text -> Parser Text -> Parser Text
multilineP quotesP allowedCharP = lexeme $ mconcat <$>
    (quotesP *> optional eol *> allowedCharP `manyTill` quotesP)

-- Parser for basic multiline string in """ quotes.
multilineBasicStringP :: Parser Text
multilineBasicStringP = multilineP quotesP allowedCharP
  where
    quotesP :: Parser Text
    quotesP = string "\"\"\""

    allowedCharP :: Parser Text
    allowedCharP = lineEndingBackslashP <|> escapeSequenceP <|> nonControlCharP <|> eol

    lineEndingBackslashP :: Parser Text
    lineEndingBackslashP = Text.empty <$ try (char '\\' >> eol >> space)

-- Parser for literal multiline string in ''' quotes.
multilineLiteralStringP :: Parser Text
multilineLiteralStringP = multilineP quotesP allowedCharP
  where
    quotesP :: Parser Text
    quotesP = string "'''"

    allowedCharP :: Parser Text
    allowedCharP = nonControlCharP <|> eol <|> Text.singleton <$> tab