fluent-syntax 1.0.0 → 1.1.0

raw patch · 10 files changed

+862/−319 lines, 10 filesdep +extradep ~textsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: extra

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +33/−0
• Setup.hs +0/−2
• fluent-syntax.cabal +9/−2
• src/Data/Attoparsec/Extra.hs +97/−0
• src/Language/Fluent/AST.hs +27/−2
• src/Language/Fluent/Parser.hs +403/−288
• src/Language/Fluent/Parser/Location.hs +66/−0
• src/Language/Fluent/Parser/Whitespace.hs +93/−0
• src/Language/Fluent/TH.hs +30/−9
• test/Main.hs +104/−16

@@ -5,6 +5,39 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.1.0] - 2026-10-16++### Added++- `parseResourceLenient`, which turns an entry with a syntax error into a `JunkEntry`.+- `ParseError`, with the `offset`, `line`, `column` and `reason` of a syntax error.+- `rejectJunk`, which fails with the syntax errors of a `Resource`.+- `describeError`, which describes a syntax error by its line, column and reason.++### Fixed++- A carriage return without a line feed is text, not junk.+- Spaces at the end of a file are not junk.++### Changed++- **Breaking:** `JunkEntry` additionally holds a `ParseError`.+- **Breaking:** `parseResource` fails on a syntax error, with a line for each error.+  Use `parseResourceLenient` to get a `JunkEntry` instead.+- **Breaking:** the `fluent` quasi-quoter and `messageIdentifiers` fail to compile on a syntax+  error.+- **Breaking:** `message` and `term` no longer take a `Maybe Comment`.+- **Breaking:** `patternElement` returns a `Maybe`.+- An entry with a syntax error on a continuation line is junk as a whole.+- Requires `text` 2.0.+- Requires `extra`.++### Removed++- **Breaking:** `anyChar`, `blank`, `blankBlock`, `blankInline`, `blockPlaceable`, `blockText`,+  `dedent`, `entryEnd`, `functionName`, `indentedChar`, `isAnyChar`, `junk`, `line`,+  `namedArgument`, `placeable`, `quotedChar`, `variant`+ ## [1.0.0] - 2026-10-01  ### Added

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: fluent-syntax-version: 1.0.0+version: 1.1.0 synopsis: The syntax tree and parser for Project Fluent description: The syntax tree and parser for <https://projectfluent.org Project Fluent>. license: EUPL-1.2@@ -53,13 +53,19 @@   build-depends:     attoparsec >=0.14 && <0.15,     base <5,+    extra >=1.7 && <1.9,     hashable >=1.1 && <1.6,-    text <2.3,+    text >=2.0 && <2.3,    exposed-modules:     Language.Fluent.AST     Language.Fluent.Parser +  other-modules:+    Data.Attoparsec.Extra+    Language.Fluent.Parser.Location+    Language.Fluent.Parser.Whitespace+   if flag(template-haskell)     build-depends:       template-haskell >=2.20 && <2.25@@ -76,6 +82,7 @@     aeson >=2.2 && <2.3,     base <5,     directory >=1.3 && <1.4,+    extra >=1.6 && <1.9,     filepath >=1.4 && <1.6,     fluent-syntax,     hspec >=2.11 && <2.12,

@@ -0,0 +1,97 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Data.Attoparsec.Extra where++import Control.Monad (void)+import Control.Monad.Extra (maybeM)+import Data.Attoparsec.Internal.Types (Pos (Pos))+import Data.Attoparsec.Internal.Types qualified as Internal+import Data.Attoparsec.Text (Parser, anyChar, peekChar, takeWhile)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Internal.Encoding.Utf8 (utf8Length)+import Prelude hiding (takeWhile)++-- | Fails with the reason as it is, without attoparsec's prefix.+parseError :: String -> Parser a+parseError reason = Internal.Parser \t pos more failure _ -> failure t pos more [] reason++-- | Fails with the given @reason@ at the given @position@,+-- which does not have to be the current one.+failAt :: Pos -> String -> Parser a+failAt position reason = Internal.Parser \t _ more failure _ -> failure t position more [] reason++-- | The position in the input, in bytes.+position :: Parser Pos+position = Internal.Parser \t pos more _ success -> success t pos more pos++-- | Runs a parser and rewinds if it fails, giving the position and reason of the failure.+observing :: Parser a -> Parser (Either (Pos, String) a)+observing p = Internal.Parser \t pos more _ success ->+    Internal.runParser+        p+        t+        pos+        more+        (\t' pos' more' _ reason -> success t' pos more' $ Left (pos', reason))+        (\t' pos' more' a -> success t' pos' more' $ Right a)++-- | Runs a parser and rewinds if it gives 'Nothing'. A failure is kept.+attemptMaybe :: Parser (Maybe a) -> Parser (Maybe a)+attemptMaybe p = Internal.Parser \t pos more failure success ->+    Internal.runParser p t pos more failure \t' pos' more' result ->+        success t' (maybe pos (const pos') result) more' result++-- | The result of a parser, which must not be 'Nothing'.+required :: String -> Parser (Maybe a) -> Parser a+required reason p =+    p >>= \case+        Nothing -> parseError reason+        Just a -> pure a++-- | The second character, without consuming anything.+peekSecond :: Parser (Maybe Char)+peekSecond = Internal.Parser \t pos more failure success ->+    Internal.runParser peekChar t pos more failure \t' _ more' -> \case+        Nothing -> success t' pos more' Nothing+        Just first ->+            Internal.runParser peekChar t' (pos + width first) more' failure \t'' _ more'' ->+                success t'' pos more''++-- | Whether the second character is the given one.+secondIs :: Char -> Parser Bool+secondIs c = (Just c ==) <$> peekSecond++-- | Runs a parser until it gives 'Nothing', and collects the results.+whileJust :: Parser (Maybe a) -> Parser [a]+whileJust p = maybeM (pure []) (\x -> (x :) <$> whileJust p) p++-- | Whether the next character is the given one.+nextIs :: Char -> Parser Bool+nextIs c = (Just c ==) <$> peekChar++-- | Consumes the next character.+advance :: Parser ()+advance = Internal.Parser \t pos more failure success ->+    Internal.runParser peekChar t pos more failure \t' _ more' -> \case+        Just c -> success t' (pos + width c) more' ()+        Nothing -> Internal.runParser (void anyChar) t' pos more' failure success++-- | How far a character moves the position, in bytes.+width :: Char -> Pos+width = Pos . utf8Length++-- | Consumes the character, or fails.+expectChar :: Char -> Parser ()+expectChar expected =+    peekChar >>= \case+        Just c | c == expected -> advance+        _ -> parseError $ "Expected token: " <> show (Text.singleton expected)++-- | Like 'takeWhile', but fails if it takes nothing.+takeWhile1With :: String -> (Char -> Bool) -> Parser Text+takeWhile1With expected p = do+    taken <- takeWhile p+    if Text.null taken+        then parseError $ "Expected a character from range: " <> expected+        else pure taken

@@ -8,6 +8,7 @@ -- The normative reference is the <https://github.com/projectfluent/fluent/blob/master/spec/fluent.ebnf grammar>. module Language.Fluent.AST where +import Control.Exception (Exception (..)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text)@@ -30,10 +31,34 @@       GroupCommentEntry Comment     | -- | A @###@ comment, describing the whole t'Resource'.       ResourceCommentEntry Comment-    | -- | Source text which could not be parsed, preserved verbatim.+    | -- | Source text which could not be parsed, preserved verbatim, and the reason why.       -- See <https://projectfluent.org/fluent/guide/ the guide> on error recovery.-      JunkEntry Text+      JunkEntry Text ParseError     deriving stock (Generic, Eq, Show)++-- | Why an t'Entry' could not be parsed.+data ParseError = ParseError+    { offset :: Int+    -- ^ Where the error is, in characters from the start of the t'Resource', counting from 0.+    , line :: Int+    -- ^ The line the error is on, counting from 1.+    , column :: Int+    -- ^ The column the error is in, in characters from the start of its line, counting from 1.+    , reason :: String+    -- ^ What is wrong there.+    }+    deriving stock (Generic, Eq, Show)++instance Exception ParseError where+    displayException ParseError{..} =+        mconcat+            [ "Invalid Fluent at "+            , show line+            , ":"+            , show column+            , ": "+            , reason+            ]  -- | A translation unit. Either the @value@ or the @attributes@ must be present. data Message = Message

@@ -3,33 +3,38 @@  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 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-    , char-    , endOfLine+    , atEnd+    , endOfInput     , match     , parseOnly     , peekChar-    , satisfy-    , string+    , take+    , takeText     , 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.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 (some1)+import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List.NonEmpty qualified as NonEmpty-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)+import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import Data.Text qualified as Text-import GHC.Ix (inRange)+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) @@ -42,91 +47,134 @@ 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 = parseNamed "resource" 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 = Resource . rights <$> many (eitherP blankBlock entryOrJunk)+resource = do+    start <- position+    whole <- lookAhead takeText+    void skipBlankBlockToEnd+    entries <- whileJust . whenMaybeM (notM atEnd) $ (,) <$> entryOrJunk <*> skipBlankBlockToEnd+    pure . Resource . Location.locate start whole $ attachComments entries -entryOrJunk :: Parser Entry-entryOrJunk = entry <* lookAhead entryEnd <|> JunkEntry <$> junk+-- | 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 -entryEnd :: Parser ()-entryEnd = void endOfLine <|> endOfInput+-- | 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} -junk :: Parser Text-junk = do-    first <- line-    when (Text.null first) $ fail "nothing left to skip"-    rest <- many $ beforeEntry *> line-    pure . mconcat $ first : rest+-- | 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-    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 == '#'+    skipLines :: Parser ()+    skipLines = do+        void $ takeWhile (/= '\n')+        unlessM atEnd $ advance *> unlessM (all beginsEntry <$> peekChar) skipLines -line :: Parser Text-line = do-    text <- takeWhile (/= '\n')-    ending <- Text.singleton <$> char '\n' <|> pure mempty-    pure $ text <> ending+    beginsEntry :: Char -> Bool+    beginsEntry c = isAsciiLetter c || c == '-' || c == '#'  entry :: Parser Entry entry =-    choice-        [ commented-        , MessageEntry <$> message Nothing-        , TermEntry <$> term Nothing-        ]+    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-    (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+    (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-    (hashes, first) <- commentLine-    rest <- many $ endOfLine *> ofSameKind hashes-    pure (hashes, Text.intercalate "\n" (first : rest))+    (level, first) <- commentLine+    rest <-+        whileJust . whenMaybeM (isContinuation level) $ expectLineEnd *> (snd <$> commentLine)+    pure (level, 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+    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-    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)+    level <- hashes 3+    content <- ifM atLineEnd (pure Text.empty) $ expectChar ' ' *> lineText+    pure (level, content)  lineText :: Parser Text lineText = do@@ -134,121 +182,143 @@     end <- peekChar     pure if end == Just '\n' then fromMaybe text $ Text.stripSuffix "\r" text else text -message :: Maybe Comment -> Parser Message-message comment = do+message :: Parser Message+message = 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{..}+    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 :: Maybe Comment -> Parser Term-term comment = do-    char '-'+term :: Parser Term+term = do+    expectChar '-'     id <- identifier-    optional blankInline-    char '='-    optional blankInline-    value <- pattern-    attributes <- many attribute-    pure Term{..}+    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-    endOfLine-    optional blank-    char '.'-    i <- identifier-    optional blankInline-    char '='-    optional blankInline-    p <- pattern-    pure $ Attribute i p+    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 = Pattern . NonEmpty.fromList . dedent . NonEmpty.toList <$> some1 patternElement+pattern =+    patternElements+        >>= maybe (parseError "Expected a value") (pure . Pattern) . NonEmpty.nonEmpty . dedent --- | 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+patternElements :: Parser [PatternElement]+patternElements = whileJust patternElement -patternElement :: Parser PatternElement+patternElement :: Parser (Maybe PatternElement) patternElement =-    choice-        [ InlineText <$> inlineText-        , BlockText <$> blockText-        , Placeable <$> placeable-        ]+    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 -placeable :: Parser Placeable-placeable =-    choice-        [ InlinePlaceable <$> inlinePlaceable-        , blockPlaceable-        ]+-- | 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-    char '{'-    optional blank+    expectChar '{'+    skipBlank     e <- expression-    optional blank-    char '}'+    skipBlank+    expectChar '}'     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-        ]+    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@@ -263,150 +333,195 @@  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-        ]+    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 -attributeAccessor :: Parser AttributeAccessor-attributeAccessor = AttributeAccessor <$> (char '.' *> identifier)+    termReference :: Parser InlineExpression+    termReference = do+        advance+        id <- identifier+        attr <- optionalAttributeAccessor+        args <- optionalCallArguments+        pure $ TermReference id attr args -variant :: Parser Variant-variant = do-    endOfLine-    optional blank-    isDefault <- isJust <$> optional (char '*')-    key <- variantKey-    optional blankInline-    value <- pattern-    pure Variant{..}+    identifierStartingExpression :: Parser InlineExpression+    identifierStartingExpression = do+        id <- identifier+        called <- callFollows+        if called && isFunctionName id+            then FunctionReference id <$> callArguments+            else MessageReference id <$> optionalAttributeAccessor -variantKey :: Parser VariantKey-variantKey = do-    char '['-    optional blank-    vk <- eitherP numberLiteral identifier-    optional blank-    char ']'-    pure $ VariantKey vk+    isFunctionName :: Identifier -> Bool+    isFunctionName (Identifier text) =+        Text.all (\c -> isAsciiUpper c || isDigit c || c == '_' || c == '-') text -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+    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-    optional blank-    char '('-    optional blank-    args <- sepBy (eitherP namedArgument inlineExpression) comma-    unless (null args) . void $ optional comma-    optional blank-    char ')'+    skipBlank+    expectChar '('+    skipBlank+    args <- arguments+    skipBlank+    expectChar ')'     unless (all isLeft $ dropWhile isRight args) $-        fail "an argument standing on its place follows one that is named"+        parseError "A positional argument cannot follow a named one"     let names = [name | Left (NamedArgument name _) <- args]-    unless (length (List.nub names) == length names) $ fail "a name is given twice"+    unless (length (List.nub names) == length names) $ parseError "A named argument is given twice"     pure $ CallArguments args   where-    comma :: Parser ()-    comma = void $ optional blank >> char ',' >> optional blank+    arguments :: Parser [Either NamedArgument InlineExpression]+    arguments = ifM (nextIs ')') (pure []) do+        arg <- argument+        skipBlank+        ifM (nextIs ',') (advance *> skipBlank *> ((arg :) <$> arguments)) $ pure [arg] -namedArgument :: Parser NamedArgument-namedArgument = do-    i <- identifier-    optional blank-    char ':'-    optional blank-    l <- eitherP stringLiteral numberLiteral-    pure $ NamedArgument i l+    argument :: Parser (Either NamedArgument InlineExpression)+    argument = do+        e <- inlineExpression+        skipBlank+        ifM (nextIs ':') (named e) (pure $ Right e) -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 == '-'+    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" -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 == '-'+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 <- optional $ string "-"+    sign <- ifM (nextIs '-') ("-" <$ advance) $ pure Text.empty     i <- digits-    f <- optional $ Text.cons <$> char '.' <*> digits-    pure . NumberLiteral . mconcat . catMaybes $ [sign, Just i, f]+    f <- ifM (nextIs '.') (advance *> (Text.cons '.' <$> digits)) $ pure Text.empty+    pure . NumberLiteral $ sign <> i <> f   where-    digits = takeWhile1 (`elem` ['0' .. '9'])+    digits :: Parser Text+    digits = takeWhile1With "0-9" isDigit  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-                ]-        ]+    expectChar '"'+    (raw, chars) <- match quotedChars+    expectChar '"'+    pure StringLiteral{raw, value = Text.pack chars}   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+    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 [] -anyChar :: Parser Char-anyChar = satisfy isAnyChar+    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" -inlineText :: Parser Text-inlineText = takeWhile1 (`notElem` ("{}\r\n" :: String))+    hexEscape :: Int -> Parser Char+    hexEscape n = do+        digits <- replicateM n hexDigit+        case readHex digits of+            [(code, "")] -> pure $ chr code+            _ -> parseError "Invalid Unicode escape sequence" -blockText :: Parser Text-blockText =-    fmap mconcat . sequence $-        [ Text.concat <$> some ("\n" <$ (optional blankInline *> endOfLine))-        , takeWhile1 (== ' ')-        , Text.cons <$> indentedChar <*> (inlineText <|> pure mempty)-        ]+    hexDigit :: Parser Char+    hexDigit =+        peekChar >>= \case+            Just c | isHexDigit c -> c <$ advance+            _ -> parseError "Expected a character from range: 0-9a-fA-F" -indentedChar :: Parser Char-indentedChar = satisfy (`notElem` ("{}[*.\r\n" :: String))+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) -blankInline :: Parser ()-blankInline = void . some . char $ ' '+    variantStart :: Parser (Maybe Bool)+    variantStart = ifM atLineEnd (expectLineEnd *> skipBlank *> marker) $ pure Nothing -blank :: Parser ()-blank = void . some $ blankInline <|> endOfLine+    marker :: Parser (Maybe Bool)+    marker = do+        isDefault <- nextIs '*'+        when isDefault advance+        whenMaybeM (nextIs '[') $ pure isDefault -blankBlock :: Parser ()-blankBlock = void . some $ optional blankInline *> endOfLine+variantKey :: Parser VariantKey+variantKey = do+    expectChar '['+    skipBlank+    key <-+        peekChar >>= \case+            Just c | isDigit c || c == '-' -> Left <$> numberLiteral+            _ -> Right <$> identifier+    skipBlank+    expectChar ']'+    pure $ VariantKey key

@@ -0,0 +1,66 @@+module Language.Fluent.Parser.Location where++import Data.Attoparsec.Internal.Types (Pos (Pos))+import Data.List qualified as List+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Unsafe (dropWord8, lengthWord8, takeWord8)+import Language.Fluent.AST+import Prelude++-- | Replaces the byte offsets of the errors of junk with character offsets, lines and columns.+locate :: Pos -> Text -> [Entry] -> [Entry]+locate (Pos start) whole = snd . List.mapAccumL step (Cursor 0 0 1 1 whole)+  where+    step :: Cursor -> Entry -> (Cursor, Entry)+    step cursor (JunkEntry text ParseError{offset, reason}) =+        let moved@Cursor{characters, lineNumber, columnNumber} = advanceTo (offset - start) cursor+         in ( moved+            , JunkEntry+                text+                ParseError+                    { offset = characters+                    , line = lineNumber+                    , column = columnNumber+                    , reason+                    }+            )+    step cursor other = (cursor, other)++-- | A position in the text in bytes, characters, lines and columns, and the text after it.+data Cursor = Cursor+    { bytes :: !Int+    , characters :: !Int+    , lineNumber :: !Int+    , columnNumber :: !Int+    , remaining :: Text+    }++-- | Moves the cursor forward to the given byte offset.+advanceTo :: Int -> Cursor -> Cursor+advanceTo target Cursor{..} =+    Cursor+        { bytes = target+        , characters = characters + Text.length passed+        , lineNumber = lineNumber + breaks+        , columnNumber = newColumn+        , remaining = dropWord8 skipped remaining+        }+  where+    skipped = target - bytes+    passed = takeWord8 skipped remaining+    breaks = Text.count "\n" passed+    newColumn+        | breaks == 0 = columnNumber + Text.length passed+        | otherwise = 1 + Text.length (Text.takeWhileEnd (/= '\n') passed)++-- | Moves a failure that follows a line break back to the end of the last non-blank character,+-- where what is missing belongs. Both offsets are in bytes of the text.+settle :: Text -> Int -> Int+settle text failure+    | Text.any (== '\n') $ Text.takeWhileEnd isBlank before = lengthWord8 content+    | otherwise = failure+  where+    before = takeWord8 failure text+    content = Text.dropWhileEnd isBlank before+    isBlank = (`elem` (" \r\n" :: String))

@@ -0,0 +1,93 @@+module Language.Fluent.Parser.Whitespace where++import Control.Monad (void)+import Control.Monad.Extra (ifM, whenM, whenMaybeM, (&&^))+import Data.Attoparsec.Extra+import Data.Attoparsec.Text (Parser, atEnd, peekChar, takeWhile)+import Data.Text (Text)+import Data.Text qualified as Text+import Language.Fluent.AST+import Prelude hiding (takeWhile)++-- | Consumes a line end: a line break or the end of the input.+expectLineEnd :: Parser ()+expectLineEnd =+    peekChar >>= \case+        Nothing -> pure ()+        Just '\n' -> advance+        Just '\r' -> ifM (secondIs '\n') (advance *> advance) notLineEnd+        _ -> notLineEnd+  where+    notLineEnd :: Parser ()+    notLineEnd = parseError "Expected token: end of line"++-- | Whether a line end is next.+atLineEnd :: Parser Bool+atLineEnd =+    peekChar >>= \case+        Nothing -> pure True+        Just '\n' -> pure True+        Just '\r' -> secondIs '\n'+        _ -> pure False++-- | Consumes a line break, and tells whether there was one. The end of the input is not one.+consumeNewline :: Parser Bool+consumeNewline =+    peekChar >>= \case+        Just '\n' -> True <$ advance+        Just '\r' -> secondIs '\n' &&^ (True <$ (advance *> advance))+        _ -> pure False++-- | Skips the spaces before the next character.+skipBlankInline :: Parser ()+skipBlankInline = void $ takeWhile (== ' ')++-- | Skips spaces and line breaks.+skipBlank :: Parser ()+skipBlank = skipBlankInline *> whenM consumeNewline skipBlank++-- | Skips lines of only spaces, and tells how many.+skipBlankBlock :: Parser Int+skipBlankBlock = length <$> whileJust (attemptMaybe blankLine)+  where+    blankLine = skipBlankInline *> whenMaybeM consumeNewline (pure ())++-- | Like 'skipBlankBlock', and skips spaces that end the input.+skipBlankBlockToEnd :: Parser Int+skipBlankBlockToEnd =+    skipBlankBlock <* attemptMaybe (skipBlankInline *> whenMaybeM atEnd (pure ()))++-- | Applies <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 dropLeadingBreaks+        $ 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 t) =+        let (ns, rest) = Text.span (`elem` newlines) t+         in BlockText (ns <> Text.drop commonIndent rest)+    strip e = e+    dropLeadingBreaks :: PatternElement -> PatternElement+    dropLeadingBreaks (BlockText t) = BlockText $ Text.dropWhile (`elem` newlines) t+    dropLeadingBreaks 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

@@ -7,14 +7,20 @@  module Language.Fluent.TH (fluent, messageIdentifiers) where +import Control.Exception (displayException)+import Data.Bifunctor (first) import Data.Char (toLower, toUpper)+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (mapMaybe) import Data.String (IsString, fromString) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text import Data.Traversable (for) import Language.Fluent.AST-import Language.Fluent.Parser (parse, parseResource, resource)+import Language.Fluent.Parser (parseResource, parseResourceLenient, rejectJunk) import Language.Haskell.TH.Lib     ( DecsQ     , appE@@ -29,8 +35,10 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax     ( Lift+    , Loc (loc_start)     , Quasi (qAddDependentFile)     , lift+    , location     , makeRelativeToProject     , mkName     , runIO@@ -39,24 +47,35 @@  -- | Parses a 'Resource'. -- Strips the indentation shared by every line.+-- Syntax errors fail the compilation. fluent :: QuasiQuoter fluent =     QuasiQuoter-        { quoteExp = either fail lift . parse resource . dedent . Text.pack+        { quoteExp = \quoted -> do+            start <- loc_start <$> location+            either (fail . List.intercalate "\n" . fmap displayException . NonEmpty.toList) lift $+                parseQuoted start quoted         , quotePat = const $ fail "a Fluent Resource is not a pattern"         , quoteType = const $ fail "a Fluent Resource is not a type"         , quoteDec = const $ fail "a Fluent Resource is not a declaration"         }   where-    dedent :: Text -> Text-    dedent written = Text.unlines $ Text.drop shared <$> lines'+    parseQuoted :: (Int, Int) -> String -> Either (NonEmpty ParseError) Resource+    parseQuoted (firstLine, firstColumn) quoted =+        first (fmap locate) . rejectJunk . parseResourceLenient $ text       where-        lines' = Text.lines written-        shared = minimum . (maxBound :) $ do-            line <- lines'-            let (indent, rest) = Text.span (== ' ') line-            [Text.length indent | not . Text.null $ rest]+        (indent, text) = dedent $ Text.pack quoted+        locate error =+            error+                { line = firstLine + error.line - 1+                , column = indent + error.column + if error.line == 1 then firstColumn - 1 else 0+                } +    dedent :: Text -> (Int, Text)+    dedent (Text.lines -> lines) = (shared, Text.unlines $ Text.drop shared <$> lines)+      where+        shared = minimum . (maxBound :) $ mapMaybe (Text.findIndex (/= ' ')) lines+ -- | Declares a constant for every message identifier in the given Fluent file. -- -- > messageIdentifiers "en.ftl"@@ -123,6 +142,8 @@ deriving stock instance Lift Resource  deriving stock instance Lift Entry++deriving stock instance Lift ParseError  deriving stock instance Lift Message 

@@ -2,32 +2,120 @@  module Main where -import Data.Aeson (ToJSON (toJSON), Value (Null), eitherDecodeFileStrict, object, (.=))-import Data.List (isSuffixOf, sort)+import Control.Monad (when)+import Control.Monad.Extra (eitherM)+import Data.Aeson+    ( FromJSON (parseJSON)+    , ToJSON (toJSON)+    , Value (Null)+    , eitherDecodeFileStrict+    , object+    , withObject+    , (.:)+    , (.=)+    )+import Data.Aeson.Types (Parser)+import Data.Bifunctor (first)+import Data.List (isPrefixOf, isSuffixOf, sort) import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (catMaybes) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO import Language.Fluent.AST-import Language.Fluent.Parser (parse, resource)+import Language.Fluent.Parser qualified as Parser import System.Directory (listDirectory) import System.Environment (lookupEnv)-import System.FilePath (replaceExtension, (</>))+import System.FilePath (replaceExtension, takeDirectory, (</>)) import Test.Hspec import Prelude  main :: IO ()-main = hspec . describe "reference fixtures" $ do-    runIO (lookupEnv "FLUENT_FIXTURES") >>= \case-        Nothing -> it "cannot be found" $ pendingWith "FLUENT_FIXTURES is unset"-        Just fixtures -> do-            runIO (sort . filter (".ftl" `isSuffixOf`) <$> listDirectory fixtures) >>= mapM_ \name -> it name do-                text <- Text.IO.readFile $ fixtures </> name-                expected <--                    either fail pure-                        =<< eitherDecodeFileStrict (fixtures </> replaceExtension name "json")-                either expectationFailure ((`shouldBe` expected) . toJSON) $ parse resource text+main = hspec do+    describe "reference fixtures" do+        runIO (lookupEnv "FLUENT_FIXTURES") >>= \case+            Nothing -> it "cannot be found" $ pendingWith "FLUENT_FIXTURES is unset"+            Just fixtures -> do+                runIO (sort . filter (".ftl" `isSuffixOf`) <$> listDirectory fixtures) >>= mapM_ \file -> it file do+                    text <- Text.IO.readFile $ fixtures </> file+                    expected <-+                        eitherM fail pure $+                            eitherDecodeFileStrict (fixtures </> replaceExtension file "json")+                    either expectationFailure ((`shouldBe` expected) . toJSON) $ Parser.parse Parser.resource text +    describe "structure fixtures" do+        runIO (lookupEnv "FLUENT_FIXTURES") >>= \case+            Nothing -> it "cannot be found" $ pendingWith "FLUENT_FIXTURES is unset"+            Just fixtures -> do+                let structure = takeDirectory fixtures </> "fixtures_structure"+                runIO (sort . filter (".ftl" `isSuffixOf`) <$> listDirectory structure) >>= mapM_ \file -> it file do+                    when (file `elem` brokenAttributes) $+                        pendingWith "fluent.js drops the whole entry (fluent.js#237), we keep the message"+                    text <- Text.IO.readFile $ structure </> file+                    Junks expected <-+                        eitherM fail pure $+                            eitherDecodeFileStrict (structure </> replaceExtension file "json")+                    let ours = junks $ Parser.parseResourceLenient text+                        mismatches =+                            [ (content, offset, theirs)+                            | ((content, offset, reason), (expectedContent, theirs)) <- zip ours expected+                            , (content, offset) /= (expectedContent, theirs)+                            , content /= expectedContent || not (movedBack text reason offset theirs)+                            ]+                    length ours `shouldBe` length expected+                    mismatches `shouldBe` []++    describe "parseResource" do+        it "succeeds when there is no syntax error" $+            Parser.parseResource "" `shouldBe` Right (Resource [])+        it "reports multiple syntax errors" $+            first lines (Parser.parseResource "a = {\nb = }\n")+                `shouldBe` Left+                    [ "Invalid Fluent at 2:1: Expected token: \"}\""+                    , "Invalid Fluent at 2:5: Unbalanced closing brace in a text element"+                    ]++    describe "parseResourceLenient" do+        it "keeps the entries after the junk" $+            length (entries $ Parser.parseResourceLenient "a = {\nb = fine\n") `shouldBe` 2++brokenAttributes :: [FilePath]+brokenAttributes =+    [ "attribute_with_empty_pattern.ftl"+    , "attribute_without_equal_sign.ftl"+    , "leading_dots.ftl"+    , "non_id_attribute_name.ftl"+    ]++junks :: Resource -> [(Text, Int, String)]+junks (Resource entries) =+    [(content, offset, reason) | JunkEntry content (ParseError offset _ _ reason) <- entries]++movedBack :: Text -> String -> Int -> Int -> Bool+movedBack text reason offset theirs =+    "Expected" `isPrefixOf` reason+        && offset < theirs+        && Text.all (`elem` (" \r\n" :: String)) (Text.take (theirs - offset) $ Text.drop offset text)++newtype Junks = Junks [(Text, Int)]++instance FromJSON Junks where+    parseJSON = withObject "Resource" \resource ->+        Junks . catMaybes <$> (traverse junk =<< resource .: "body")+      where+        junk :: Value -> Parser (Maybe (Text, Int))+        junk = withObject "Entry" \entry -> do+            kind <- entry .: "type"+            if kind /= ("Junk" :: Text)+                then pure Nothing+                else do+                    content <- entry .: "content"+                    annotations <- entry .: "annotations"+                    start <- case annotations of+                        annotation : _ -> annotation .: "span" >>= (.: "start")+                        [] -> fail "Junk without an annotation"+                    pure $ Just (content, start)+ instance ToJSON Resource where     toJSON (Resource entries) =         object ["type" .= ("Resource" :: Text), "body" .= (entry <$> entries)]@@ -52,7 +140,7 @@         entry (CommentEntry c) = comment "Comment" c         entry (GroupCommentEntry c) = comment "GroupComment" c         entry (ResourceCommentEntry c) = comment "ResourceComment" c-        entry (JunkEntry content) =+        entry (JunkEntry content _) =             object                 [ "type" .= ("Junk" :: Text)                 , "annotations" .= ([] :: [Value])@@ -83,7 +171,7 @@                 ]          runs :: [PatternElement] -> [Either Text Placeable]-        runs = withoutLeadingBreak . filter (either (not . Text.null) (const True)) . foldr add []+        runs = withoutLeadingBreak . filter (either (not . Text.null) $ const True) . foldr add []           where             withoutLeadingBreak :: [Either Text Placeable] -> [Either Text Placeable]             withoutLeadingBreak (Left "\n" : rest) = rest