{-# OPTIONS_GHC -Wno-orphans #-}
module Main where
import Data.Aeson (ToJSON (toJSON), Value (Null), eitherDecodeFileStrict, object, (.=))
import Data.List (isSuffixOf, sort)
import Data.List.NonEmpty qualified as NonEmpty
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 System.Directory (listDirectory)
import System.Environment (lookupEnv)
import System.FilePath (replaceExtension, (</>))
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
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]