diff --git a/internal/CLI.hs b/internal/CLI.hs new file mode 100644 index 0000000..f39402a --- /dev/null +++ b/internal/CLI.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use newtype instead of data" #-} + +module CLI (Opts (..), getOpts) where + +import Options.Applicative +import Prelude + +data Opts + = Lint FilePath + +getOpts :: IO Opts +getOpts = execParser (info (opts <**> helper) (progDesc h)) + where h = "Additional tooling for Unsplash." + +opts :: Parser Opts +opts = subparser + ( command "lint" (info (lint <**> helper) mempty) + ) + +lint :: Parser Opts +lint = Lint <$> pathp + +pathp :: Parser FilePath +pathp = argument str (metavar "filepath") diff --git a/internal/Main.hs b/internal/Main.hs new file mode 100644 index 0000000..d623354 --- /dev/null +++ b/internal/Main.hs @@ -0,0 +1,31 @@ +module Main where + +import CLI (Opts (..), getOpts) +import qualified Data.Map as M +import qualified Data.Text as T +import Intlc.Core +import Intlc.Linter +import Intlc.Parser (parseDataset, printErr) +import Intlc.Parser.Error (ParseFailure) +import Prelude hiding (filter) + +main :: IO () +main = getOpts >>= \case + Lint path -> either parserDie lint' =<< getParsed path + where + getParsed :: FilePath -> IO (Either ParseFailure (Dataset Translation)) + getParsed x = parseDataset x <$> readFileText x + + parserDie = die . printErr + + lint' :: Dataset Translation -> IO () + lint' = exit . M.mapMaybe statusToMaybe . fmap (lint . message) + + exit :: Dataset (NonEmpty LintingError) -> IO () + exit sts + | M.size sts > 0 = (die . T.unpack . ("Errors\n" <>) . M.foldrWithKey mkLine mempty) sts + | otherwise = pure () + + mkLine :: Text -> NonEmpty LintingError -> Text -> Text + mkLine k es acc = acc <> "\n" <> k <> ": " <> e + where e = T.intercalate ", " . toList . fmap show $ es diff --git a/intlc.cabal b/intlc.cabal index 41dbe0c..47c1462 100644 --- a/intlc.cabal +++ b/intlc.cabal @@ -38,6 +38,16 @@ executable intlc other-modules: CLI +executable intlc-internal + import: common + hs-source-dirs: internal/ + main-is: Main.hs + build-depends: + intlc + , optparse-applicative ^>=0.16 + other-modules: + CLI + library import: common hs-source-dirs: lib/ @@ -54,6 +64,7 @@ library Intlc.Backend.TypeScript.Compiler Intlc.Core Intlc.ICU + Intlc.Linter Intlc.Parser Intlc.Parser.Error Intlc.Parser.JSON @@ -81,5 +92,6 @@ test-suite test-intlc Intlc.Backend.TypeScriptSpec Intlc.CompilerSpec Intlc.EndToEndSpec + Intlc.LinterSpec Intlc.Parser.JSONSpec Intlc.Parser.ICUSpec diff --git a/lib/Intlc/ICU.hs b/lib/Intlc/ICU.hs index 22421fb..3040928 100644 --- a/lib/Intlc/ICU.hs +++ b/lib/Intlc/ICU.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} + -- This module defines an AST for ICU messages. We do not necessarily behave -- identically to other implementations. @@ -27,6 +29,55 @@ mergePlaintext [] = [] mergePlaintext (Plaintext x : Plaintext y : zs) = mergePlaintext $ Plaintext (x <> y) : zs mergePlaintext (x:ys) = x : mergePlaintext ys +getStream :: Token -> Maybe Stream +getStream Plaintext {} = Nothing +getStream (Interpolation _ t) = case t of + String -> Nothing + Number -> Nothing + Date {} -> Nothing + Time {} -> Nothing + PluralRef -> Nothing + Bool {trueCase, falseCase} -> Just $ trueCase <> falseCase + Plural x -> Just $ getPluralStream x + Select cs mw -> Just $ ss <> ws + where ss = (\(SelectCase _ xs) -> xs) `concatMap` cs + ws = case mw of + Nothing -> [] + Just (SelectWildcard xs) -> xs + Callback xs -> Just xs + +getPluralStream :: Plural -> Stream +getPluralStream (Cardinal x) = getCardinalStream x +getPluralStream (Ordinal x) = getOrdinalStream x + +getCardinalStream :: CardinalPlural -> Stream +getCardinalStream (LitPlural xs mw) = join + [ getPluralCaseStream `concatMap` xs + , maybeToMonoid $ getPluralWildcardStream <$> mw + ] +getCardinalStream (RulePlural xs w) = join + [ getPluralCaseStream `concatMap` xs + , getPluralWildcardStream w + ] +getCardinalStream (MixedPlural xs ys w) = join + [ getPluralCaseStream `concatMap` xs + , getPluralCaseStream `concatMap` ys + , getPluralWildcardStream w + ] + +getOrdinalStream :: OrdinalPlural -> Stream +getOrdinalStream (OrdinalPlural xs ys w) = join + [ getPluralCaseStream `concatMap` xs + , getPluralCaseStream `concatMap` ys + , getPluralWildcardStream w + ] + +getPluralCaseStream :: PluralCase a -> Stream +getPluralCaseStream (PluralCase _ xs) = xs + +getPluralWildcardStream :: PluralWildcard -> Stream +getPluralWildcardStream (PluralWildcard xs) = xs + -- We diverge from icu4j by supporting a boolean type, and not necessarily -- requiring wildcard cases. data Type diff --git a/lib/Intlc/Linter.hs b/lib/Intlc/Linter.hs new file mode 100644 index 0000000..2f18ff8 --- /dev/null +++ b/lib/Intlc/Linter.hs @@ -0,0 +1,36 @@ +module Intlc.Linter where + +import Intlc.ICU +import Prelude hiding (Type) + +data LintingError + = TooManyInterpolations + deriving (Eq, Show) + +data Status + = Success + | Failure (NonEmpty LintingError) + deriving (Eq, Show) + +statusToMaybe :: Status -> Maybe (NonEmpty LintingError) +statusToMaybe Success = Nothing +statusToMaybe (Failure xs) = Just xs + +maybeToStatus :: Maybe (NonEmpty LintingError) -> Status +maybeToStatus Nothing = Success +maybeToStatus (Just xs) = Failure xs + +interpolationsRule :: Stream -> Maybe LintingError +interpolationsRule = go 0 + where + go :: Int -> Stream -> Maybe LintingError + go 2 _ = Just TooManyInterpolations + go _ [] = Nothing + go n (x:xs) = go n' $ maybeToMonoid mys <> xs + where mys = getStream x + n' = n + length mys + +lint :: Message -> Status +lint (Message stream) = toStatus $ rules `flap` stream + where toStatus = maybeToStatus . nonEmpty . catMaybes + rules = [interpolationsRule] diff --git a/test/Intlc/LinterSpec.hs b/test/Intlc/LinterSpec.hs new file mode 100644 index 0000000..b2c6c21 --- /dev/null +++ b/test/Intlc/LinterSpec.hs @@ -0,0 +1,41 @@ +module Intlc.LinterSpec where + +import Intlc.ICU +import Intlc.Linter +import Prelude +import Test.Hspec + +spec :: Spec +spec = describe "linter" $ do + it "lints streams with 1 plain text token" $ do + lint (Message [Plaintext "yay"]) `shouldBe` Success + + it "lints streams with 2 or more plain text token" $ do + lint (Message [Plaintext "yay", Plaintext "Hello"]) `shouldBe` Success + + it "lints streams with 1 simple interpolation" $ do + lint (Message [Interpolation "Hello" String]) `shouldBe` Success + + it "lints streams with 1 complex interpolation" $ do + lint (Message [Interpolation "Hello" (Callback [])]) `shouldBe` Success + + it "lints streams with 1 complex interpolation and 1 simple interpolation" $ do + lint (Message [Interpolation "Hello" (Callback []), Plaintext "hello"]) `shouldBe` Success + + it "does not lint streams with 2 or more complex interpolations" $ do + lint (Message [Interpolation "Hello" (Callback []), Interpolation "Hello" (Bool [] [])]) `shouldBe` Failure (pure TooManyInterpolations) + + it "does not lint nested streams" $ do + lint (Message [Interpolation "outer" (Callback [Interpolation "inner" (Callback [])])]) `shouldBe` Failure (pure TooManyInterpolations) + + it "does not lint complex interpolations with nested complex interpolations" $ do + lint (Message [Interpolation "outer" (Select (fromList [SelectCase "hello" [Interpolation "super_inner" (Callback [])]]) Nothing)]) `shouldBe` Failure (pure TooManyInterpolations) + + it "stops iterating after encountering two stream-interpolations" $ do + let nested x = Interpolation "x" (Callback [x]) + let e = error "should not reach this item" + + lint (Message + [ nested (nested e) + , e + ]) `shouldBe` Failure (pure TooManyInterpolations)