Merge pull request purescript#1545 from nwolverson/unused-imports

garyb · garyb · commit 0281a04abf21 · 2015-11-01T01:45:42.000Z
Give warnings on unused imports (implicit and explicit)
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
@@ -36,6 +36,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
 - [@natefaubion](https://github.com/natefaubion) (Nathan Faubion) My existing contributions and all future contributions until further notice are Copyright Nathan Faubion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@nicodelpiano](https://github.com/nicodelpiano) (Nicolas Del Piano) My existing contributions and all future contributions until further notice are Copyright Nicolas Del Piano, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@nullobject](https://github.com/nullobject) (Josh Bassett) My existing contributions and all future contributions until further notice are Copyright Josh Bassett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
 - [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
diff --git a/purescript.cabal b/purescript.cabal
@@ -108,6 +108,7 @@ library
                      Language.PureScript.Kinds
                      Language.PureScript.Linter
                      Language.PureScript.Linter.Exhaustive
+                     Language.PureScript.Linter.Imports
                      Language.PureScript.Make
                      Language.PureScript.ModuleDependencies
                      Language.PureScript.Names
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -144,7 +144,9 @@ data SimpleErrorMessage
   | ClassOperator ProperName Ident
   | MisleadingEmptyTypeImport ModuleName ProperName
   | ImportHidingModule ModuleName
-  deriving Show
+  | UnusedImport ModuleName
+  | UnusedExplicitImport ModuleName [String]
+  deriving (Show)
 
 -- | Error message hints, providing more detailed information about failure.
 data ErrorMessageHint
@@ -280,6 +282,8 @@ errorCode em = case unwrapErrorMessage em of
   ClassOperator{} -> "ClassOperator"
   MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"
   ImportHidingModule{} -> "ImportHidingModule"
+  UnusedImport{} -> "UnusedImport"
+  UnusedExplicitImport{} -> "UnusedExplicitImport"
 
 -- |
 -- A stack trace for an error
@@ -688,6 +692,12 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
       paras [ line "An exhaustivity check was abandoned due to too many possible cases."
             , line "You may want to decompose your data types into smaller types."
             ]
+    renderSimpleErrorMessage (UnusedImport name) =
+      line $ "The import of module " ++ runModuleName name ++ " is redundant"
+
+    renderSimpleErrorMessage (UnusedExplicitImport name names) =
+      paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"
+            , indent $ paras $ map line names ]
 
     renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
     renderHint (ErrorUnifyingTypes t1 t2) detail =
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
@@ -36,6 +36,7 @@ import Language.PureScript.Names
 import Language.PureScript.Errors
 import Language.PureScript.Types
 import Language.PureScript.Linter.Exhaustive as L
+import Language.PureScript.Linter.Imports as L
 
 -- | Lint the PureScript AST.
 -- |
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+
+module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where
+
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe)
+import Data.List ((\\), find)
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class
+import Control.Monad(unless,when)
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Data.Foldable (forM_)
+
+import Language.PureScript.AST.Declarations
+import Language.PureScript.AST.SourcePos
+import Language.PureScript.Names as P
+
+import Language.PureScript.Errors
+import Language.PureScript.Sugar.Names.Env
+import Language.PureScript.Sugar.Names.Imports
+
+import qualified Language.PureScript.Constants as C
+
+-- | Imported name used in some type or expression.
+data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) | DctorName (Qualified ProperName)
+
+-- | Map of module name to list of imported names from that module which have been used.
+type UsedImports = M.Map ModuleName [Name]
+
+-- |
+-- Find and warn on any unused import statements (qualified or unqualified)
+-- or references in an explicit import list.
+--
+findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()
+findUnusedImports (Module _ _ _ mdecls _) env usedImps = do
+  imps <- findImports mdecls
+  forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` autoIncludes) $
+    forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $
+      let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames ++ M.findWithDefault [] mni usedImps in
+      case declType of
+        Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni
+        Explicit declrefs -> do
+          let idents = mapMaybe runDeclRef declrefs
+          let diff = idents \\ usedNames
+          unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff
+        _ -> return ()
+  where
+  sugarNames :: [ Name ]
+  sugarNames = [ IdentName $ Qualified Nothing (Ident C.bind) ]
+
+  autoIncludes :: [ ModuleName ]
+  autoIncludes = [ ModuleName [ProperName C.prim] ]
+
+  typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName
+  typeForDCtor mn pn =
+    getTy <$> find matches tys
+    where
+      matches ((_, ctors), _) = pn `elem` ctors
+      getTy ((ty, _), _) = ty
+      tys :: [((ProperName, [ProperName]), ModuleName)]
+      tys = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
+
+matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String
+matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x
+matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x
+matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x
+matchName _ _ _ = Nothing
+
+runDeclRef :: DeclarationRef -> Maybe String
+runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref
+runDeclRef (ValueRef ident) = Just $ showIdent ident
+runDeclRef (TypeRef pn _) = Just $ runProperName pn
+runDeclRef _ = Nothing
+
+addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
+addModuleLocError sp err =
+  case sp of
+    Just pos -> withPosition pos err
+    _ -> err
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
@@ -28,6 +28,7 @@ import Control.Applicative (Applicative(..), (<$>), (<*>))
 import Control.Monad
 import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.Writer (MonadWriter(..), censor)
+import Control.Monad.State.Lazy
 
 import qualified Data.Map as M
 
@@ -41,6 +42,7 @@ import Language.PureScript.Externs
 import Language.PureScript.Sugar.Names.Env
 import Language.PureScript.Sugar.Names.Imports
 import Language.PureScript.Sugar.Names.Exports
+import Language.PureScript.Linter.Imports
 
 -- |
 -- Replaces all local names with qualified names within a list of modules. The
@@ -103,9 +105,11 @@ desugarImports externs modules = do
 
   renameInModule' :: Env -> Module -> m Module
   renameInModule' env m@(Module _ _ mn _ _) =
-    rethrow (addHint (ErrorInModule mn)) $ do
+    warnAndRethrow (addHint (ErrorInModule mn)) $ do
       let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env
-      elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)
+      (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)
+      findUnusedImports m env used
+      return $ elaborateImports imps m'
 
 -- |
 -- Make all exports for a module explicit. This may still effect modules that
@@ -146,10 +150,11 @@ elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls'
 -- Replaces all local names with qualified names within a module and checks that all existing
 -- qualified names are valid.
 --
-renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> Imports -> Module -> m Module
+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module
 renameInModule env imports (Module ss coms mn decls exps) =
   Module ss coms mn <$> parU decls go <*> pure exps
   where
+
   (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
 
   updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
@@ -168,7 +173,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
   updateDecl (pos, bound) (ExternDeclaration name ty) =
     (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)
   updateDecl s d = return (s, d)
-
+  --
   updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
   updateValue (_, bound) v@(PositionedValue pos' _ _) =
     return ((Just pos', bound), v)
@@ -189,7 +194,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
   updateValue s@(pos, _) (TypedValue check val ty) =
     (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
   updateValue s v = return (s, v)
-
+  --
   updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
   updateBinder (_, bound) v@(PositionedBinder pos _ _) =
     return ((Just pos, bound), v)
@@ -201,8 +206,8 @@ renameInModule env imports (Module ss coms mn decls exps) =
     return (s', TypedBinder t' b')
   updateBinder s v =
     return (s, v)
-
-  updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
+  --
+  updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative ->  m ((Maybe SourceSpan, [Ident]), CaseAlternative)
   updateCase (pos, bound) c@(CaseAlternative bs _) =
     return ((pos, concatMap binderNames bs ++ bound), c)
 
@@ -223,16 +228,16 @@ renameInModule env imports (Module ss coms mn decls exps) =
   updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
 
   updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
-  updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes)
+  updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName
 
   updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
-  updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes)
+  updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName
 
   updateClassName  :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
-  updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses)
+  updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName
 
   updateValueName  :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
-  updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues)
+  updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName
 
   -- Used when performing an update to qualify values and classes with their
   -- module of original definition.
@@ -255,16 +260,22 @@ renameInModule env imports (Module ss coms mn decls exps) =
   update :: (Ord a) => (Qualified a -> SimpleErrorMessage)
                        -> M.Map (Qualified a) (Qualified a, ModuleName)
                        -> (Exports -> a -> Maybe (Qualified a))
+                       -> (Qualified a -> Name)
                        -> Qualified a
                        -> Maybe SourceSpan
                        -> m (Qualified a)
-  update unknown imps getE qname@(Qualified mn' name) pos = positioned $
+  update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $
     case (M.lookup qname imps, mn') of
       -- We found the name in our imports, so we return the name for it,
       -- qualifying with the name of the module it was originally defined in
       -- rather than the module we're importing from, to handle the case of
       -- re-exports.
-      (Just (_, mnOrig), _) -> return $ Qualified (Just mnOrig) name
+      (Just (qn, mnOrig), _) -> do
+        case qn of
+          Qualified (Just mnNew) _ ->
+            modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
+          _ -> return ()
+        return $ Qualified (Just mnOrig) name
       -- If the name wasn't found in our imports but was qualified then we need
       -- to check whether it's a failed import from a "pseudo" module (created
       -- by qualified importing). If that's not the case, then we just need to
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -19,6 +19,7 @@
 module Language.PureScript.Sugar.Names.Imports
   ( resolveImports
   , resolveModuleImport
+  , findImports
   ) where
 
 import Data.List (find)
@@ -40,8 +41,10 @@ import Language.PureScript.Names
 import Language.PureScript.Errors
 import Language.PureScript.Sugar.Names.Env
 
+-- |
 -- Finds the imports within a module, mapping the imported module name to an optional set of
 -- explicitly imported declarations.
+--
 findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
 findImports = foldM (go Nothing) M.empty
   where
