diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs index 143cec63..8fccbc32 100644 --- a/src/Hint/Restrict.hs +++ b/src/Hint/Restrict.hs @@ -164,88 +164,97 @@ checkPragmas modu flags exts mps = data QualifiedPostOrPre = QualifiedPostOrPre deriving Eq checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea] -checkImports modu lImportDecls (def, mp) = mapMaybe getImportHint lImportDecls +checkImports modu lImportDecls (def, mp) = concatMap getImportHint lImportDecls where - getImportHint :: LImportDecl GhcPs -> Maybe Idea + getImportHint :: LImportDecl GhcPs -> [Idea] getImportHint i@(L _ ImportDecl{..}) = do - let RestrictItem{..} = getRestrictItem def ideclName mp - either (Just . ideaMessage riMessage) (const Nothing) $ do - unless (within modu "" riWithin) $ - Left $ ideaNoTo $ warn "Avoid restricted module" (reLoc i) (reLoc i) [] - - let importedIdents = Set.fromList $ - case first (== EverythingBut) <$> ideclImportList of - Just (False, lxs) -> concatMap (importListToIdents . unLoc) (unLoc lxs) - _ -> [] - invalidIdents = case riRestrictIdents of - NoRestrictIdents -> Set.empty - ForbidIdents badIdents -> importedIdents `Set.intersection` Set.fromList badIdents - OnlyIdents onlyIdents -> importedIdents `Set.difference` Set.fromList onlyIdents - unless (Set.null invalidIdents) $ - Left $ ideaNoTo $ warn "Avoid restricted identifiers" (reLoc i) (reLoc i) [] - - let qualAllowed = case (riAs, ideclAs) of - ([], _) -> True - (_, Nothing) -> maybe True not $ getAlt riAsRequired - (_, Just (L _ modName)) -> moduleNameString modName `elem` riAs - unless qualAllowed $ do - let i' = noLoc $ (unLoc i){ ideclAs = noLocA . mkModuleName <$> listToMaybe riAs } - Left $ warn "Avoid restricted alias" (reLoc i) i' [] - - let (expectedQual, expectedHiding) = - case fromMaybe ImportStyleUnrestricted $ getAlt riImportStyle of - ImportStyleUnrestricted - | NotQualified <- ideclQualified -> (Nothing, Nothing) - | otherwise -> (Just $ second (<> " or unqualified") expectedQualStyle, Nothing) - ImportStyleQualified -> (Just expectedQualStyle, Nothing) - ImportStyleExplicitOrQualified - | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing) - | otherwise -> - ( Just $ second (<> " or with an explicit import list") expectedQualStyle - , Nothing ) - ImportStyleExplicit - | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing) - | otherwise -> - ( Just (Right NotQualified, "unqualified") - , Just $ Just (Exactly, noLocA []) ) - ImportStyleUnqualified -> (Just (Right NotQualified, "unqualified"), Nothing) - expectedQualStyle = - case fromMaybe QualifiedStyleUnrestricted $ getAlt riQualifiedStyle of - QualifiedStyleUnrestricted -> (Left QualifiedPostOrPre, "qualified") - QualifiedStylePost -> (Right QualifiedPost, "post-qualified") - QualifiedStylePre -> (Right QualifiedPre, "pre-qualified") - -- unless expectedQual is Nothing, it holds the Idea (hint) to ultimately emit, - -- except in these cases when the rule's requirements are fulfilled in-source: - qualIdea - -- the rule demands a particular importStyle, and the decl obeys exactly - | Just (Right ideclQualified) == (fst <$> expectedQual) = Nothing - -- the rule demands a QualifiedPostOrPre import, and the decl does either - | Just (Left QualifiedPostOrPre) == (fst <$> expectedQual) - && ideclQualified `elem` [QualifiedPost, QualifiedPre] = Nothing - -- otherwise, expectedQual gets converted into a warning below (or is Nothing) - | otherwise = expectedQual - whenJust qualIdea $ \(qual, hint) -> do - -- convert non-Nothing qualIdea into hlint's refactoring Idea - let i' = noLoc $ (unLoc i){ ideclQualified = fromRight QualifiedPre qual - , ideclImportList = fromMaybe ideclImportList expectedHiding } - msg = moduleNameString (unLoc ideclName) <> " should be imported " <> hint - Left $ warn msg (reLoc i) i' [] - -getRestrictItem :: Bool -> LocatedA ModuleName -> Map.Map String RestrictItem -> RestrictItem -getRestrictItem def ideclName = - fromMaybe (RestrictItem mempty mempty mempty mempty [("","") | def] NoRestrictIdents Nothing) - . lookupRestrictItem ideclName - -lookupRestrictItem :: LocatedA ModuleName -> Map.Map String RestrictItem -> Maybe RestrictItem + let restrictItems = getRestrictItem def ideclName mp + flip mapMaybe restrictItems $ \RestrictItem {..} -> + either (Just . ideaMessage riMessage) (const Nothing) $ do + unless (within modu "" riWithin) $ + Left $ ideaNoTo $ warn "Avoid restricted module" (reLoc i) (reLoc i) [] + + let importedIdents = Set.fromList $ + case first (== EverythingBut) <$> ideclImportList of + Just (False, lxs) -> concatMap (importListToIdents . unLoc) (unLoc lxs) + _ -> [] + invalidIdents = case riRestrictIdents of + NoRestrictIdents -> Set.empty + ForbidIdents badIdents -> importedIdents `Set.intersection` Set.fromList badIdents + OnlyIdents onlyIdents -> importedIdents `Set.difference` Set.fromList onlyIdents + unless (Set.null invalidIdents) $ + Left $ ideaNoTo $ warn "Avoid restricted identifiers" (reLoc i) (reLoc i) [] + + let qualAllowed = case (riAs, ideclAs) of + ([], _) -> True + (_, Nothing) -> maybe True not $ getAlt riAsRequired + (_, Just (L _ modName)) -> moduleNameString modName `elem` riAs + unless qualAllowed $ do + let i' = noLoc $ (unLoc i){ ideclAs = noLocA . mkModuleName <$> listToMaybe riAs } + Left $ warn "Avoid restricted alias" (reLoc i) i' [] + + let (expectedQual, expectedHiding) = + case fromMaybe ImportStyleUnrestricted $ getAlt riImportStyle of + ImportStyleUnrestricted + | NotQualified <- ideclQualified -> (Nothing, Nothing) + | otherwise -> (Just $ second (<> " or unqualified") expectedQualStyle, Nothing) + ImportStyleQualified -> (Just expectedQualStyle, Nothing) + ImportStyleExplicitOrQualified + | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing) + | otherwise -> + ( Just $ second (<> " or with an explicit import list") expectedQualStyle + , Nothing ) + ImportStyleExplicit + | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing) + | otherwise -> + ( Just (Right NotQualified, "unqualified") + , Just $ Just (Exactly, noLocA []) ) + ImportStyleUnqualified -> (Just (Right NotQualified, "unqualified"), Nothing) + expectedQualStyle = + case fromMaybe QualifiedStyleUnrestricted $ getAlt riQualifiedStyle of + QualifiedStyleUnrestricted -> (Left QualifiedPostOrPre, "qualified") + QualifiedStylePost -> (Right QualifiedPost, "post-qualified") + QualifiedStylePre -> (Right QualifiedPre, "pre-qualified") + -- unless expectedQual is Nothing, it holds the Idea (hint) to ultimately emit, + -- except in these cases when the rule's requirements are fulfilled in-source: + qualIdea + -- the rule demands a particular importStyle, and the decl obeys exactly + | Just (Right ideclQualified) == (fst <$> expectedQual) = Nothing + -- the rule demands a QualifiedPostOrPre import, and the decl does either + | Just (Left QualifiedPostOrPre) == (fst <$> expectedQual) + && ideclQualified `elem` [QualifiedPost, QualifiedPre] = Nothing + -- otherwise, expectedQual gets converted into a warning below (or is Nothing) + | otherwise = expectedQual + whenJust qualIdea $ \(qual, hint) -> do + -- convert non-Nothing qualIdea into hlint's refactoring Idea + let i' = noLoc $ (unLoc i){ ideclQualified = fromRight QualifiedPre qual + , ideclImportList = fromMaybe ideclImportList expectedHiding } + msg = moduleNameString (unLoc ideclName) <> " should be imported " <> hint + Left $ warn msg (reLoc i) i' [] + +getRestrictItem :: Bool -> LocatedA ModuleName -> Map.Map String RestrictItem -> [RestrictItem] +getRestrictItem def ideclName mp = + case lookupRestrictItem ideclName mp of + [] -> + pure (RestrictItem mempty mempty mempty mempty [("","") | def] NoRestrictIdents Nothing) + restricts -> + restricts + +lookupRestrictItem :: LocatedA ModuleName -> Map.Map String RestrictItem -> [RestrictItem] lookupRestrictItem ideclName mp = let moduleName = moduleNameString $ unLoc ideclName - exact = Map.lookup moduleName mp - wildcard = nonEmpty + mexact = Map.lookup moduleName mp + wildcard = catMaybes . NonEmpty.toList . sequence . nonEmpty . fmap snd . reverse -- the hope is less specific matches will end up last, but it's not guaranteed . filter (liftA2 (&&) (elem '*') (`wildcardMatch` moduleName) . fst) $ Map.toList mp - in exact <> sconcat (sequence wildcard) + in + case mexact of + Nothing -> + wildcard + Just exact -> + [sconcat (exact NonEmpty.:| wildcard)] importListToIdents :: IE GhcPs -> [String] importListToIdents =