Parser.hs

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

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

import Control.Applicative (Alternative (many, some), optional, (<|>))
import Control.Monad (replicateM, unless, when)
import Data.Attoparsec.Combinator (choice, eitherP, endOfInput, lookAhead, sepBy)
import Data.Attoparsec.Text
    ( Parser
    , char
    , endOfLine
    , match
    , parseOnly
    , peekChar
    , satisfy
    , string
    , takeWhile
    , takeWhile1
    )
import Data.Bifunctor (first)
import Data.Char (chr, isAsciiLower, isAsciiUpper, isDigit, isHexDigit, ord)
import Data.Either (isLeft, isRight, rights)
import Data.Functor (void, (<&>))
import Data.List qualified as List
import Data.List.NonEmpty (some1)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.Ix (inRange)
import Language.Fluent.AST
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

parseResource :: Text -> Either String Resource
parseResource = parseNamed "resource" resource

resource :: Parser Resource
resource = Resource . rights <$> many (eitherP blankBlock entryOrJunk)

entryOrJunk :: Parser Entry
entryOrJunk = entry <* lookAhead entryEnd <|> JunkEntry <$> junk

entryEnd :: Parser ()
entryEnd = void endOfLine <|> endOfInput

junk :: Parser Text
junk = do
    first <- line
    when (Text.null first) $ fail "nothing left to skip"
    rest <- many $ beforeEntry *> line
    pure . mconcat $ first : rest
  where
    beforeEntry :: Parser ()
    beforeEntry = do
        next <- peekChar
        case next of
            Just c | beginsEntry c -> fail "the next entry begins here"
            Just _ -> pure ()
            Nothing -> fail "end of input"
    beginsEntry :: Char -> Bool
    beginsEntry c = isAsciiLower c || isAsciiUpper c || c == '-' || c == '#'

line :: Parser Text
line = do
    text <- takeWhile (/= '\n')
    ending <- Text.singleton <$> char '\n' <|> pure mempty
    pure $ text <> ending

entry :: Parser Entry
entry =
    choice
        [ commented
        , MessageEntry <$> message Nothing
        , TermEntry <$> term Nothing
        ]

commented :: Parser Entry
commented = do
    (hashes, Comment -> comment) <- commentBlock
    case hashes of
        1 ->
            optional
                ( (endOfLine *>)
                    . (<* lookAhead entryEnd)
                    . eitherP (message $ Just comment)
                    . term
                    $ Just comment
                )
                <&> \case
                    Nothing -> CommentEntry comment
                    Just (Left message) -> MessageEntry message
                    Just (Right term) -> TermEntry term
        2 -> pure $ GroupCommentEntry comment
        _ -> pure $ ResourceCommentEntry comment

commentBlock :: Parser (Int, Text)
commentBlock = do
    (hashes, first) <- commentLine
    rest <- many $ endOfLine *> ofSameKind hashes
    pure (hashes, Text.intercalate "\n" (first : rest))
  where
    ofSameKind :: Int -> Parser Text
    ofSameKind hashes = do
        (found, content) <- commentLine
        unless (found == hashes) . fail $
            "expected a " <> replicate hashes '#' <> " comment, found a " <> replicate found '#' <> " one"
        pure content

commentLine :: Parser (Int, Text)
commentLine = do
    let hash = char '#'
    hashes <- length . catMaybes <$> sequence [Just <$> hash, optional hash, optional hash]
    content <-
        choice
            [ char ' ' *> lineText
            , mempty <$ lookAhead (void (string "\r\n") <|> void (char '\n') <|> endOfInput)
            ]
    pure (hashes, 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 :: Maybe Comment -> Parser Message
message comment = do
    id <- identifier
    optional blankInline
    char '='
    optional blankInline
    value <- optional pattern
    attributes <- many attribute
    when (isNothing value && null attributes) $
        fail "Message must have either a pattern or attributes"
    pure Message{..}

term :: Maybe Comment -> Parser Term
term comment = do
    char '-'
    id <- identifier
    optional blankInline
    char '='
    optional blankInline
    value <- pattern
    attributes <- many attribute
    pure Term{..}

attribute :: Parser Attribute
attribute = do
    endOfLine
    optional blank
    char '.'
    i <- identifier
    optional blankInline
    char '='
    optional blankInline
    p <- pattern
    pure $ Attribute i p

pattern :: Parser Pattern
pattern = Pattern . NonEmpty.fromList . dedent . NonEmpty.toList <$> some1 patternElement

-- | Apply <https://projectfluent.org/fluent/guide/multiline multi-line rules>
-- to the raw pattern elements.
dedent :: [PatternElement] -> [PatternElement]
dedent elements =
    onLast (mapText $ Text.dropWhileEnd (`elem` blanks))
        . onFirst (mapText $ Text.dropWhile (`elem` newlines))
        $ strip <$> elements
  where
    newlines = "\r\n" :: String
    blanks = " \r\n" :: String
    commonIndent :: Int
    commonIndent =
        minimum $
            maxBound
                : [indentWidth t | BlockText t <- elements]
                    <> [indent | Placeable (BlockPlaceable indent _) <- elements]
    indentWidth :: Text -> Int
    indentWidth = Text.length . Text.takeWhile (== ' ') . Text.dropWhile (`elem` newlines)
    strip :: PatternElement -> PatternElement
    strip (BlockText (Text.span (`elem` newlines) -> (ns, rest))) =
        BlockText (ns <> Text.drop commonIndent rest)
    strip e = e
    mapText :: (Text -> Text) -> PatternElement -> PatternElement
    mapText f (InlineText t) = InlineText (f t)
    mapText f (BlockText t) = BlockText (f t)
    mapText _ e = e
    onFirst, onLast :: (a -> a) -> [a] -> [a]
    onFirst f (x : xs) = f x : xs
    onFirst _ [] = []
    onLast f = reverse . onFirst f . reverse

patternElement :: Parser PatternElement
patternElement =
    choice
        [ InlineText <$> inlineText
        , BlockText <$> blockText
        , Placeable <$> placeable
        ]

placeable :: Parser Placeable
placeable =
    choice
        [ InlinePlaceable <$> inlinePlaceable
        , blockPlaceable
        ]

inlinePlaceable :: Parser Expression
inlinePlaceable = do
    char '{'
    optional blank
    e <- expression
    optional blank
    char '}'
    pure e

blockPlaceable :: Parser Placeable
blockPlaceable = do
    blankBlock
    indent <- maybe 0 Text.length <$> optional (takeWhile1 (== ' '))
    BlockPlaceable indent <$> inlinePlaceable

expression :: Parser Expression
expression = do
    i <- inlineExpression
    choice
        [ Select <$> do
            optional blank
            string "->"
            optional blankInline
            unless (choosesVariant i) $ fail "failed to choose a variant"
            vs <- variantList
            pure $ SelectExpression i vs
        , do
            unless (usableAsPlaceable i) $ fail "Attributes of terms cannot be used as placeables"
            pure $ Inline i
        ]
  where
    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 =
    choice
        [ StringLiteralExpression <$> stringLiteral
        , NumberLiteralExpression <$> numberLiteral
        , FunctionReference <$> functionName <*> callArguments
        , MessageReference <$> identifier <*> optional attributeAccessor
        , TermReference
            <$> (char '-' *> identifier)
            <*> optional attributeAccessor
            <*> optional callArguments
        , VariableReference <$> (char '$' *> identifier)
        , PlaceableExpression <$> inlinePlaceable
        ]

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

variant :: Parser Variant
variant = do
    endOfLine
    optional blank
    isDefault <- isJust <$> optional (char '*')
    key <- variantKey
    optional blankInline
    value <- pattern
    pure Variant{..}

variantKey :: Parser VariantKey
variantKey = do
    char '['
    optional blank
    vk <- eitherP numberLiteral identifier
    optional blank
    char ']'
    pure $ VariantKey vk

variantList :: Parser VariantList
variantList = do
    variants <- some1 variant
    unless (any isDefault variants) $ fail "VariantList must have at least one default variant"
    endOfLine
    pure $ VariantList variants

callArguments :: Parser CallArguments
callArguments = do
    optional blank
    char '('
    optional blank
    args <- sepBy (eitherP namedArgument inlineExpression) comma
    unless (null args) . void $ optional comma
    optional blank
    char ')'
    unless (all isLeft $ dropWhile isRight args) $
        fail "an argument standing on its place follows one that is named"
    let names = [name | Left (NamedArgument name _) <- args]
    unless (length (List.nub names) == length names) $ fail "a name is given twice"
    pure $ CallArguments args
  where
    comma :: Parser ()
    comma = void $ optional blank >> char ',' >> optional blank

namedArgument :: Parser NamedArgument
namedArgument = do
    i <- identifier
    optional blank
    char ':'
    optional blank
    l <- eitherP stringLiteral numberLiteral
    pure $ NamedArgument i l

identifier :: Parser Identifier
identifier = Identifier <$> (Text.cons <$> satisfy isAsciiLetter <*> tailLetters)
  where
    isAsciiLetter c = isAsciiLower c || isAsciiUpper c
    tailLetters = takeWhile \c -> isAsciiLetter c || isDigit c || c == '_' || c == '-'

functionName :: Parser Identifier
functionName = do
    name@(Identifier text) <- identifier
    unless (Text.all capital text) $ fail "a function name should be written in all capitals"
    pure name
  where
    capital :: Char -> Bool
    capital c = isAsciiUpper c || isDigit c || c == '_' || c == '-'

numberLiteral :: Parser NumberLiteral
numberLiteral = do
    sign <- optional $ string "-"
    i <- digits
    f <- optional $ Text.cons <$> char '.' <*> digits
    pure . NumberLiteral . mconcat . catMaybes $ [sign, Just i, f]
  where
    digits = takeWhile1 (`elem` ['0' .. '9'])

stringLiteral :: Parser StringLiteral
stringLiteral = do
    char '"'
    (raw, value) <- match $ Text.pack <$> many quotedChar
    char '"'
    pure StringLiteral{..}

quotedChar :: Parser Char
quotedChar =
    choice
        [ satisfy \c -> isAnyChar c && notElem c ("\\\"\r\n" :: String)
        , char '\\'
            *> choice
                [ satisfy (`elem` ("\\\"" :: String))
                , char 'u' *> hexString 4
                , char 'U' *> hexString 6
                ]
        ]
  where
    hexDigit :: Parser Char
    hexDigit = satisfy isHexDigit
    hexString :: Int -> Parser Char
    hexString len = do
        [(num, "")] <- readHex <$> replicateM len hexDigit
        pure $ chr num

isAnyChar :: Char -> Bool
isAnyChar = inRange (0, 0x10FFFF) . ord

anyChar :: Parser Char
anyChar = satisfy isAnyChar

inlineText :: Parser Text
inlineText = takeWhile1 (`notElem` ("{}\r\n" :: String))

blockText :: Parser Text
blockText =
    fmap mconcat . sequence $
        [ Text.concat <$> some ("\n" <$ (optional blankInline *> endOfLine))
        , takeWhile1 (== ' ')
        , Text.cons <$> indentedChar <*> (inlineText <|> pure mempty)
        ]

indentedChar :: Parser Char
indentedChar = satisfy (`notElem` ("{}[*.\r\n" :: String))

blankInline :: Parser ()
blankInline = void . some . char $ ' '

blank :: Parser ()
blank = void . some $ blankInline <|> endOfLine

blankBlock :: Parser ()
blankBlock = void . some $ optional blankInline *> endOfLine