diff --git a/lib/fine-types/app/Commands/Lint.hs b/lib/fine-types/app/Commands/Lint.hs new file mode 100644 index 00000000..06c726e4 --- /dev/null +++ b/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 "" 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 diff --git a/lib/fine-types/app/Main.hs b/lib/fine-types/app/Main.hs index 529aba89..7129b11b 100644 --- a/lib/fine-types/app/Main.hs +++ b/lib/fine-types/app/Main.hs @@ -2,6 +2,10 @@ 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 (..) @@ -9,10 +13,6 @@ import Options , parseOptions ) -import Commands.Check (check) -import Commands.Convert (convert) -import Commands.Log (inside, withLogPutLn) - main :: IO () main = withUtf8 $ do Options{..} <- parseOptions @@ -20,3 +20,4 @@ main = withUtf8 $ do case optCommand of Convert co -> convert (inside "convert" tracer) co Check co -> check (inside "check" tracer) co + Lint co -> lint (inside "lint" tracer) co diff --git a/lib/fine-types/app/Options.hs b/lib/fine-types/app/Options.hs index dbd549f9..38072211 100644 --- a/lib/fine-types/app/Options.hs +++ b/lib/fine-types/app/Options.hs @@ -18,6 +18,7 @@ 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 @@ -25,7 +26,7 @@ data Options = Options , 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 ] diff --git a/lib/fine-types/app/Options/Check.hs b/lib/fine-types/app/Options/Check.hs index b6b0975d..8b16a6db 100644 --- a/lib/fine-types/app/Options/Check.hs +++ b/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 "." - ] - ) diff --git a/lib/fine-types/app/Options/Common.hs b/lib/fine-types/app/Options/Common.hs index f14dd6bf..27e52c9c 100644 --- a/lib/fine-types/app/Options/Common.hs +++ b/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 "." + ] + ) diff --git a/lib/fine-types/app/Options/Lint.hs b/lib/fine-types/app/Options/Lint.hs new file mode 100644 index 00000000..2ebcc074 --- /dev/null +++ b/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 diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal index faa0f831..048904fa 100644 --- a/lib/fine-types/fine-types.cabal +++ b/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 diff --git a/lib/fine-types/src/Language/FineTypes/Module.hs b/lib/fine-types/src/Language/FineTypes/Module.hs index 40f9e568..6513f536 100644 --- a/lib/fine-types/src/Language/FineTypes/Module.hs +++ b/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)