Maintenance: linting

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")

internal/Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import           CLI       (Opts (..), getOpts)
+import qualified Data.Text as T
+import           Prelude
+
+main :: IO ()
+main = getOpts >>= \case
+  Lint x -> putTextLn $ "Hello, " <> T.pack x <> "!"

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

lib/Intlc/Linter.hs

@@ -0,0 +1,37 @@
+module Intlc.Linter where
+
+import           Intlc.ICU
+import           Prelude   hiding (Type)
+
+data Status
+  = Success
+  | Failure Text
+  deriving (Eq, Show)
+
+countInterpolations :: NEStream -> Int
+countInterpolations = foldr go 0
+  where
+    count = \case
+      String      -> 0
+      Number      -> 0
+      Date {}     -> 0
+      Time {}     -> 0
+      PluralRef   -> 0
+      Bool {}     -> 1
+      Plural {}   -> 1
+      Select {}   -> 1
+      Callback {} -> 1
+    go :: Token -> Int -> Int
+    go t n = case t of
+      Plaintext {}              -> n
+      Interpolation ((Arg _ x)) -> count x + n
+
+lint :: Message -> Status
+lint m = case m of
+  Static {}        -> Success
+  Dynamic neStream -> (mkStatus . countInterpolations) neStream
+    where
+      mkStatus n = if n > 1
+        then Failure "Too many interpolations. They will appear nested once flattened."
+        else Success
+

test/Intlc/LinterSpec.hs

@@ -0,0 +1,30 @@
+module Intlc.LinterSpec where
+
+import           Intlc.ICU
+import           Intlc.Linter
+import           Prelude
+import           Test.Hspec
+
+spec :: Spec
+spec = describe "linter" $ do
+  it "lints static text" $ do
+    lint (Static "Hello world") `shouldBe` Success
+
+  it "lints dynamic streams with 1 plain text token" $ do
+    lint (Dynamic (fromList [Plaintext "yay"])) `shouldBe` Success
+
+  it "lints dynamic streams with 2 or more plain text token" $ do
+    lint (Dynamic (fromList [Plaintext "yay", Plaintext "Hello"])) `shouldBe` Success
+
+  it "lints dynamic streams with 1 dynamic simple interpolation" $ do
+    lint (Dynamic (fromList [Interpolation (Arg "Hello" String)])) `shouldBe` Success
+
+  it "lints dynamic streams with 1 dynamic complex interpolation" $ do
+    lint (Dynamic (fromList [Interpolation (Arg "Hello" (Callback []))])) `shouldBe` Success
+
+  it "lints dynamic streams with 1 dynamic complex interpolation and 1 simple interpolation" $ do
+    lint (Dynamic (fromList [Interpolation (Arg "Hello" (Callback [])), Plaintext "hello"])) `shouldBe` Success
+
+  it "does not lint dynamic streams with 2 or more dynamic complex interpolations" $ do
+    lint (Dynamic (fromList [Interpolation (Arg "Hello" (Callback [])), Interpolation (Arg "Hello" (Bool [] []))])) `shouldBe` Failure "Too many interpolations. They will appear nested once flattened."
+