[ADP-3179] Add package linting command (#34)

- [x] add a function to resolve the unused import
- [x] add a `lint` sub command that works on packages and fail in case
redundant imports are found
ADP-3179

lib/fine-types/app/Commands/Lint.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Commands.Lint
+    ( lint
+    ) where
+
+import Prelude
+
+import Commands.Check.PrettyPrinter
+    ( renderCompilePackageError
+    , renderParsePackageError
+    )
+import Commands.Common (readInput)
+import Commands.Log (inside)
+import Control.Tracer (Tracer, traceWith)
+import Data.Maybe (fromMaybe)
+import Language.FineTypes.Module (redundantImports)
+import Language.FineTypes.Package
+    ( Package (..)
+    , compilePackageDescription
+    , parsePackageDescription
+    )
+import Options.Lint (LintOptions (..))
+import System.Exit (exitFailure)
+
+import Data.Foldable (toList)
+import qualified Data.Map as Map
+
+lint :: Tracer IO String -> LintOptions -> IO ()
+lint tracer LintOptions{..} = do
+    let trace = traceWith tracer
+    package <- readInput (inside "readInput" tracer) optInput
+    trace
+        $ "Linting "
+            <> fromMaybe "<stdin>" optInput
+    case parsePackageDescription package of
+        Left e -> do
+            trace "Failed to parse input file:"
+            trace $ renderParsePackageError e
+            exitFailure
+        Right pd -> do
+            r <- compilePackageDescription optDir pd
+            case r of
+                Left e -> do
+                    trace "Failed to compile package description:"
+                    trace $ renderCompilePackageError e
+                    exitFailure
+                Right (Package ms) -> do
+                    rs <- sequence $ do
+                        (mname, module') <- Map.assocs ms
+                        (imodule, iname) <- toList $ redundantImports module'
+                        pure
+                            $ traceWith
+                                (inside ("module " <> mname) tracer)
+                            $ "Redundant import: "
+                                <> imodule
+                                <> "("
+                                <> iname
+                                <> ")"
+                    case rs of
+                        [] -> trace "Success!"
+                        _ -> exitFailure

lib/fine-types/app/Main.hs

@@ -2,21 +2,22 @@
 
 import Prelude
 
+import Commands.Check (check)
+import Commands.Convert (convert)
+import Commands.Lint (lint)
+import Commands.Log (inside, withLogPutLn)
 import Main.Utf8 (withUtf8)
 import Options
     ( Commands (..)
     , Options (..)
     , parseOptions
     )
 
-import Commands.Check (check)
-import Commands.Convert (convert)
-import Commands.Log (inside, withLogPutLn)
-
 main :: IO ()
 main = withUtf8 $ do
     Options{..} <- parseOptions
     withLogPutLn optLogFile $ \tracer ->
         case optCommand of
             Convert co -> convert (inside "convert" tracer) co
             Check co -> check (inside "check" tracer) co
+            Lint co -> lint (inside "lint" tracer) co

lib/fine-types/app/Options.hs

@@ -18,14 +18,15 @@ import Options.Applicative
     )
 import Options.Check (CheckOptions, checkDescr, checkOptions)
 import Options.Convert (ConvertOptions, convertDescr, convertOptions)
+import Options.Lint (LintOptions (..), lintDescr, lintOptions)
 import Options.Log (LogFile, optionLogFile)
 
 data Options = Options
     { optCommand :: Commands
     , optLogFile :: LogFile
     }
 
-data Commands = Convert ConvertOptions | Check CheckOptions
+data Commands = Convert ConvertOptions | Check CheckOptions | Lint LintOptions
 
 parseOptions :: IO Options
 parseOptions =
@@ -45,5 +46,7 @@ commands =
                 $ info (Convert <$> convertOptions) convertDescr
             , command "check"
                 $ info (Check <$> checkOptions) checkDescr
+            , command "lint"
+                $ info (Lint <$> lintOptions) lintDescr
                 -- other commands go here
             ]

lib/fine-types/app/Options/Check.hs

@@ -8,15 +8,9 @@ import Options.Applicative
     ( InfoMod
     , Parser
     , header
-    , help
-    , long
-    , metavar
     , progDesc
-    , short
-    , strOption
-    , value
     )
-import Options.Common (inputOption)
+import Options.Common (dirOption, inputOption)
 
 data CheckOptions = CheckOptions
     { optInput :: Maybe FilePath
@@ -32,15 +26,3 @@ checkDescr =
 
 checkOptions :: Parser CheckOptions
 checkOptions = CheckOptions <$> inputOption <*> dirOption
-
-dirOption :: Parser FilePath
-dirOption =
-    strOption
-        ( mconcat
-            [ long "dir"
-            , short 'd'
-            , metavar "DIR"
-            , help "Directory where modules are located"
-            , value "."
-            ]
-        )

lib/fine-types/app/Options/Common.hs

@@ -14,6 +14,7 @@ import Options.Applicative
     , metavar
     , option
     , short
+    , strOption
     , value
     )
 
@@ -41,3 +42,15 @@ outputOption =
 fileReader :: ReadM (Maybe FilePath)
 fileReader = eitherReader $ \case
     file -> Right $ Just file
+
+dirOption :: Parser FilePath
+dirOption =
+    strOption
+        ( mconcat
+            [ long "dir"
+            , short 'd'
+            , metavar "DIR"
+            , help "Directory where modules are located"
+            , value "."
+            ]
+        )

lib/fine-types/app/Options/Lint.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use <$>" #-}
+
+module Options.Lint
+    ( LintOptions (..)
+    , lintDescr
+    , lintOptions
+    )
+where
+
+import Prelude
+
+import Options.Applicative
+    ( InfoMod
+    , Parser
+    , header
+    , progDesc
+    )
+import Options.Common (dirOption, inputOption)
+
+data LintOptions = LintOptions
+    { optInput :: Maybe FilePath
+    , optDir :: FilePath
+    }
+
+lintDescr :: InfoMod a
+lintDescr =
+    mconcat
+        [ progDesc "Lint a fine-types package"
+        , header "fine-types lint - lint a fine-types package"
+        ]
+
+lintOptions :: Parser LintOptions
+lintOptions = do
+    input <- inputOption
+    dir <- dirOption
+    pure $ LintOptions input dir

lib/fine-types/fine-types.cabal

@@ -141,9 +141,11 @@ executable fine-types
     , aeson-pretty
     , base
     , bytestring
+    , containers
     , contra-tracer
     , megaparsec
     , optparse-applicative
+    , transformers
     , fine-types
     , prettyprinter
     , with-utf8
@@ -153,9 +155,11 @@ executable fine-types
     Commands.Check.PrettyPrinter
     Commands.Common
     Commands.Convert
+    Commands.Lint
     Commands.Log
     Options
     Options.Check
     Options.Common
     Options.Convert
+    Options.Lint
     Options.Log

lib/fine-types/src/Language/FineTypes/Module.hs

@@ -21,12 +21,14 @@ module Language.FineTypes.Module
     , resolveImports
     , collectNotInScope
     , resolveVars
+    , redundantImports
     ) where
 
 import Prelude
 
 import Control.Monad
     ( forM
+    , guard
     )
 import Data.Map
     ( Map
@@ -157,10 +159,14 @@ collectNotInScope :: Module -> Set TypName
 collectNotInScope Module{moduleDeclarations, moduleImports} =
     needed Set.\\ defined
   where
+    defined :: Set TypName
     defined = declaredNames <> importedNames
+
+    declaredNames, importedNames :: Set TypName
     declaredNames = Map.keysSet moduleDeclarations
     importedNames = mconcat (getImportNames <$> Map.elems moduleImports)
 
+    needed :: Set TypName
     needed = mconcat . map collectVars $ Map.elems moduleDeclarations
 
 -- | Collect all 'Var' in a 'Typ'.
@@ -169,3 +175,13 @@ collectVars = everything (<>) vars
   where
     vars (Var name) = Set.singleton name
     vars _ = Set.empty
+
+-- | Find all imports that are not needed.
+redundantImports :: Module -> Set (ModuleName, TypName)
+redundantImports Module{moduleImports, moduleDeclarations} =
+    let needed = mconcat . map collectVars $ Map.elems moduleDeclarations
+    in  Set.fromList $ do
+            (moduleName, ImportNames names) <- Map.toList moduleImports
+            name <- Set.toList names
+            guard $ name `Set.notMember` needed
+            pure (moduleName, name)