Merge pull request #144 from unsplash/ext-linter

Add external/public linter

cli/CLI.hs

@@ -7,23 +7,28 @@ import           Prelude
 data Opts
   = Compile FilePath Locale
   | Flatten FilePath
+  | Lint    FilePath
 
 getOpts :: IO Opts
 getOpts = execParser (info (opts <**> helper) (progDesc h))
   where h = "Compile ICU messages into code."
 
 opts :: Parser Opts
-opts = subparser
-  ( command "compile" (info (compile <**> helper) mempty)
- <> command "flatten" (info (flatten <**> helper) mempty)
-  )
+opts = subparser . mconcat $
+  [ command "compile" (info (compile <**> helper) mempty)
+  , command "flatten" (info (flatten <**> helper) mempty)
+  , command "lint"    (info (lint    <**> helper) mempty)
+  ]
 
 compile :: Parser Opts
 compile = Compile <$> pathp <*> localep
 
 flatten :: Parser Opts
 flatten = Flatten <$> pathp
 
+lint :: Parser Opts
+lint = Lint <$> pathp
+
 pathp :: Parser FilePath
 pathp = argument str (metavar "filepath")
 

cli/Main.hs

@@ -1,17 +1,26 @@
 module Main where
 
 import           CLI                (Opts (..), getOpts)
+import qualified Data.Map           as M
 import qualified Data.Text          as T
 import           Intlc.Compiler     (compileDataset, compileFlattened)
 import           Intlc.Core
+import           Intlc.Linter
 import           Intlc.Parser       (parseDataset, printErr)
 import           Intlc.Parser.Error (ParseFailure)
 import           Prelude
 
 main :: IO ()
 main = getOpts >>= \case
   Compile path loc -> tryCompile loc =<< getParsed path
-  Flatten path -> either parserDie (putTextLn . compileFlattened) =<< getParsed path
+  Flatten path     -> either parserDie (putTextLn . compileFlattened) =<< getParsed path
+  Lint    path     -> either parserDie lint =<< getParsed path
+    where lint = exit . M.mapMaybe (statusToMaybe . lintExternal . message)
+          exit sts
+            | M.size sts > 0 = die . T.unpack . ("Errors\n" <>) . M.foldrWithKey mkLine mempty $ sts
+            | otherwise = pure ()
+          mkLine k es acc = acc <> "\n" <> k <> ": " <> e
+            where e = T.intercalate ", " . toList . fmap show $ es
   where tryCompile l = either parserDie (either compilerDie putTextLn . compileDataset l)
         parserDie = die . printErr
         compilerDie = die . T.unpack . ("Invalid keys:\n" <>) . T.intercalate "\n" . fmap ("\t" <>) . toList

internal/CLI.hs

@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Use newtype instead of data" #-}
-
 module CLI (Opts (..), getOpts) where
 
 import           Options.Applicative

internal/Main.hs

@@ -26,13 +26,13 @@ main = getOpts >>= \case
     expandPlurals' = putTextLn . compileDataset . fmap (\x -> x { message = expandPlurals (message x) })
 
     lint' :: Dataset Translation -> IO ()
-    lint' = exit . M.mapMaybe (statusToMaybe . lint . message)
+    lint' = exit . M.mapMaybe (statusToMaybe . lintInternal . message)
 
-    exit :: Dataset (NonEmpty LintingError) -> IO ()
+    exit :: Dataset (NonEmpty InternalLint) -> 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 :: Text -> NonEmpty InternalLint -> Text -> Text
     mkLine k es acc = acc <> "\n" <> k <> ": " <> e
       where e = T.intercalate ", " . toList . fmap show $ es

intlc.cabal

@@ -23,6 +23,7 @@ common common
     , optics               ^>=0.4
     , relude               ^>=1.0
     , text                 ^>=1.2
+    , these                ^>=1.1
     , validation           ^>=1.1
   mixins:
       base hiding (Prelude)

lib/Intlc/Backend/ICU/Compiler.hs

@@ -8,8 +8,9 @@
 
 module Intlc.Backend.ICU.Compiler where
 
+import           Data.These (These (..), mergeTheseWith)
 import           Intlc.ICU
-import           Prelude   hiding (Type)
+import           Prelude    hiding (Type)
 
 compileMsg :: Message -> Text
 compileMsg (Message xs) = stream xs
@@ -30,7 +31,7 @@ interp n (Time fmt)                   = "{" <> n <> ", time, "          <> dateT
 interp n (Plural (Cardinal p))        = "{" <> n <> ", plural, "        <> cardinalPlural p <> "}"
 interp n (Plural (Ordinal p))         = "{" <> n <> ", selectordinal, " <> ordinalPlural p  <> "}"
 interp _ PluralRef                    = "#"
-interp n (Select xs y)                = "{" <> n <> ", select, "        <> select xs y      <> "}"
+interp n (Select x)                   = "{" <> n <> ", select, "        <> select x         <> "}"
 interp n (Callback xs)                = "<" <> n <> ">"                 <> stream xs        <> "</" <> n <> ">"
 
 dateTimeFmt :: DateTimeFmt -> Text
@@ -64,7 +65,7 @@ pluralRule Many = "many"
 pluralWildcard :: PluralWildcard -> Text
 pluralWildcard (PluralWildcard xs) = "other {" <> stream xs <> "}"
 
-select :: NonEmpty SelectCase -> Maybe SelectWildcard -> Text
-select xs mw = unwords . toList $ (case' <$> toList xs) <> foldMap (pure . wild) mw
+select :: These (NonEmpty SelectCase) SelectWildcard -> Text
+select = unwords . mergeTheseWith (toList . fmap case') (pure . wild) (<>)
   where case' (SelectCase n ys) = n <> " {" <> stream ys <> "}"
         wild (SelectWildcard ys) = "other {" <> stream ys <> "}"

lib/Intlc/Backend/JavaScript/Language.hs

@@ -1,5 +1,6 @@
 module Intlc.Backend.JavaScript.Language where
 
+import           Data.These (These (..))
 import           Intlc.Core (Locale)
 import qualified Intlc.ICU  as ICU
 import           Prelude
@@ -33,7 +34,7 @@ data MatchCond
 
 data MatchRet
   = LitMatchRet (NonEmpty Branch)
-  | NonLitMatchRet (NonEmpty Branch) Wildcard
+  | NonLitMatchRet [Branch] Wildcard
   | RecMatchRet (NonEmpty Branch) Match
   deriving (Show, Eq)
 
@@ -60,32 +61,37 @@ fromInterp nraw t =
       x <- fromBoolCase True trueCase
       y <- fromBoolCase False falseCase
       pure . TMatch . Match n LitCond . LitMatchRet $ x :| [y]
-    ICU.String             -> pure $ TStr n
-    ICU.Number             -> pure $ TNum n
-    ICU.Date x             -> pure $ TDate n x
-    ICU.Time x             -> pure $ TTime n x
-    ICU.Plural x           -> TMatch <$> fromPlural n x
-    ICU.PluralRef          -> pure $ TNum n
-    ICU.Select cs (Just w) -> ((TMatch . Match n LitCond) .) . NonLitMatchRet <$> (fromSelectCase `mapM` cs) <*> fromSelectWildcard w
-    ICU.Select cs Nothing  -> TMatch . Match n LitCond . LitMatchRet <$> (fromSelectCase `mapM` cs)
-    ICU.Callback xs        -> TApply n <$> (fromToken `mapM` xs)
+    ICU.String      -> pure $ TStr n
+    ICU.Number      -> pure $ TNum n
+    ICU.Date x      -> pure $ TDate n x
+    ICU.Time x      -> pure $ TTime n x
+    ICU.Plural x    -> TMatch <$> fromPlural n x
+    ICU.PluralRef   -> pure $ TNum n
+    ICU.Select x    -> case x of
+      (This cs)    -> TMatch . Match n LitCond . LitMatchRet <$> ret
+        where ret = fromSelectCase `mapM` cs
+      (That w)     -> TMatch . Match n LitCond <$> ret
+        where ret = NonLitMatchRet mempty <$> fromSelectWildcard w
+      (These cs w) -> TMatch . Match n LitCond <$> ret
+        where ret = NonLitMatchRet <$> (toList <$> fromSelectCase `mapM` cs) <*> fromSelectWildcard w
+    ICU.Callback xs -> TApply n <$> (fromToken `mapM` xs)
   where n = Ref nraw
 
 fromPlural :: Ref -> ICU.Plural -> ASTCompiler Match
 fromPlural r p = case p of
   ICU.Cardinal (ICU.LitPlural lcs mw)            -> Match r LitCond <$> case mw of
     Nothing -> LitMatchRet    <$> (fromExactPluralCase `mapM` lcs)
-    Just w  -> NonLitMatchRet <$> (fromExactPluralCase `mapM` lcs) <*> fromPluralWildcard w
+    Just w  -> NonLitMatchRet <$> (toList <$> fromExactPluralCase `mapM` lcs) <*> fromPluralWildcard w
   ICU.Cardinal (ICU.RulePlural rcs w)            -> Match r CardinalPluralRuleCond <$> m
-    where m = NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w
+    where m = NonLitMatchRet <$> (toList <$> fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w
   ICU.Cardinal (ICU.MixedPlural lcs rcs w)       -> Match r LitCond <$> m
     where m = RecMatchRet <$> (fromExactPluralCase `mapM` lcs) <*> (Match r CardinalPluralRuleCond <$> im)
-          im = NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w
+          im = NonLitMatchRet <$> (toList <$> fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w
   ICU.Ordinal (ICU.OrdinalPlural [] rcs w)       -> Match r OrdinalPluralRuleCond <$> m
-    where m = NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w
+    where m = NonLitMatchRet <$> (toList <$> fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w
   ICU.Ordinal (ICU.OrdinalPlural (lc:lcs) rcs w) -> Match r LitCond <$> m
     where m = RecMatchRet <$> ((:|) <$> fromExactPluralCase lc <*> (fromExactPluralCase `mapM` lcs)) <*> im
-          im = Match r OrdinalPluralRuleCond <$> (NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w)
+          im = Match r OrdinalPluralRuleCond <$> (NonLitMatchRet <$> (toList <$> fromRulePluralCase `mapM` rcs) <*> fromPluralWildcard w)
 
 fromExactPluralCase :: ICU.PluralCase ICU.PluralExact -> ASTCompiler Branch
 fromExactPluralCase (ICU.PluralCase (ICU.PluralExact n) xs) = Branch n <$> (fromToken `mapM` xs)

lib/Intlc/Backend/TypeScript/Language.hs

@@ -2,6 +2,7 @@ module Intlc.Backend.TypeScript.Language where
 
 import           Data.List.NonEmpty (nub)
 import qualified Data.Map           as M
+import           Data.These         (These (..))
 import qualified Intlc.ICU          as ICU
 import           Prelude
 
@@ -48,21 +49,21 @@ fromToken ICU.Plaintext {}        = mempty
 fromToken (ICU.Interpolation x y) = fromInterp x y
 
 fromInterp :: Text -> ICU.Type -> UncollatedArgs
-fromInterp n (ICU.Bool xs ys)   = (n, TBool) : (fromToken =<< xs) <> (fromToken =<< ys)
-fromInterp n ICU.String         = pure (n, TStr)
-fromInterp n ICU.Number         = pure (n, TNum)
-fromInterp n ICU.Date {}        = pure (n, TDate)
-fromInterp n ICU.Time {}        = pure (n, TDate)
-fromInterp n (ICU.Plural x)     = fromPlural n x
+fromInterp n (ICU.Bool xs ys)  = (n, TBool) : (fromToken =<< xs) <> (fromToken =<< ys)
+fromInterp n ICU.String        = pure (n, TStr)
+fromInterp n ICU.Number        = pure (n, TNum)
+fromInterp n ICU.Date {}       = pure (n, TDate)
+fromInterp n ICU.Time {}       = pure (n, TDate)
+fromInterp n (ICU.Plural x)    = fromPlural n x
 -- Plural references are treated as a no-op.
-fromInterp _ ICU.PluralRef      = mempty
-fromInterp n (ICU.Select cs mw) = (n, t) : (fromSelectCase =<< toList cs) <> foldMap fromSelectWildcard mw
+fromInterp _ ICU.PluralRef     = mempty
+fromInterp n (ICU.Select x)    = case x of
+  (That w)     -> (n, TStr) : fromSelectWildcard w
+  (These cs w) -> (n, TStr) : (fromSelectCase =<< toList cs) <> fromSelectWildcard w
   -- When there's no wildcard case we can compile to a union of string literals.
-  where t = case mw of
-              Just _  -> TStr
-              Nothing -> TStrLitUnion $ caseLit <$> cs
-        caseLit (ICU.SelectCase x _) = x
-fromInterp n (ICU.Callback xs)  = (n, TEndo) : (fromToken =<< xs)
+  (This cs)    -> (n, TStrLitUnion (lit <$> cs)) : (fromSelectCase =<< toList cs)
+    where lit (ICU.SelectCase l _) = l
+fromInterp n (ICU.Callback xs) = (n, TEndo) : (fromToken =<< xs)
 
 fromPlural :: Text -> ICU.Plural -> UncollatedArgs
 fromPlural n (ICU.Cardinal (ICU.LitPlural ls mw))      = (n, t) : (fromExactPluralCase =<< toList ls) <> foldMap fromPluralWildcard mw

lib/Intlc/Compiler.hs

@@ -5,6 +5,7 @@ import           Data.Foldable                     (elem)
 import           Data.List.Extra                   (firstJust, unionBy)
 import qualified Data.Map                          as M
 import qualified Data.Text                         as T
+import           Data.These                        (These (..))
 import           Intlc.Backend.JavaScript.Compiler as JS
 import qualified Intlc.Backend.JSON.Compiler       as JSON
 import qualified Intlc.Backend.TypeScript.Compiler as TS
@@ -37,7 +38,7 @@ compileTranslation l k (Translation v be _) = case be of
   TypeScriptReact -> TS.compileNamedExport JSX         l k v
 
 type ICUBool = (ICU.Stream, ICU.Stream)
-type ICUSelect = (NonEmpty ICU.SelectCase, Maybe ICU.SelectWildcard)
+type ICUSelect = These (NonEmpty ICU.SelectCase) ICU.SelectWildcard
 
 compileFlattened :: Dataset Translation -> Text
 compileFlattened = JSON.compileDataset . mapMsgs flatten
@@ -52,11 +53,11 @@ mapTokens :: (ICU.Token -> ICU.Token) -> ICU.Stream -> ICU.Stream
 mapTokens f = fmap $ f >>> \case
   x@(ICU.Plaintext {})      -> x
   x@(ICU.Interpolation n t) -> case t of
-    ICU.Bool xs ys   -> g $ ICU.Bool (h xs) (h ys)
-    ICU.Plural y     -> g . ICU.Plural $ mapPluralStreams h y
-    ICU.Select ys mz -> g . uncurry ICU.Select $ mapSelectStreams h (ys, mz)
-    ICU.Callback ys  -> g . ICU.Callback . h $ ys
-    _                -> x
+    ICU.Bool xs ys  -> g $ ICU.Bool (h xs) (h ys)
+    ICU.Plural y    -> g . ICU.Plural $ mapPluralStreams h y
+    ICU.Select y    -> g . ICU.Select $ mapSelectStreams h y
+    ICU.Callback ys -> g . ICU.Callback . h $ ys
+    _               -> x
     where g = ICU.Interpolation n
           h = fmap f
 
@@ -69,8 +70,8 @@ flatten (ICU.Message xs) = ICU.Message . flattenStream $ xs
           , mapPlural <$> extractFirstPlural ys
           ]
         mapBool (n, ls, boo, rs) = streamFromArg n . uncurry ICU.Bool $ mapBoolStreams (around ls rs) boo
-        mapSelect (n, ls, sel, rs) = streamFromArg n . uncurry ICU.Select $ mapSelectStreams (around ls rs) sel
-        mapPlural (n, ls, plu, rs) = streamFromArg n .         ICU.Plural $ mapPluralStreams (around ls rs) plu
+        mapSelect (n, ls, sel, rs) = streamFromArg n . ICU.Select $ mapSelectStreams (around ls rs) sel
+        mapPlural (n, ls, plu, rs) = streamFromArg n . ICU.Plural $ mapPluralStreams (around ls rs) plu
         around ls rs = flattenStream . ICU.mergePlaintext . surround ls rs
         surround ls rs cs = ls <> cs <> rs
         streamFromArg n = pure . ICU.Interpolation n
@@ -119,8 +120,8 @@ extractFirstArg f xs = firstJust arg (zip [0..] xs)
 
 extractFirstSelect :: ICU.Stream -> Maybe (Text, ICU.Stream, ICUSelect, ICU.Stream)
 extractFirstSelect = extractFirstArg $ \case
-  ICU.Select xs y -> Just (xs, y)
-  _               -> Nothing
+  ICU.Select x -> Just x
+  _            -> Nothing
 
 extractFirstPlural :: ICU.Stream -> Maybe (Text, ICU.Stream, ICU.Plural, ICU.Stream)
 extractFirstPlural = extractFirstArg $ \case
@@ -131,7 +132,7 @@ mapBoolStreams :: (ICU.Stream -> ICU.Stream) -> ICUBool -> ICUBool
 mapBoolStreams f (xs, ys) = (f xs, f ys)
 
 mapSelectStreams :: (ICU.Stream -> ICU.Stream) -> ICUSelect -> ICUSelect
-mapSelectStreams f (xs, mw) = (mapSelectCase f <$> xs, mapSelectWildcard f <$> mw)
+mapSelectStreams f = bimap (fmap (mapSelectCase f)) (mapSelectWildcard f)
 
 mapSelectCase :: (ICU.Stream -> ICU.Stream) -> ICU.SelectCase -> ICU.SelectCase
 mapSelectCase f (ICU.SelectCase x ys) = ICU.SelectCase x (f ys)

lib/Intlc/ICU.hs

@@ -5,7 +5,8 @@
 
 module Intlc.ICU where
 
-import           Prelude hiding (Type)
+import           Data.These (These (..), mergeTheseWith)
+import           Prelude    hiding (Type)
 
 newtype Message = Message Stream
   deriving (Show, Eq)
@@ -39,11 +40,9 @@ getStream (Interpolation _ t) = case t of
   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
+  Select x                   -> Just . mergeTheseWith (concatMap f) g (<>) $ x
+    where f (SelectCase _ xs)  = xs
+          g (SelectWildcard w) = w
   Callback xs                -> Just xs
 
 getPluralStream :: Plural -> Stream
@@ -90,7 +89,7 @@ data Type
   -- Plural hash references have their own distinct type rather than merely
   -- taking on `Number` to allow compilers to infer appropriately.
   | PluralRef
-  | Select (NonEmpty SelectCase) (Maybe SelectWildcard)
+  | Select (These (NonEmpty SelectCase) SelectWildcard)
   | Callback Stream
   deriving (Show, Eq)