Parser.hs

{- HLINT ignore "Use <$>" -}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Language.Fluent.Parser (module Language.Fluent.Parser, Parser) where

import Control.Applicative (optional)
import Control.Exception (displayException)
import Control.Monad (replicateM, unless, void, when)
import Control.Monad.Extra (ifM, notM, unlessM, whenMaybeM, (&&^))
import Data.Attoparsec.Combinator (lookAhead)
import Data.Attoparsec.Extra
import Data.Attoparsec.Internal.Types (Pos (Pos))
import Data.Attoparsec.Text
    ( Parser
    , atEnd
    , endOfInput
    , match
    , parseOnly
    , peekChar
    , take
    , takeText
    , takeWhile
    )
import Data.Bifunctor (first)
import Data.Char (chr, isAsciiLower, isAsciiUpper, isDigit, isHexDigit)
import Data.Either (isLeft, isRight)
import Data.Foldable (toList)
import Data.List qualified as List
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Unsafe (takeWord8)
import Language.Fluent.AST
import Language.Fluent.Parser.Location qualified as Location
import Language.Fluent.Parser.Whitespace
import Numeric (readHex)
import Prelude hiding (take, takeWhile)

parse :: Parser a -> Text -> Either String a
parse p = parseOnly $ p <* endOfInput

parseNamed :: String -> Parser a -> Text -> Either String a
parseNamed name p t = first (const $ "Invalid " <> name <> ": " <> show t) $ parse p t

parseIdentifier :: Text -> Either String Identifier
parseIdentifier = parseNamed "identifier" identifier

-- | Parses an FTL file that must have no syntax errors. Fails with a line for each error.
parseResource :: Text -> Either String Resource
parseResource =
    first (List.intercalate "\n" . fmap displayException . toList)
        . rejectJunk
        . parseResourceLenient

-- | Parses an FTL file whatever is in it. An entry with a syntax error is a 'JunkEntry'.
parseResourceLenient :: Text -> Resource
parseResourceLenient text = case parse resource text of
    Right resource -> resource
    Left reason -> Resource [JunkEntry text ParseError{offset = 0, line = 1, column = 1, reason}]

-- | Fails with the syntax errors of a 'Resource'.
rejectJunk :: Resource -> Either (NonEmpty ParseError) Resource
rejectJunk resource@Resource{entries} =
    maybe (Right resource) Left $ nonEmpty [e | JunkEntry _ e <- entries]

resource :: Parser Resource
resource = do
    start <- position
    whole <- lookAhead takeText
    void skipBlankBlockToEnd
    entries <- whileJust . whenMaybeM (notM atEnd) $ (,) <$> entryOrJunk <*> skipBlankBlockToEnd
    pure . Resource . Location.locate start whole $ attachComments entries

-- | Attaches a comment to the message or term that follows it without a blank line.
attachComments :: [(Entry, Int)] -> [Entry]
attachComments [] = []
attachComments ((CommentEntry comment, 0) : (next, _) : rest) = attach comment next <> attachComments rest
  where
    attach :: Comment -> Entry -> [Entry]
    attach attached (MessageEntry Message{..}) =
        [MessageEntry Message{comment = Just attached, ..}]
    attach attached (TermEntry Term{..}) = [TermEntry Term{comment = Just attached, ..}]
    attach attached other = [CommentEntry attached, other]
attachComments ((entry, _) : rest) = entry : attachComments rest

-- | An entry, or the junk up to the next line that could begin one.
entryOrJunk :: Parser Entry
entryOrJunk = do
    start <- position
    observing (entry <* expectLineEnd) >>= \case
        Right entry -> pure entry
        Left (failedAt, reason) -> do
            rest <- lookAhead takeText
            let Pos failure = failedAt - start
            (junk, ()) <- match $ skipToNextEntryStart failure
            end <- position
            let reported
                    | "Expected" `List.isPrefixOf` reason = Location.settle rest failure
                    | otherwise = failure
                Pos offset = min (start + Pos reported) end
            pure $ JunkEntry junk ParseError{offset, line = 0, column = 0, reason}

-- | Skips to the next line that begins like an entry, from the line of the given byte offset.
skipToNextEntryStart :: Int -> Parser ()
skipToNextEntryStart failed = do
    rest <- lookAhead takeText
    let through = Text.take (Text.length (takeWord8 failed rest) + 1) rest
    void . take . max 0 $ Text.length (fst $ Text.breakOnEnd "\n" through) - 1
    skipLines
  where
    skipLines :: Parser ()
    skipLines = do
        void $ takeWhile (/= '\n')
        unlessM atEnd $ advance *> unlessM (all beginsEntry <$> peekChar) skipLines

    beginsEntry :: Char -> Bool
    beginsEntry c = isAsciiLetter c || c == '-' || c == '#'

entry :: Parser Entry
entry =
    peekChar >>= \case
        Just '#' -> commented
        Just '-' -> TermEntry <$> term
        Just c | isAsciiLetter c -> MessageEntry <$> message
        _ -> parseError "Expected an entry start"

isAsciiLetter :: Char -> Bool
isAsciiLetter c = isAsciiLower c || isAsciiUpper c

commented :: Parser Entry
commented = do
    (level, text) <- commentBlock
    let comment = Comment text
    pure case level of
        1 -> CommentEntry comment
        2 -> GroupCommentEntry comment
        _ -> ResourceCommentEntry comment

-- | A run of adjacent comment lines of the same level, joined by line breaks.
commentBlock :: Parser (Int, Text)
commentBlock = do
    (level, first) <- commentLine
    rest <-
        whileJust . whenMaybeM (isContinuation level) $ expectLineEnd *> (snd <$> commentLine)
    pure (level, Text.intercalate "\n" (first : rest))
  where
    isContinuation :: Int -> Parser Bool
    isContinuation level =
        lookAhead $
            atLineEnd
                &&^ (consumeNewline *> ((level ==) <$> hashes (level + 1)) &&^ endsMarker)

    endsMarker :: Parser Bool
    endsMarker =
        peekChar >>= \case
            Nothing -> pure True
            Just ' ' -> pure True
            Just '\n' -> pure True
            Just '\r' -> secondIs '\n'
            _ -> pure False

-- | Consumes up to @limit@ number signs, and counts them.
hashes :: Int -> Parser Int
hashes limit = go 0
  where
    go :: Int -> Parser Int
    go n
        | n >= limit = pure n
        | otherwise = ifM (nextIs '#') (advance *> go (n + 1)) $ pure n

commentLine :: Parser (Int, Text)
commentLine = do
    level <- hashes 3
    content <- ifM atLineEnd (pure Text.empty) $ expectChar ' ' *> lineText
    pure (level, content)

lineText :: Parser Text
lineText = do
    text <- takeWhile (/= '\n')
    end <- peekChar
    pure if end == Just '\n' then fromMaybe text $ Text.stripSuffix "\r" text else text

message :: Parser Message
message = do
    id <- identifier
    skipBlankInline
    expectChar '='
    afterEquals <- position
    skipBlankInline
    value <- maybePattern
    attributes <- getAttributes
    unless (isJust value || not (null attributes)) $
        failAt afterEquals "Expected message to have a value or attributes"
    pure Message{id, value, attributes, comment = Nothing}

term :: Parser Term
term = do
    expectChar '-'
    id <- identifier
    skipBlankInline
    expectChar '='
    skipBlankInline
    value <- required "Expected term to have a value" maybePattern
    attributes <- getAttributes
    pure Term{id, value, attributes, comment = Nothing}

getAttributes :: Parser [Attribute]
getAttributes = whileJust $ optional attribute

-- | An attribute on a line of its own. A malformed one ends the attributes of its message.
attribute :: Parser Attribute
attribute = do
    unlessM atLineEnd $ parseError "Expected a line end before an attribute"
    expectLineEnd
    skipBlank
    expectChar '.'
    key <- identifier
    skipBlankInline
    expectChar '='
    skipBlankInline
    value <- required "Expected value" maybePattern
    pure $ Attribute key value

-- | The pattern of a value, which can start on the line of the value or on a line of its own.
maybePattern :: Parser (Maybe Pattern)
maybePattern =
    ifM (notM atLineEnd) (Just <$> pattern) $ whenMaybeM (lookAhead blockStart) pattern
  where
    blockStart :: Parser Bool
    blockStart =
        expectLineEnd *> skipBlankBlock *> (startsBlock <$> takeWhile (== ' ') <*> peekChar)

    startsBlock :: Text -> Maybe Char -> Bool
    startsBlock _ (Just '{') = True
    startsBlock indent (Just c) = isIndentedChar c && not (Text.null indent)
    startsBlock _ Nothing = False

pattern :: Parser Pattern
pattern =
    patternElements
        >>= maybe (parseError "Expected a value") (pure . Pattern) . NonEmpty.nonEmpty . dedent

patternElements :: Parser [PatternElement]
patternElements = whileJust patternElement

patternElement :: Parser (Maybe PatternElement)
patternElement =
    peekChar >>= \case
        Just '{' -> Just . Placeable . InlinePlaceable <$> inlinePlaceable
        Just '}' -> parseError "Unbalanced closing brace in a text element"
        Nothing -> pure Nothing
        Just _ -> ifM atLineEnd blockContinuation $ Just . InlineText <$> inlineText

-- | The block text or block placeable after a line break, if there is one.
blockContinuation :: Parser (Maybe PatternElement)
blockContinuation = attemptMaybe do
    blankLines <- skipBlankBlock
    indent <- takeWhile (== ' ')
    next <- peekChar
    block blankLines indent next
  where
    block :: Int -> Text -> Maybe Char -> Parser (Maybe PatternElement)
    block 0 _ _ = pure Nothing
    block _ indent (Just '{') =
        Just . Placeable . BlockPlaceable (Text.length indent) <$> inlinePlaceable
    block blankLines indent (Just c)
        | isIndentedChar c
        , not $ Text.null indent =
            Just . BlockText . ((Text.replicate blankLines "\n" <> indent) <>) <$> textRun
    block _ _ _ = pure Nothing

-- | Whether a line of a pattern can begin with the character.
isIndentedChar :: Char -> Bool
isIndentedChar c = c `notElem` ("{}[*.\n" :: String)

-- | Text up to a brace or a line break. A carriage return without a line feed is text.
textRun :: Parser Text
textRun = do
    text <- takeWhile (`notElem` ("{}\r\n" :: String))
    ifM
        (nextIs '\r' &&^ notM (secondIs '\n'))
        (advance *> (((text <> "\r") <>) <$> textRun))
        $ pure text

inlineText :: Parser Text
inlineText = do
    text <- textRun
    if Text.null text
        then parseError "Expected a character from range: anything but { } or a line end"
        else pure text

inlinePlaceable :: Parser Expression
inlinePlaceable = do
    expectChar '{'
    skipBlank
    e <- expression
    skipBlank
    expectChar '}'
    pure e

expression :: Parser Expression
expression = do
    i <- inlineExpression
    skipBlank
    ifM (nextIs '-' &&^ secondIs '>') (selected i) $ placed i
  where
    selected :: InlineExpression -> Parser Expression
    selected i = do
        unless (choosesVariant i) $ parseError "This expression cannot be used as a selector"
        advance *> advance
        skipBlankInline
        Select . SelectExpression i <$> variantList

    placed :: InlineExpression -> Parser Expression
    placed i = do
        unless (usableAsPlaceable i) $
            parseError "Attributes of terms cannot be used as placeables"
        pure $ Inline i

    choosesVariant :: InlineExpression -> Bool
    choosesVariant (StringLiteralExpression _) = True
    choosesVariant (NumberLiteralExpression _) = True
    choosesVariant (VariableReference _) = True
    choosesVariant (FunctionReference _ _) = True
    choosesVariant (TermReference _ attribute _) = isJust attribute
    choosesVariant _ = False

    usableAsPlaceable :: InlineExpression -> Bool
    usableAsPlaceable (TermReference _ (Just _) _) = False
    usableAsPlaceable _ = True

inlineExpression :: Parser InlineExpression
inlineExpression =
    peekChar >>= \case
        Just '"' -> StringLiteralExpression <$> stringLiteral
        Just c | isDigit c || c == '-' -> numberOrTermReference
        Just '$' -> advance *> (VariableReference <$> identifier)
        Just c | isAsciiLetter c -> identifierStartingExpression
        Just '{' -> PlaceableExpression <$> inlinePlaceable
        _ -> parseError "Expected an inline expression"
  where
    numberOrTermReference :: Parser InlineExpression
    numberOrTermReference =
        peekChar >>= \case
            Just '-' ->
                peekSecond >>= \case
                    Just c | isDigit c -> NumberLiteralExpression <$> numberLiteral
                    _ -> termReference
            _ -> NumberLiteralExpression <$> numberLiteral

    termReference :: Parser InlineExpression
    termReference = do
        advance
        id <- identifier
        attr <- optionalAttributeAccessor
        args <- optionalCallArguments
        pure $ TermReference id attr args

    identifierStartingExpression :: Parser InlineExpression
    identifierStartingExpression = do
        id <- identifier
        called <- callFollows
        if called && isFunctionName id
            then FunctionReference id <$> callArguments
            else MessageReference id <$> optionalAttributeAccessor

    isFunctionName :: Identifier -> Bool
    isFunctionName (Identifier text) =
        Text.all (\c -> isAsciiUpper c || isDigit c || c == '_' || c == '-') text

    callFollows :: Parser Bool
    callFollows = lookAhead $ skipBlank *> nextIs '('

    optionalAttributeAccessor :: Parser (Maybe AttributeAccessor)
    optionalAttributeAccessor = whenMaybeM (nextIs '.') attributeAccessor

    optionalCallArguments :: Parser (Maybe CallArguments)
    optionalCallArguments = whenMaybeM callFollows callArguments

attributeAccessor :: Parser AttributeAccessor
attributeAccessor = AttributeAccessor <$> (expectChar '.' *> identifier)

callArguments :: Parser CallArguments
callArguments = do
    skipBlank
    expectChar '('
    skipBlank
    args <- arguments
    skipBlank
    expectChar ')'
    unless (all isLeft $ dropWhile isRight args) $
        parseError "A positional argument cannot follow a named one"
    let names = [name | Left (NamedArgument name _) <- args]
    unless (length (List.nub names) == length names) $ parseError "A named argument is given twice"
    pure $ CallArguments args
  where
    arguments :: Parser [Either NamedArgument InlineExpression]
    arguments = ifM (nextIs ')') (pure []) do
        arg <- argument
        skipBlank
        ifM (nextIs ',') (advance *> skipBlank *> ((arg :) <$> arguments)) $ pure [arg]

    argument :: Parser (Either NamedArgument InlineExpression)
    argument = do
        e <- inlineExpression
        skipBlank
        ifM (nextIs ':') (named e) (pure $ Right e)

    named :: InlineExpression -> Parser (Either NamedArgument InlineExpression)
    named (MessageReference name Nothing) = do
        advance
        skipBlank
        Left . NamedArgument name <$> literal
    named _ = parseError "An argument's name must be a plain identifier"

literal :: Parser (Either StringLiteral NumberLiteral)
literal =
    peekChar >>= \case
        Just c | isDigit c || c == '-' -> Right <$> numberLiteral
        Just '"' -> Left <$> stringLiteral
        _ -> parseError "Expected a literal"

identifier :: Parser Identifier
identifier = do
    first <-
        peekChar >>= \case
            Just c | isAsciiLetter c -> c <$ advance
            _ -> parseError "Expected a character from range: a-zA-Z"
    rest <- takeWhile \c -> isAsciiLetter c || isDigit c || c == '_' || c == '-'
    pure . Identifier $ Text.cons first rest

numberLiteral :: Parser NumberLiteral
numberLiteral = do
    sign <- ifM (nextIs '-') ("-" <$ advance) $ pure Text.empty
    i <- digits
    f <- ifM (nextIs '.') (advance *> (Text.cons '.' <$> digits)) $ pure Text.empty
    pure . NumberLiteral $ sign <> i <> f
  where
    digits :: Parser Text
    digits = takeWhile1With "0-9" isDigit

stringLiteral :: Parser StringLiteral
stringLiteral = do
    expectChar '"'
    (raw, chars) <- match quotedChars
    expectChar '"'
    pure StringLiteral{raw, value = Text.pack chars}
  where
    quotedChars :: Parser [Char]
    quotedChars = do
        lineEnd <- atLineEnd
        peekChar >>= \case
            Just c | not lineEnd && c /= '"' && c /= '\\' -> do
                advance
                (c :) <$> quotedChars
            Just '\\' -> do
                advance
                c <- escapeSequence
                (c :) <$> quotedChars
            _ -> pure []

    escapeSequence :: Parser Char
    escapeSequence =
        peekChar >>= \case
            Just c | c == '\\' || c == '"' -> c <$ advance
            Just 'u' -> advance *> hexEscape 4
            Just 'U' -> advance *> hexEscape 6
            _ -> parseError "Unknown escape sequence"

    hexEscape :: Int -> Parser Char
    hexEscape n = do
        digits <- replicateM n hexDigit
        case readHex digits of
            [(code, "")] -> pure $ chr code
            _ -> parseError "Invalid Unicode escape sequence"

    hexDigit :: Parser Char
    hexDigit =
        peekChar >>= \case
            Just c | isHexDigit c -> c <$ advance
            _ -> parseError "Expected a character from range: 0-9a-fA-F"

variantList :: Parser VariantList
variantList = do
    vs <- variants False
    case NonEmpty.nonEmpty vs of
        Nothing -> skipBlank *> parseError "Expected at least one variant"
        Just ne
            | not $ any isDefault ne ->
                skipBlank *> parseError "Expected one of the variants to be the default"
            | otherwise -> VariantList ne <$ expectLineEnd
  where
    variants :: Bool -> Parser [Variant]
    variants hasDefault =
        attemptMaybe variantStart >>= \case
            Nothing -> pure []
            Just isDefault -> do
                when (isDefault && hasDefault) do
                    Pos afterStar <- position
                    failAt (Pos $ afterStar - 1) "Only one variant can be the default"
                key <- variantKey
                skipBlankInline
                value <- required "Expected value" maybePattern
                (Variant{key, value, isDefault} :) <$> variants (hasDefault || isDefault)

    variantStart :: Parser (Maybe Bool)
    variantStart = ifM atLineEnd (expectLineEnd *> skipBlank *> marker) $ pure Nothing

    marker :: Parser (Maybe Bool)
    marker = do
        isDefault <- nextIs '*'
        when isDefault advance
        whenMaybeM (nextIs '[') $ pure isDefault

variantKey :: Parser VariantKey
variantKey = do
    expectChar '['
    skipBlank
    key <-
        peekChar >>= \case
            Just c | isDigit c || c == '-' -> Left <$> numberLiteral
            _ -> Right <$> identifier
    skipBlank
    expectChar ']'
    pure $ VariantKey key