{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module ImportStylePlugin where import Control.Monad (forM_, unless) import Data.Functor (($>), (<&>)) import Data.List (intercalate, intersperse) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) import qualified Data.Set as Set import Data.String (fromString) import qualified GHC.Hs as Ghc import qualified GHC.Plugins as Ghc import qualified GHC.Tc.Types as Ghc import ImportStylePlugin.Compat (getExplicitlyHiddenNames, getExplicitlyImportedNames, report) import ImportStylePlugin.Config as Config importPlugin :: ImportsStyle -> Ghc.TcGblEnv -> Ghc.TcM Ghc.TcGblEnv importPlugin :: ImportsStyle -> TcGblEnv -> TcM TcGblEnv importPlugin ImportsStyle{Maybe QualificationStyle Map ModuleName Ban Map ModuleName ImportRules qualificationStyle :: Maybe QualificationStyle bannedModules :: Map ModuleName Ban importRules :: Map ModuleName ImportRules $sel:qualificationStyle:ImportsStyle :: ImportsStyle -> Maybe QualificationStyle $sel:bannedModules:ImportsStyle :: ImportsStyle -> Map ModuleName Ban $sel:importRules:ImportsStyle :: ImportsStyle -> Map ModuleName ImportRules ..} e :: TcGblEnv e@Ghc.TcGblEnv{[LImportDecl GhcRn] tcg_rn_imports :: [LImportDecl GhcRn] tcg_rn_imports :: TcGblEnv -> [LImportDecl GhcRn] tcg_rn_imports} = IOEnv (Env TcGblEnv TcLclEnv) () corrections IOEnv (Env TcGblEnv TcLclEnv) () -> TcGblEnv -> TcM TcGblEnv forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> TcGblEnv e where mkWord :: Severity -> [Char] mkWord = \case Severity Error -> [Char] "must" Severity Warning -> [Char] "should" corrections :: IOEnv (Env TcGblEnv TcLclEnv) () corrections = [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (ImportDecl GhcRn)] -> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (ImportDecl GhcRn) -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> IOEnv (Env TcGblEnv TcLclEnv) () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [LImportDecl GhcRn] [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (ImportDecl GhcRn)] tcg_rn_imports \(Ghc.L Ghc.SrcSpanAnn{SrcSpan EpAnn AnnListItem ann :: EpAnn AnnListItem locA :: SrcSpan ann :: forall a. SrcSpanAnn' a -> a locA :: forall a. SrcSpanAnn' a -> SrcSpan ..} importDecl :: ImportDecl GhcRn importDecl@Ghc.ImportDecl{Bool Maybe (ImportListInterpretation, XRec GhcRn [LIE GhcRn]) Maybe (XRec GhcRn ModuleName) ImportDeclPkgQual GhcRn XCImportDecl GhcRn XRec GhcRn ModuleName IsBootInterface ImportDeclQualifiedStyle ideclExt :: XCImportDecl GhcRn ideclName :: XRec GhcRn ModuleName ideclPkgQual :: ImportDeclPkgQual GhcRn ideclSource :: IsBootInterface ideclSafe :: Bool ideclQualified :: ImportDeclQualifiedStyle ideclAs :: Maybe (XRec GhcRn ModuleName) ideclImportList :: Maybe (ImportListInterpretation, XRec GhcRn [LIE GhcRn]) ideclExt :: forall pass. ImportDecl pass -> XCImportDecl pass ideclName :: forall pass. ImportDecl pass -> XRec pass ModuleName ideclPkgQual :: forall pass. ImportDecl pass -> ImportDeclPkgQual pass ideclSource :: forall pass. ImportDecl pass -> IsBootInterface ideclSafe :: forall pass. ImportDecl pass -> Bool ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle ideclAs :: forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName) ideclImportList :: forall pass. ImportDecl pass -> Maybe (ImportListInterpretation, XRec pass [LIE pass]) ..}) -> let (Ghc.L SrcSpanAnn' (EpAnn AnnListItem) _ (ModuleName -> [Char] Ghc.moduleNameString -> [Char] moduleName)) = XRec GhcRn ModuleName ideclName in do case Maybe QualificationStyle qualificationStyle of Maybe QualificationStyle _ | ImportDeclQualifiedStyle ideclQualified ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool forall a. Eq a => a -> a -> Bool == ImportDeclQualifiedStyle Ghc.NotQualified -> () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a forall (f :: * -> *) a. Applicative f => a -> f a pure () Just QualificationStyle Pre | ImportDeclQualifiedStyle ideclQualified ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool forall a. Eq a => a -> a -> Bool /= ImportDeclQualifiedStyle Ghc.QualifiedPre -> Severity -> SDoc -> Maybe SrcSpan -> IOEnv (Env TcGblEnv TcLclEnv) () report Severity Error SDoc "Use prefix qualification" (SrcSpan -> Maybe SrcSpan forall a. a -> Maybe a Just SrcSpan locA) Just QualificationStyle Post | ImportDeclQualifiedStyle ideclQualified ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool forall a. Eq a => a -> a -> Bool /= ImportDeclQualifiedStyle Ghc.QualifiedPost -> Severity -> SDoc -> Maybe SrcSpan -> IOEnv (Env TcGblEnv TcLclEnv) () report Severity Error SDoc "Use postfix qualification" (SrcSpan -> Maybe SrcSpan forall a. a -> Maybe a Just SrcSpan locA) Maybe QualificationStyle _ -> () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a forall (f :: * -> *) a. Applicative f => a -> f a pure () case ModuleName -> Map ModuleName Ban -> Maybe Ban forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup ([Char] -> ModuleName Config.ModuleName [Char] moduleName) Map ModuleName Ban bannedModules of Just Ban{[Char] Severity severity :: Severity why :: [Char] $sel:severity:Ban :: Ban -> Severity $sel:why:Ban :: Ban -> [Char] ..} -> Severity -> SDoc -> Maybe SrcSpan -> IOEnv (Env TcGblEnv TcLclEnv) () report Severity severity ([Char] -> SDoc forall a. IsString a => [Char] -> a fromString [Char] why) (SrcSpan -> Maybe SrcSpan forall a. a -> Maybe a Just SrcSpan locA) Maybe Ban Nothing -> IOEnv (Env TcGblEnv TcLclEnv) () -> (ImportRules -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> Maybe ImportRules -> IOEnv (Env TcGblEnv TcLclEnv) () forall b a. b -> (a -> b) -> Maybe a -> b maybe do () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a forall (f :: * -> *) a. Applicative f => a -> f a pure () do \ImportRules{[ImportRule] Severity rules :: [ImportRule] severity :: Severity $sel:rules:ImportRules :: ImportRules -> [ImportRule] $sel:severity:ImportRules :: ImportRules -> Severity ..} -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless ((ImportRule -> Bool) -> [ImportRule] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (ImportDecl GhcRn -> ImportRule -> Bool isImportValid ImportDecl GhcRn importDecl) [ImportRule] rules) do let header :: SDoc header = [Char] -> SDoc forall a. IsString a => [Char] -> a fromString ([Char] -> SDoc) -> [Char] -> SDoc forall a b. (a -> b) -> a -> b $ [Char] "Import " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> Severity -> [Char] mkWord Severity severity [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " satisfy the following rules:" let allStringRules :: SDoc allStringRules = [SDoc] -> SDoc forall doc. IsDoc doc => [doc] -> doc Ghc.vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc forall a b. (a -> b) -> a -> b $ (SDoc header SDoc -> [SDoc] -> [SDoc] forall a. a -> [a] -> [a] :) ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc] forall a b. (a -> b) -> a -> b $ SDoc -> [SDoc] -> [SDoc] forall a. a -> [a] -> [a] intersperse SDoc "or" ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc] forall a b. (a -> b) -> a -> b $ (ImportRule -> SDoc) -> [ImportRule] -> [SDoc] forall a b. (a -> b) -> [a] -> [b] map ([SDoc] -> SDoc forall doc. IsDoc doc => [doc] -> doc Ghc.vcat ([SDoc] -> SDoc) -> (ImportRule -> [SDoc]) -> ImportRule -> SDoc forall b c a. (b -> c) -> (a -> b) -> a -> c . Severity -> ImportRule -> [SDoc] forall {b}. IsString b => Severity -> ImportRule -> [b] stringifyRule Severity severity) [ImportRule] rules Severity -> SDoc -> Maybe SrcSpan -> IOEnv (Env TcGblEnv TcLclEnv) () report Severity severity SDoc allStringRules (SrcSpan -> Maybe SrcSpan forall a. a -> Maybe a Just SrcSpan locA) do ModuleName -> Map ModuleName ImportRules -> Maybe ImportRules forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup ([Char] -> ModuleName Config.ModuleName [Char] moduleName) Map ModuleName ImportRules importRules stringifyRule :: Severity -> ImportRule -> [b] stringifyRule Severity severity ImportRule{Maybe NamesList Maybe ModuleAliases Maybe Qualification qualification :: Maybe Qualification aliases :: Maybe ModuleAliases importedNames :: Maybe NamesList $sel:qualification:ImportRule :: ImportRule -> Maybe Qualification $sel:aliases:ImportRule :: ImportRule -> Maybe ModuleAliases $sel:importedNames:ImportRule :: ImportRule -> Maybe NamesList ..} = ([Char] -> b) -> [[Char]] -> [b] forall a b. (a -> b) -> [a] -> [b] map ([Char] -> b forall a. IsString a => [Char] -> a fromString ([Char] -> b) -> ([Char] -> [Char]) -> [Char] -> b forall b c a. (b -> c) -> (a -> b) -> a -> c . ([Char] " * " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <>)) ([[Char]] -> [b]) -> [[Char]] -> [b] forall a b. (a -> b) -> a -> b $ [Maybe [Char]] -> [[Char]] forall a. [Maybe a] -> [a] catMaybes [ Maybe Qualification qualification Maybe Qualification -> (Qualification -> [Char]) -> Maybe [Char] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \case Qualification Required -> [Char] "Module " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] word [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " be qualified" Qualification Forbidden -> [Char] "Module " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] word [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " not be qualified" , let common :: Set [Char] -> [Char] common (Set [Char] -> [[Char]] forall a. Set a -> [a] Set.toList -> [[Char]] allowed) = [Char] "Alias " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] word [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " be " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> case [[Char]] allowed of [[Char] name] -> [Char] name [[Char]] _ -> [Char] "one of " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [[Char]] -> [Char] commaSep [[Char]] allowed in Maybe ModuleAliases aliases Maybe ModuleAliases -> (ModuleAliases -> [Char]) -> Maybe [Char] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \case Exactly Set [Char] allowed -> if Set [Char] -> Bool forall a. Set a -> Bool Set.null Set [Char] allowed then [Char] "Import " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] word [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " not have alias" else Set [Char] -> [Char] common Set [Char] allowed OrOmitted Set [Char] allowed -> Set [Char] -> [Char] common Set [Char] allowed [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " or alias can be omitted" , Maybe NamesList importedNames Maybe NamesList -> (NamesList -> [Char]) -> Maybe [Char] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \case BlackList Set [Char] names -> [Char] "Module " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] word [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " not import the following names: " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> Set [Char] -> [Char] printNamesList Set [Char] names WhiteList Set [Char] names | Set [Char] -> Bool forall a. Set a -> Bool Set.null Set [Char] names -> [Char] "Module" [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] word [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " not import names explicitly" WhiteList Set [Char] names -> [Char] "Module " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] word [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> [Char] " import only the following names: " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> Set [Char] -> [Char] printNamesList Set [Char] names ] where printNamesList :: Set [Char] -> [Char] printNamesList = [[Char]] -> [Char] commaSep ([[Char]] -> [Char]) -> (Set [Char] -> [[Char]]) -> Set [Char] -> [Char] forall b c a. (b -> c) -> (a -> b) -> a -> c . Set [Char] -> [[Char]] forall a. Set a -> [a] Set.toList commaSep :: [[Char]] -> [Char] commaSep = [Char] -> [[Char]] -> [Char] forall a. [a] -> [[a]] -> [a] intercalate [Char] ", " word :: [Char] word = Severity -> [Char] mkWord Severity severity isImportValid :: Ghc.ImportDecl Ghc.GhcRn -> ImportRule -> Bool isImportValid :: ImportDecl GhcRn -> ImportRule -> Bool isImportValid decl :: ImportDecl GhcRn decl@Ghc.ImportDecl{Bool Maybe (ImportListInterpretation, XRec GhcRn [LIE GhcRn]) Maybe (XRec GhcRn ModuleName) ImportDeclPkgQual GhcRn XCImportDecl GhcRn XRec GhcRn ModuleName IsBootInterface ImportDeclQualifiedStyle ideclExt :: forall pass. ImportDecl pass -> XCImportDecl pass ideclName :: forall pass. ImportDecl pass -> XRec pass ModuleName ideclPkgQual :: forall pass. ImportDecl pass -> ImportDeclPkgQual pass ideclSource :: forall pass. ImportDecl pass -> IsBootInterface ideclSafe :: forall pass. ImportDecl pass -> Bool ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle ideclAs :: forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName) ideclImportList :: forall pass. ImportDecl pass -> Maybe (ImportListInterpretation, XRec pass [LIE pass]) ideclExt :: XCImportDecl GhcRn ideclName :: XRec GhcRn ModuleName ideclPkgQual :: ImportDeclPkgQual GhcRn ideclSource :: IsBootInterface ideclSafe :: Bool ideclQualified :: ImportDeclQualifiedStyle ideclAs :: Maybe (XRec GhcRn ModuleName) ideclImportList :: Maybe (ImportListInterpretation, XRec GhcRn [LIE GhcRn]) ..} ImportRule{Maybe NamesList Maybe ModuleAliases Maybe Qualification $sel:qualification:ImportRule :: ImportRule -> Maybe Qualification $sel:aliases:ImportRule :: ImportRule -> Maybe ModuleAliases $sel:importedNames:ImportRule :: ImportRule -> Maybe NamesList qualification :: Maybe Qualification aliases :: Maybe ModuleAliases importedNames :: Maybe NamesList ..} = Bool isQualificationValid Bool -> Bool -> Bool && Bool areImportedNamesValid Bool -> Bool -> Bool && Bool isAliasValid where isQualificationValid :: Bool isQualificationValid = case Maybe Qualification qualification of Just Qualification Required -> ImportDeclQualifiedStyle ideclQualified ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool forall a. Eq a => a -> a -> Bool /= ImportDeclQualifiedStyle Ghc.NotQualified Just Qualification Forbidden -> ImportDeclQualifiedStyle ideclQualified ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool forall a. Eq a => a -> a -> Bool == ImportDeclQualifiedStyle Ghc.NotQualified Maybe Qualification Nothing -> Bool True isAliasValid :: Bool isAliasValid = case Maybe ModuleAliases aliases of Just (Exactly Set [Char] allowedAliases) -> Bool -> Set [Char] -> Bool oneOfAllowed Bool False Set [Char] allowedAliases Just (OrOmitted Set [Char] allowedAliases) -> Bool -> Set [Char] -> Bool oneOfAllowed Bool True Set [Char] allowedAliases Maybe ModuleAliases Nothing -> Bool True where oneOfAllowed :: Bool -> Set [Char] -> Bool oneOfAllowed Bool def Set [Char] allowed = Bool -> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName -> Bool) -> Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName) -> Bool forall b a. b -> (a -> b) -> Maybe a -> b maybe do Bool def do \(Ghc.L SrcSpanAnn' (EpAnn AnnListItem) _ ModuleName name) -> ModuleName -> [Char] Ghc.moduleNameString ModuleName name [Char] -> Set [Char] -> Bool forall a. Ord a => a -> Set a -> Bool `Set.member` Set [Char] allowed do Maybe (XRec GhcRn ModuleName) Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName) ideclAs areImportedNamesValid :: Bool areImportedNamesValid = case Maybe NamesList importedNames of Just (WhiteList Set [Char] allowedNames) -> Bool -> ([[Char]] -> Bool) -> Maybe [[Char]] -> Bool forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool False (([Char] -> Bool) -> [[Char]] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all ([Char] -> Set [Char] -> Bool forall a. Ord a => a -> Set a -> Bool `Set.member` Set [Char] allowedNames)) (ImportDecl GhcRn -> Maybe [[Char]] getExplicitlyImportedNames ImportDecl GhcRn decl) Just (BlackList Set [Char] forbiddenNames) -> Bool -> ([[Char]] -> Bool) -> Maybe [[Char]] -> Bool forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool True (Set [Char] -> Bool forall a. Set a -> Bool Set.null (Set [Char] -> Bool) -> ([[Char]] -> Set [Char]) -> [[Char]] -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . (Set [Char] forbiddenNames Set [Char] -> Set [Char] -> Set [Char] forall a. Ord a => Set a -> Set a -> Set a `Set.difference`) (Set [Char] -> Set [Char]) -> ([[Char]] -> Set [Char]) -> [[Char]] -> Set [Char] forall b c a. (b -> c) -> (a -> b) -> a -> c . [[Char]] -> Set [Char] forall a. Ord a => [a] -> Set a Set.fromList) (ImportDecl GhcRn -> Maybe [[Char]] getExplicitlyHiddenNames ImportDecl GhcRn decl) Bool -> Bool -> Bool && Bool -> ([[Char]] -> Bool) -> Maybe [[Char]] -> Bool forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool False (Bool -> Bool not (Bool -> Bool) -> ([[Char]] -> Bool) -> [[Char]] -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . ([Char] -> Bool) -> [[Char]] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any ([Char] -> Set [Char] -> Bool forall a. Ord a => a -> Set a -> Bool `Set.member` Set [Char] forbiddenNames)) (ImportDecl GhcRn -> Maybe [[Char]] getExplicitlyImportedNames ImportDecl GhcRn decl) Maybe NamesList Nothing -> Bool True