{-# OPTIONS_GHC -Wno-orphans #-}
module Main where
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 qualified as Parser
import System.Directory (listDirectory)
import System.Environment (lookupEnv)
import System.FilePath (replaceExtension, takeDirectory, (</>))
import Test.Hspec
import Prelude
main :: IO ()
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)]
where
entry :: Entry -> Value
entry (MessageEntry message) =
object
[ "type" .= ("Message" :: Text)
, "id" .= identifier message.id
, "value" .= maybe Null pattern message.value
, "attributes" .= (attribute <$> message.attributes)
, "comment" .= maybe Null (comment "Comment") message.comment
]
entry (TermEntry term) =
object
[ "type" .= ("Term" :: Text)
, "id" .= identifier term.id
, "value" .= pattern term.value
, "attributes" .= (attribute <$> term.attributes)
, "comment" .= maybe Null (comment "Comment") term.comment
]
entry (CommentEntry c) = comment "Comment" c
entry (GroupCommentEntry c) = comment "GroupComment" c
entry (ResourceCommentEntry c) = comment "ResourceComment" c
entry (JunkEntry content _) =
object
[ "type" .= ("Junk" :: Text)
, "annotations" .= ([] :: [Value])
, "content" .= content
]
comment :: Text -> Comment -> Value
comment kind (Comment content) =
object ["type" .= kind, "content" .= content]
identifier :: Identifier -> Value
identifier (Identifier name) =
object ["type" .= ("Identifier" :: Text), "name" .= name]
attribute :: Attribute -> Value
attribute (Attribute name value) =
object
[ "type" .= ("Attribute" :: Text)
, "id" .= identifier name
, "value" .= pattern value
]
pattern :: Pattern -> Value
pattern (Pattern elements) =
object
[ "type" .= ("Pattern" :: Text)
, "elements" .= (either textElement placeable <$> runs (NonEmpty.toList elements))
]
runs :: [PatternElement] -> [Either Text Placeable]
runs = withoutLeadingBreak . filter (either (not . Text.null) $ const True) . foldr add []
where
withoutLeadingBreak :: [Either Text Placeable] -> [Either Text Placeable]
withoutLeadingBreak (Left "\n" : rest) = rest
withoutLeadingBreak elements = elements
add :: PatternElement -> [Either Text Placeable] -> [Either Text Placeable]
add (InlineText t) (Left u : rest) = Left (t <> u) : rest
add (BlockText t) (Left u : rest) = Left (t <> u) : rest
add (InlineText t) rest = Left t : rest
add (BlockText t) rest = Left t : rest
add (Placeable p@(BlockPlaceable _ _)) rest = Left "\n" : Right p : rest
add (Placeable p) rest = Right p : rest
textElement :: Text -> Value
textElement value = object ["type" .= ("TextElement" :: Text), "value" .= value]
placeable :: Placeable -> Value
placeable p =
object
[ "type" .= ("Placeable" :: Text)
, "expression" .= expression (placeableExpression p)
]
expression :: Expression -> Value
expression (Inline inline) = inlineExpression inline
expression (Select (SelectExpression selector (VariantList variants))) =
object
[ "type" .= ("SelectExpression" :: Text)
, "selector" .= inlineExpression selector
, "variants" .= (variant <$> NonEmpty.toList variants)
]
variant :: Variant -> Value
variant v =
object
[ "type" .= ("Variant" :: Text)
, "key" .= variantKey v.key
, "value" .= pattern v.value
, "default" .= v.isDefault
]
variantKey :: VariantKey -> Value
variantKey (VariantKey key) = either numberLiteral identifier key
inlineExpression :: InlineExpression -> Value
inlineExpression (StringLiteralExpression s) = stringLiteral s
inlineExpression (NumberLiteralExpression n) = numberLiteral n
inlineExpression (FunctionReference name called) =
object
[ "type" .= ("FunctionReference" :: Text)
, "id" .= identifier name
, "arguments" .= callArguments called
]
inlineExpression (MessageReference name accessor) =
object
[ "type" .= ("MessageReference" :: Text)
, "id" .= identifier name
, "attribute" .= maybe Null accessor' accessor
]
inlineExpression (TermReference name accessor called) =
object
[ "type" .= ("TermReference" :: Text)
, "id" .= identifier name
, "attribute" .= maybe Null accessor' accessor
, "arguments" .= maybe Null callArguments called
]
inlineExpression (VariableReference name) =
object ["type" .= ("VariableReference" :: Text), "id" .= identifier name]
inlineExpression (PlaceableExpression e) =
object ["type" .= ("Placeable" :: Text), "expression" .= expression e]
accessor' :: AttributeAccessor -> Value
accessor' (AttributeAccessor name) = identifier name
callArguments :: CallArguments -> Value
callArguments (CallArguments called) =
object
[ "type" .= ("CallArguments" :: Text)
, "positional" .= [inlineExpression e | Right e <- called]
, "named" .= [namedArgument a | Left a <- called]
]
namedArgument :: NamedArgument -> Value
namedArgument (NamedArgument name literal) =
object
[ "type" .= ("NamedArgument" :: Text)
, "name" .= identifier name
, "value" .= either stringLiteral numberLiteral literal
]
stringLiteral :: StringLiteral -> Value
stringLiteral StringLiteral{raw} =
object ["type" .= ("StringLiteral" :: Text), "value" .= raw]
numberLiteral :: NumberLiteral -> Value
numberLiteral (NumberLiteral value) =
object ["type" .= ("NumberLiteral" :: Text), "value" .= value]