@@ -1,18 +1,23 @@
11{-# LANGUAGE ScopedTypeVariables #-}
22{-# LANGUAGE FlexibleContexts #-}
33
4−module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where
4+module Language.PureScript.Linter.Imports
5+ ( lintImports
6+ , Name(..)
7+ , UsedImports()
8+ ) where
59
610import Prelude ()
711import Prelude.Compat
812
9−import qualified Data.Map as M
10−import Data.Maybe (mapMaybe, isNothing)
11−import Data.List ((\\), find, intersect, nub)
13+import Control.Monad (unless, when)
1214import Control.Monad.Error.Class (MonadError(..))
1315import Control.Monad.Writer.Class
14−import Control.Monad (unless,when)
16+
1517import Data.Foldable (forM_)
18+import Data.List ((\\), find, intersect, nub)
19+import Data.Maybe (mapMaybe)
20+import qualified Data.Map as M
1621
1722import Language.PureScript.AST.Declarations
1823import Language.PureScript.AST.SourcePos
@@ -31,118 +36,247 @@ data Name
3136 | TyName (Qualified (ProperName 'TypeName))
3237 | DctorName (Qualified (ProperName 'ConstructorName))
3338 | TyClassName (Qualified (ProperName 'ClassName))
34− deriving (Eq)
39+ deriving (Eq, Show)
3540
36−getIdentName :: Name -> Maybe Ident
37−getIdentName (IdentName (Qualified _ name)) = Just name
38−getIdentName _ = Nothing
41+getIdentName :: Maybe ModuleName -> Name -> Maybe Ident
42+getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name
43+getIdentName _ _ = Nothing
3944
40−getTypeName :: Name -> Maybe (ProperName 'TypeName)
41−getTypeName (TyName (Qualified _ name)) = Just name
42−getTypeName _ = Nothing
45+getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)
46+getTypeName q (TyName (Qualified q' name)) | q == q' = Just name
47+getTypeName _ _ = Nothing
4348
44−getClassName :: Name -> Maybe (ProperName 'ClassName)
45−getClassName (TyClassName (Qualified _ name)) = Just name
46−getClassName _ = Nothing
49+getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)
50+getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name
51+getClassName _ _ = Nothing
4752
4853-- | Map of module name to list of imported names from that module which have been used.
4954type UsedImports = M.Map ModuleName [Name]
5055
5156-- |
52−-- Find and warn on any unused import statements (qualified or unqualified)
53−-- or references in an explicit import list.
57+-- Find and warn on:
58+--
59+-- * Unused import statements (qualified or unqualified)
60+--
61+-- * Unused references in an explicit import list
5462--
55−findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()
56−findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do
57− imps <- findImports mdecls
58− forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $
59− forM_ decls $ \(ss, declType, qualifierName) ->
60− censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $
61− let names = nub $ M.findWithDefault [] mni usedImps
62− usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
63− usedDctors = mapMaybe (matchDctor qualifierName) names
64− in case declType of
65− Implicit | isNothing qualifierName ->
66− let classRefs = TypeClassRef <$> mapMaybe getClassName names
67− valueRefs = ValueRef <$> mapMaybe getIdentName names
68− types = mapMaybe getTypeName names
69− typesWithDctors = reconstructTypeRefs mni usedDctors
70− typesWithoutDctors = filter (`M.notMember` typesWithDctors) types
71− typesRefs
72− = map (flip TypeRef (Just [])) typesWithoutDctors
73− ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)
74− allRefs = classRefs ++ typesRefs ++ valueRefs
75− in tell $ errorMessage $
76− if null allRefs
77− then UnusedImport mni
78− else ImplicitImport mni allRefs
79− Explicit [] -> tell $ errorMessage $ UnusedImport mni
80− Explicit declrefs -> do
81− let idents = nub (mapMaybe runDeclRef declrefs)
82− let diff = idents \\ usedNames
83− case (length diff, length idents) of
84− (0, _) -> return ()
85− (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni
86− _ -> tell $ errorMessage $ UnusedExplicitImport mni diff
87−
88− -- If we've not already warned a type is unused, check its data constructors
89− forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
90− let allCtors = dctorsForType mni tn
91− when (runProperName tn `elem` usedNames) $ case (c, usedDctors `intersect` allCtors) of
92− (_, []) | c /= Just [] ->
93− tell $ errorMessage $ UnusedDctorImport tn
94− (Just ctors, usedDctors') ->
95− let ddiff = ctors \\ usedDctors'
96− in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
97− _ -> return ()
98−
99− return ()
100−
101− _ -> return ()
63+-- * Implicit imports of modules
64+--
65+-- * Implicit imports into a virtual module (unless the virtual module only has
66+-- members from one module imported)
67+--
68+-- * Imports using `hiding` (this is another form of implicit importing)
69+--
70+lintImports
71+ :: forall m
72+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
73+ => Module
74+ -> Env
75+ -> UsedImports
76+ -> m ()
77+lintImports (Module _ _ mn mdecls mexports) env usedImps = do
78+
79+ let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)
80+ usedImps' = foldr (elaborateUsed scope) usedImps exportedModules
81+
82+ imps <- M.toAscList <$> findImports mdecls
83+
84+ forM_ imps $ \(mni, decls) ->
85+ unless (isPrim mni) $ do
86+ forM_ decls $ \(ss, declType, qualifierName) ->
87+ censor (onErrorMessages $ addModuleLocError ss) $ do
88+ let names = nub $ M.findWithDefault [] mni usedImps'
89+ lintImportDecl env mni qualifierName names declType
90+
91+ forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do
92+ let mnis = nub $ map (\(_, _, mni) -> mni) entries
93+ unless (length mnis == 1) $ do
94+ let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries
95+ forM_ implicits $ \(ss, _, mni) ->
96+ censor (onErrorMessages $ addModuleLocError ss) $ do
97+ let names = nub $ M.findWithDefault [] mni usedImps'
98+ usedRefs = findUsedRefs env mni (Just mnq) names
99+ unless (null usedRefs) $
100+ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs
101+
102+ return ()
103+
102104 where
103− reconstructTypeRefs :: ModuleName -> [ProperName 'ConstructorName] -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]
104− reconstructTypeRefs mni = foldr accumDctors M.empty
105− where
106− accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)
107105
108− findTypeForDctor :: ModuleName -> ProperName 'ConstructorName -> ProperName 'TypeName
109− findTypeForDctor mn dctor =
110− case mn `M.lookup` env of
111− Just (_, _, exps) ->
112− case find (elem dctor . snd . fst) (exportedTypes exps) of
113− Just ((ty, _), _) -> ty
114− Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"
115− Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"
106+ -- Checks whether a module is the Prim module - used to suppress any checks
107+ -- made, as Prim is always implicitly imported.
108+ isPrim :: ModuleName -> Bool
109+ isPrim = (== ModuleName [ProperName C.prim])
110+
111+ -- Creates a map of virtual modules mapped to all the declarations that
112+ -- import to that module, with the corresponding source span, import type,
113+ -- and module being imported
114+ byQual
115+ :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])]
116+ -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)]
117+ byQual = foldr goImp M.empty
118+ where
119+ goImp (mni, xs) acc = foldr (goDecl mni) acc xs
120+ goDecl mni (ss, declType, Just qmn) acc =
121+ let entry = (ss, declType, mni)
122+ in M.alter (Just . maybe [entry] (entry :)) qmn acc
123+ goDecl _ _ acc = acc
116124
117− -- rely on exports being elaborated by this point
118− alwaysUsedModules :: [ ModuleName ]
119− alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports
125+ -- The list of modules that are being re-exported by the current module. Any
126+ -- module that appears in this list is always considered to be used.
127+ exportedModules :: [ModuleName]
128+ exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports
120129 where
121130 extractModule (PositionedDeclarationRef _ _ r) = extractModule r
122− extractModule (ModuleRef mn) = Just mn
131+ extractModule (ModuleRef mne) = Just mne
123132 extractModule _ = Nothing
124133
125− qnameUsed :: Maybe ModuleName -> Bool
126− qnameUsed (Just qn) = qn `elem` alwaysUsedModules
127− qnameUsed Nothing = False
134+ -- Elaborates the UsedImports to include values from modules that are being
135+ -- re-exported. This ensures explicit export hints are printed for modules
136+ -- that are implicitly exported and then re-exported.
137+ elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports
138+ elaborateUsed scope mne used =
139+ let classes = extractByQual mne (importedTypeClasses scope) TyClassName
140+ types = extractByQual mne (importedTypes scope) TyName
141+ dctors = extractByQual mne (importedDataConstructors scope) DctorName
142+ values = extractByQual mne (importedValues scope) IdentName
143+ in foldr go used (classes ++ types ++ dctors ++ values)
144+ where
145+ go :: (ModuleName, Name) -> UsedImports -> UsedImports
146+ go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc
147+
148+ extractByQual
149+ :: (Eq a)
150+ => ModuleName
151+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]
152+ -> (Qualified a -> Name)
153+ -> [(ModuleName, Name)]
154+ extractByQual k m toName = mapMaybe go (M.toList m)
155+ where
156+ go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q =
157+ case fst (head is) of
158+ Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)
159+ _ -> internalError "unqualified name in extractByQual"
160+ go _ = Nothing
128161
129− dtys :: ModuleName -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
162+lintImportDecl
163+ :: forall m
164+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
165+ => Env
166+ -> ModuleName
167+ -> Maybe ModuleName
168+ -> [Name]
169+ -> ImportDeclarationType
170+ -> m ()
171+lintImportDecl env mni qualifierName names declType =
172+ case declType of
173+ Implicit -> case qualifierName of
174+ Nothing -> checkImplicit ImplicitImport
175+ Just q ->
176+ let usedModuleNames = mapMaybe extractQualName names
177+ in unless (q `elem` usedModuleNames) unused
178+ Hiding _ -> checkImplicit HidingImport
179+ Explicit [] -> unused
180+ Explicit declrefs -> checkExplicit declrefs
181+
182+ where
183+
184+ checkImplicit
185+ :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)
186+ -> m ()
187+ checkImplicit warning =
188+ let allRefs = findUsedRefs env mni qualifierName names
189+ in if null allRefs
190+ then unused
191+ else tell $ errorMessage $ warning mni allRefs
192+
193+ checkExplicit
194+ :: [DeclarationRef]
195+ -> m ()
196+ checkExplicit declrefs = do
197+ let idents = nub (mapMaybe runDeclRef declrefs)
198+ dctors = mapMaybe (matchDctor qualifierName) names
199+ usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
200+ diff = idents \\ usedNames
201+ case (length diff, length idents) of
202+ (0, _) -> return ()
203+ (n, m) | n == m -> unused
204+ _ -> tell $ errorMessage $ UnusedExplicitImport mni diff
205+
206+ -- If we've not already warned a type is unused, check its data constructors
207+ forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
208+ let allCtors = dctorsForType mni tn
209+ when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of
210+ (_, []) | c /= Just [] ->
211+ tell $ errorMessage $ UnusedDctorImport tn
212+ (Just ctors, dctors') ->
213+ let ddiff = ctors \\ dctors'
214+ in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
215+ _ -> return ()
216+ return ()
217+
218+ unused :: m ()
219+ unused = tell $ errorMessage $ UnusedImport mni
220+
221+ dtys
222+ :: ModuleName
223+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
130224 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
131225
132− dctorsForType :: ModuleName -> ProperName 'TypeName -> [ProperName 'ConstructorName]
226+ dctorsForType
227+ :: ModuleName
228+ -> ProperName 'TypeName
229+ -> [ProperName 'ConstructorName]
133230 dctorsForType mn tn =
134231 maybe [] getDctors (find matches $ dtys mn)
135232 where
136233 matches ((ty, _),_) = ty == tn
137234 getDctors ((_,ctors),_) = ctors
138235
139− typeForDCtor :: ModuleName -> ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)
236+ typeForDCtor
237+ :: ModuleName
238+ -> ProperName 'ConstructorName
239+ -> Maybe (ProperName 'TypeName)
140240 typeForDCtor mn pn =
141241 getTy <$> find matches (dtys mn)
142242 where
143243 matches ((_, ctors), _) = pn `elem` ctors
144244 getTy ((ty, _), _) = ty
145245
246+findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]
247+findUsedRefs env mni qualifierName names =
248+ let
249+ classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names
250+ valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names
251+ types = mapMaybe (getTypeName qualifierName) names
252+ dctors = mapMaybe (matchDctor qualifierName) names
253+ typesWithDctors = reconstructTypeRefs dctors
254+ typesWithoutDctors = filter (`M.notMember` typesWithDctors) types
255+ typesRefs
256+ = map (flip TypeRef (Just [])) typesWithoutDctors
257+ ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)
258+ in classRefs ++ typesRefs ++ valueRefs
259+
260+ where
261+
262+ reconstructTypeRefs
263+ :: [ProperName 'ConstructorName]
264+ -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]
265+ reconstructTypeRefs = foldr accumDctors M.empty
266+ where
267+ accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)
268+
269+ findTypeForDctor
270+ :: ModuleName
271+ -> ProperName 'ConstructorName
272+ -> ProperName 'TypeName
273+ findTypeForDctor mn dctor =
274+ case mn `M.lookup` env of
275+ Just (_, _, exps) ->
276+ case find (elem dctor . snd . fst) (exportedTypes exps) of
277+ Just ((ty, _), _) -> ty
278+ Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"
279+ Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"
146280
147281matchName
148282 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))
@@ -155,6 +289,12 @@ matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperNam
155289matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x
156290matchName _ _ _ = Nothing
157291
292+extractQualName :: Name -> Maybe ModuleName
293+extractQualName (IdentName (Qualified q _)) = q
294+extractQualName (TyName (Qualified q _)) = q
295+extractQualName (TyClassName (Qualified q _)) = q
296+extractQualName (DctorName (Qualified q _)) = q
297+
158298matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)
159299matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x
160300matchDctor _ _ = Nothing
@@ -166,7 +306,9 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn
166306runDeclRef (TypeClassRef pn) = Just $ runProperName pn
167307runDeclRef _ = Nothing
168308
169−getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
309+getTypeRef
310+ :: DeclarationRef
311+ -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
170312getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref
171313getTypeRef (TypeRef pn x) = Just (pn, x)
172314getTypeRef _ = Nothing