module Language.PureScript.Linter.Imports
( lintImports
, Name(..)
, UsedImports()
) where
import Prelude ()
import Prelude.Compat
import Control.Monad (unless, when)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class
import Data.Foldable (forM_)
import Data.List ((\\), find, intersect, nub)
import Data.Maybe (mapMaybe)
import Data.Monoid (Sum(..))
import qualified Data.Map as M
import Language.PureScript.AST.Declarations
import Language.PureScript.AST.SourcePos
import Language.PureScript.Crash
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
data Name
= IdentName (Qualified Ident)
| TyName (Qualified (ProperName 'TypeName))
| DctorName (Qualified (ProperName 'ConstructorName))
| TyClassName (Qualified (ProperName 'ClassName))
deriving (Eq, Show)
getIdentName :: Maybe ModuleName -> Name -> Maybe Ident
getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name
getIdentName _ _ = Nothing
getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)
getTypeName q (TyName (Qualified q' name)) | q == q' = Just name
getTypeName _ _ = Nothing
getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)
getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name
getClassName _ _ = Nothing
type UsedImports = M.Map ModuleName [Name]
lintImports
:: forall m
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Module
-> Env
-> UsedImports
-> m ()
lintImports (Module _ _ mn mdecls mexports) env usedImps = do
let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)
usedImps' = foldr (elaborateUsed scope) usedImps exportedModules
numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls
allowImplicit = numOpenImports == 1
imps <- M.toAscList <$> findImports mdecls
forM_ imps $ \(mni, decls) ->
unless (isPrim mni) $ do
forM_ decls $ \(ss, declType, qualifierName) ->
censor (onErrorMessages $ addModuleLocError ss) $ do
let names = nub $ M.findWithDefault [] mni usedImps'
lintImportDecl env mni qualifierName names declType allowImplicit
forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do
let mnis = nub $ map (\(_, _, mni) -> mni) entries
unless (length mnis == 1) $ do
let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries
forM_ implicits $ \(ss, _, mni) ->
censor (onErrorMessages $ addModuleLocError ss) $ do
let names = nub $ M.findWithDefault [] mni usedImps'
usedRefs = findUsedRefs env mni (Just mnq) names
unless (null usedRefs) $
tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs
return ()
where
countOpenImports :: Declaration -> Int
countOpenImports (ImportDeclaration mn' Implicit Nothing _) | not (isPrim mn') = 1
countOpenImports (ImportDeclaration mn' (Hiding _) Nothing _) | not (isPrim mn') = 1
countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d
countOpenImports _ = 0
isPrim :: ModuleName -> Bool
isPrim = (== ModuleName [ProperName C.prim])
byQual
:: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])]
-> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)]
byQual = foldr goImp M.empty
where
goImp (mni, xs) acc = foldr (goDecl mni) acc xs
goDecl mni (ss, declType, Just qmn) acc =
let entry = (ss, declType, mni)
in M.alter (Just . maybe [entry] (entry :)) qmn acc
goDecl _ _ acc = acc
exportedModules :: [ModuleName]
exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports
where
extractModule (PositionedDeclarationRef _ _ r) = extractModule r
extractModule (ModuleRef mne) = Just mne
extractModule _ = Nothing
elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports
elaborateUsed scope mne used =
let classes = extractByQual mne (importedTypeClasses scope) TyClassName
types = extractByQual mne (importedTypes scope) TyName
dctors = extractByQual mne (importedDataConstructors scope) DctorName
values = extractByQual mne (importedValues scope) IdentName
in foldr go used (classes ++ types ++ dctors ++ values)
where
go :: (ModuleName, Name) -> UsedImports -> UsedImports
go (q, name) = M.alter (Just . maybe [name] (name :)) q
extractByQual
:: (Eq a)
=> ModuleName
-> M.Map (Qualified a) [ImportRecord a]
-> (Qualified a -> Name)
-> [(ModuleName, Name)]
extractByQual k m toName = mapMaybe go (M.toList m)
where
go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q =
case importName (head is) of
Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)
_ -> internalError "unqualified name in extractByQual"
go _ = Nothing
lintImportDecl
:: forall m
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Env
-> ModuleName
-> Maybe ModuleName
-> [Name]
-> ImportDeclarationType
-> Bool
-> m ()
lintImportDecl env mni qualifierName names declType allowImplicit =
case declType of
Implicit -> case qualifierName of
Nothing -> unless allowImplicit (checkImplicit ImplicitImport)
Just q ->
let usedModuleNames = mapMaybe extractQualName names
in unless (q `elem` usedModuleNames) unused
Hiding _ -> checkImplicit HidingImport
Explicit [] -> unused
Explicit declrefs -> checkExplicit declrefs
where
checkImplicit
:: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)
-> m ()
checkImplicit warning =
if null allRefs
then unused
else tell $ errorMessage $ warning mni allRefs
checkExplicit
:: [DeclarationRef]
-> m ()
checkExplicit declrefs = do
let idents = nub (mapMaybe runDeclRef declrefs)
dctors = mapMaybe (matchDctor qualifierName) names
usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
diff = idents \\ usedNames
case (length diff, length idents) of
(0, _) -> return ()
(n, m) | n == m -> unused
_ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs
forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
let allCtors = dctorsForType mni tn
when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of
(_, []) | c /= Just [] ->
tell $ errorMessage $ UnusedDctorImport tn
(Just ctors, dctors') ->
let ddiff = ctors \\ dctors'
in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
_ -> return ()
return ()
unused :: m ()
unused = tell $ errorMessage $ UnusedImport mni
allRefs :: [DeclarationRef]
allRefs = findUsedRefs env mni qualifierName names
dtys
:: ModuleName
-> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
dctorsForType
:: ModuleName
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
dctorsForType mn tn =
maybe [] getDctors (find matches $ dtys mn)
where
matches ((ty, _),_) = ty == tn
getDctors ((_,ctors),_) = ctors
typeForDCtor
:: ModuleName
-> ProperName 'ConstructorName
-> Maybe (ProperName 'TypeName)
typeForDCtor mn pn =
getTy <$> find matches (dtys mn)
where
matches ((_, ctors), _) = pn `elem` ctors
getTy ((ty, _), _) = ty
findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]
findUsedRefs env mni qualifierName names =
let
classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names
valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names
types = mapMaybe (getTypeName qualifierName) names
dctors = mapMaybe (matchDctor qualifierName) names
typesWithDctors = reconstructTypeRefs dctors
typesWithoutDctors = filter (`M.notMember` typesWithDctors) types
typesRefs
= map (flip TypeRef (Just [])) typesWithoutDctors
++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)
in classRefs ++ typesRefs ++ valueRefs
where
reconstructTypeRefs
:: [ProperName 'ConstructorName]
-> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]
reconstructTypeRefs = foldr accumDctors M.empty
where
accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)
findTypeForDctor
:: ModuleName
-> ProperName 'ConstructorName
-> ProperName 'TypeName
findTypeForDctor mn dctor =
case mn `M.lookup` env of
Just (_, _, exps) ->
case find (elem dctor . snd . fst) (exportedTypes exps) of
Just ((ty, _), _) -> ty
Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"
Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"
matchName
:: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))
-> Maybe ModuleName
-> Name
-> Maybe String
matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x
matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x
matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x
matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x
matchName _ _ _ = Nothing
extractQualName :: Name -> Maybe ModuleName
extractQualName (IdentName (Qualified q _)) = q
extractQualName (TyName (Qualified q _)) = q
extractQualName (TyClassName (Qualified q _)) = q
extractQualName (DctorName (Qualified q _)) = q
matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)
matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x
matchDctor _ _ = Nothing
runDeclRef :: DeclarationRef -> Maybe String
runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref
runDeclRef (ValueRef ident) = Just $ showIdent ident
runDeclRef (TypeRef pn _) = Just $ runProperName pn
runDeclRef (TypeClassRef pn) = Just $ runProperName pn
runDeclRef _ = Nothing
getTypeRef
:: DeclarationRef
-> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref
getTypeRef (TypeRef pn x) = Just (pn, x)
getTypeRef _ = Nothing
addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
addModuleLocError sp err =
case sp of
Just pos -> withPosition pos err
_ -> err