diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/fluent-syntax.cabal b/fluent-syntax.cabal --- a/fluent-syntax.cabal +++ b/fluent-syntax.cabal @@ -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 . 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, diff --git a/src/Data/Attoparsec/Extra.hs b/src/Data/Attoparsec/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Attoparsec/Extra.hs @@ -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 diff --git a/src/Language/Fluent/AST.hs b/src/Language/Fluent/AST.hs --- a/src/Language/Fluent/AST.hs +++ b/src/Language/Fluent/AST.hs @@ -8,6 +8,7 @@ -- The normative reference is the . 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 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 diff --git a/src/Language/Fluent/Parser.hs b/src/Language/Fluent/Parser.hs --- a/src/Language/Fluent/Parser.hs +++ b/src/Language/Fluent/Parser.hs @@ -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 --- 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 diff --git a/src/Language/Fluent/Parser/Location.hs b/src/Language/Fluent/Parser/Location.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fluent/Parser/Location.hs @@ -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)) diff --git a/src/Language/Fluent/Parser/Whitespace.hs b/src/Language/Fluent/Parser/Whitespace.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fluent/Parser/Whitespace.hs @@ -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 +-- 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 diff --git a/src/Language/Fluent/TH.hs b/src/Language/Fluent/TH.hs --- a/src/Language/Fluent/TH.hs +++ b/src/Language/Fluent/TH.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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