@@ -8,7 +8,7 @@ import Prelude.Compat
88
99import qualified Data.Map as M
1010import Data.Maybe (mapMaybe)
11−import Data.List ((\\), find)
11+import Data.List ((\\), find, intersect)
1212import Control.Monad.Error.Class (MonadError(..))
1313import Control.Monad.Writer.Class
1414import Control.Monad(unless,when)
@@ -35,33 +35,70 @@ type UsedImports = M.Map ModuleName [Name]
3535-- or references in an explicit import list.
3636--
3737findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()
38−findUnusedImports (Module _ _ _ mdecls _) env usedImps = do
38+findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do
3939 imps <- findImports mdecls
40− forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` autoIncludes) $
41− forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $
42− let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames ++ M.findWithDefault [] mni usedImps in
43− case declType of
44− Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni
45− Explicit declrefs -> do
46− let idents = mapMaybe runDeclRef declrefs
47− let diff = idents \\ usedNames
48− unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff
49− _ -> return ()
40+ forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $
41+ forM_ decls $ \(ss, declType, qualifierName) ->
42+ censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $
43+ let names = sugarNames mni ++ M.findWithDefault [] mni usedImps
44+ usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
45+ usedDctors = mapMaybe (matchDctor qualifierName) names
46+ in case declType of
47+ Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni
48+ Explicit declrefs -> do
49+ let idents = mapMaybe runDeclRef declrefs
50+ let diff = idents \\ usedNames
51+ case (length diff, length idents) of
52+ (0, _) -> return ()
53+ (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni
54+ _ -> tell $ errorMessage $ UnusedExplicitImport mni diff
55+
56+ -- If we've not already warned a type is unused, check its data constructors
57+ forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
58+ let allCtors = dctorsForType mni tn
59+ when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of
60+ (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn
61+ (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn
62+ (Just ctors, _) ->
63+ let ddiff = ctors \\ usedDctors
64+ in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
65+ _ -> return ()
66+ return ()
67+
68+ _ -> return ()
5069 where
51− sugarNames :: [ Name ]
52− sugarNames = [ IdentName $ Qualified Nothing (Ident C.bind) ]
70+ sugarNames :: ModuleName -> [ Name ]
71+ sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]
72+ sugarNames _ = []
73+
74+ -- rely on exports being elaborated by this point
75+ alwaysUsedModules :: [ ModuleName ]
76+ alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports
77+ where
78+ isExport (ModuleRef mn) = Just mn
79+ isExport _ = Nothing
80+
81+ qnameUsed :: Maybe ModuleName -> Bool
82+ qnameUsed (Just qn) = qn `elem` alwaysUsedModules
83+ qnameUsed Nothing = False
5384
54− autoIncludes :: [ ModuleName ]
55− autoIncludes = [ ModuleName [ProperName C.prim] ]
85+ dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]
86+ dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
87+
88+ dctorsForType :: ModuleName -> ProperName -> [ProperName]
89+ dctorsForType mn tn =
90+ maybe [] getDctors (find matches $ dtys mn)
91+ where
92+ matches ((ty, _),_) = ty == tn
93+ getDctors ((_,ctors),_) = ctors
5694
5795 typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName
5896 typeForDCtor mn pn =
59− getTy <$> find matches tys
97+ getTy <$> find matches (dtys mn)
6098 where
6199 matches ((_, ctors), _) = pn `elem` ctors
62100 getTy ((ty, _), _) = ty
63− tys :: [((ProperName, [ProperName]), ModuleName)]
64− tys = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
101+
65102
66103matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String
67104matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x
@@ -69,12 +106,21 @@ matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperNa
69106matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x
70107matchName _ _ _ = Nothing
71108
109+matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName
110+matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x
111+matchDctor _ _ = Nothing
112+
72113runDeclRef :: DeclarationRef -> Maybe String
73114runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref
74115runDeclRef (ValueRef ident) = Just $ showIdent ident
75116runDeclRef (TypeRef pn _) = Just $ runProperName pn
76117runDeclRef _ = Nothing
77118
119+getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])
120+getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref
121+getTypeRef (TypeRef pn x) = Just (pn, x)
122+getTypeRef _ = Nothing
123+
78124addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
79125addModuleLocError sp err =
80126 case sp of