{-# LANGUAGE PatternGuards, RecordWildCards #-}
module Hint.Import(importHint) where
import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest',toSS',rawIdea',rawIdeaN')
import Refact.Types hiding (ModuleName)
import qualified Refact.Types as R
import Data.Tuple.Extra
import Data.List.Extra
import Data.Generics.Uniplate.Operations
import Data.Maybe
import Control.Applicative
import Prelude
import FastString
import BasicTypes
import RdrName
import Module
import GHC.Hs
import SrcLoc
import GHC.Util
importHint :: ModuHint
importHint _ ModuleEx {ghcModule=L _ HsModule{hsmodImports=ms}} =
concatMap (reduceImports . snd) (
groupSort [((n, pkg), i) | i <- ms
, not $ ideclSource (unLoc i)
, let i' = unLoc i
, let n = unLoc $ ideclName i'
, let pkg = unpackFS . sl_fs <$> ideclPkgQual i']) ++
concatMap stripRedundantAlias ms ++
concatMap preferHierarchicalImports ms
reduceImports :: [LImportDecl GhcPs] -> [Idea]
reduceImports [] = []
reduceImports ms@(m:_) =
[rawIdea' Hint.Type.Warning "Use fewer imports" (getLoc m) (f ms) (Just $ f x) [] rs
| Just (x, rs) <- [simplify ms]]
where f = unlines . map unsafePrettyPrint
simplify :: [LImportDecl GhcPs]
-> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan])
simplify [] = Nothing
simplify (x : xs) = case simplifyHead x xs of
Nothing -> first (x:) <$> simplify xs
Just (xs, rs) -> Just $ maybe (xs, rs) (second (++ rs)) $ simplify xs
simplifyHead :: LImportDecl GhcPs
-> [LImportDecl GhcPs]
-> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan])
simplifyHead x (y : ys) = case combine x y of
Nothing -> first (y:) <$> simplifyHead x ys
Just (xy, rs) -> Just (xy : ys, rs)
simplifyHead x [] = Nothing
combine :: LImportDecl GhcPs
-> LImportDecl GhcPs
-> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])
combine x@(L _ x') y@(L _ y')
| qual, as, specs = Just (x, [Delete Import (toSS' y)])
| qual, as
, Just (False, xs) <- ideclHiding x'
, Just (False, ys) <- ideclHiding y' =
let newImp = noLoc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}
in Just (newImp, [Replace Import (toSS' x) [] (unsafePrettyPrint (unLoc newImp))
, Delete Import (toSS' y)])
| qual, as, isNothing (ideclHiding x') || isNothing (ideclHiding y') =
let (newImp, toDelete) = if isNothing (ideclHiding x') then (x, y) else (y, x)
in Just (newImp, [Delete Import (toSS' toDelete)])
| ideclQualified x' == NotQualified, qual, specs, length ass == 1 =
let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x)
in Just (newImp, [Delete Import (toSS' toDelete)])
| otherwise = Nothing
where
eqMaybe:: Eq a => Maybe (Located a) -> Maybe (Located a) -> Bool
eqMaybe (Just x) (Just y) = x `eqLocated` y
eqMaybe Nothing Nothing = True
eqMaybe _ _ = False
qual = ideclQualified x' == ideclQualified y'
as = ideclAs x' `eqMaybe` ideclAs y'
ass = mapMaybe ideclAs [x', y']
specs = transformBi (const noSrcSpan) (ideclHiding x') ==
transformBi (const noSrcSpan) (ideclHiding y')
stripRedundantAlias :: LImportDecl GhcPs -> [Idea]
stripRedundantAlias x@(L loc i@ImportDecl {..})
| Just (unLoc ideclName) == fmap unLoc ideclAs =
[suggest' "Redundant as" x (cL loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS' x)]]
stripRedundantAlias _ = []
preferHierarchicalImports :: LImportDecl GhcPs -> [Idea]
preferHierarchicalImports x@(L loc i@ImportDecl{ideclName=L _ n,ideclPkgQual=Nothing})
| n == mkModuleName "IO" && isNothing (ideclHiding i) =
[rawIdeaN' Suggestion "Use hierarchical imports" loc
(trimStart $ unsafePrettyPrint i) (
Just $ unlines $ map (trimStart . unsafePrettyPrint)
[ f "System.IO" Nothing, f "System.IO.Error" Nothing
, f "Control.Exception" $ Just (False, noLoc [mkLIE x | x <- ["bracket","bracket_"]])]) []]
| Just y <- lookup (moduleNameString n) newNames =
let newModuleName = y ++ "." ++ moduleNameString n
r = [Replace R.ModuleName (toSS' x) [] newModuleName] in
[suggest' "Use hierarchical imports"
x (noLoc (desugarQual i){ideclName=noLoc (mkModuleName newModuleName)} :: LImportDecl GhcPs) r]
where
f a b = (desugarQual i){ideclName=noLoc (mkModuleName a), ideclHiding=b}
mkLIE :: String -> LIE GhcPs
mkLIE n = noLoc $ IEVar noExtField (noLoc (IEName (noLoc (mkVarUnqual (fsLit n)))))
desugarQual :: ImportDecl GhcPs -> ImportDecl GhcPs
desugarQual i
| ideclQualified i /= NotQualified && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)}
| otherwise = i
preferHierarchicalImports _ = []
newNames :: [(String, String)]
newNames = let (*) = flip (,) in
["Control" * "Monad"
,"Data" * "Char"
,"Data" * "List"
,"Data" * "Maybe"
,"Data" * "Ratio"
,"System" * "Directory"
]