module Language.Haskell.Tools.Refactor.Predefined.OrganizeImports (organizeImports, OrganizeImportsDomain, projectOrganizeImports) where
import ConLike (ConLike(..))
import DataCon (FieldLbl(..), dataConTyCon)
import DynFlags (xopt)
import FamInstEnv (FamInst(..))
import GHC (TyThing(..), lookupName)
import qualified GHC
import Id
import IdInfo (RecSelParent(..))
import InstEnv (ClsInst(..))
import Language.Haskell.TH.LanguageExtensions as GHC (Extension(..))
import Name (NamedThing(..))
import TyCon (tyConFieldLabels, tyConDataCons, isClassTyCon)
import Control.Applicative ((<$>), Alternative(..))
import Control.Monad
import Control.Monad.Trans (MonadTrans(..))
import Control.Reference hiding (element)
import Data.Function hiding ((&))
import Data.Generics.Uniplate.Data (universeBi)
import Data.List
import Data.Maybe (Maybe(..), maybe, catMaybes)
import Language.Haskell.Tools.Refactor as AST
type OrganizeImportsDomain dom = ( HasNameInfo dom, HasImportInfo dom, HasModuleInfo dom )
projectOrganizeImports :: forall dom . OrganizeImportsDomain dom => Refactoring dom
projectOrganizeImports mod mods
= mapM (\(k, m) -> ContentChanged . (k,) <$> localRefactoringRes id m (organizeImports m)) (mod:mods)
organizeImports :: forall dom . OrganizeImportsDomain dom => LocalRefactoring dom
organizeImports mod
= do ms <- lift $ GHC.getModSummary (GHC.moduleName $ semanticsModule mod)
let noNarrowingImports = xopt TemplateHaskell (GHC.ms_hspp_opts ms)
noNarrowingSubspecs = xopt GHC.StandaloneDeriving (GHC.ms_hspp_opts ms)
if noNarrowingImports
then
return $ modImports .- sortImports $ mod
else modImports !~ narrowImports noNarrowingSubspecs exportedModules usedNames prelInstances prelFamInsts . sortImports $ mod
where prelInstances = semanticsPrelOrphanInsts mod
prelFamInsts = semanticsPrelFamInsts mod
usedNames = map getName $ catMaybes $ map semanticsName
$ (universeBi (mod ^. modHead) ++ universeBi (mod ^. modDecl) :: [QualifiedName dom])
exportedModules = mod ^? modHead & annJust & mhExports & annJust
& espExports & annList & exportModuleName & moduleNameString
sortImports :: forall dom . ImportDeclList dom -> ImportDeclList dom
sortImports ls = srcInfo & srcTmpSeparators .= filter (not . null) (concatMap (\(sep,elems) -> sep : map fst elems) reordered)
$ annListElems .= concatMap (map snd . snd) reordered
$ ls
where reordered :: [(String, [(String, ImportDecl dom)])]
reordered = map (_2 .- sortBy (compare `on` (^. _2 & importModule & AST.moduleNameString))) parts
parts = map (_2 .- reverse) $ reverse $ breakApart [] imports
breakApart :: [(String, [(String, ImportDecl dom)])] -> [(String, ImportDecl dom)] -> [(String, [(String, ImportDecl dom)])]
breakApart res [] = res
breakApart res ((sep, e) : rest) | length (filter ('\n' ==) sep) > 1
= breakApart ((sep, [("",e)]) : res) rest
breakApart ((lastSep, lastRes) : res) (elem : rest)
= breakApart ((lastSep, elem : lastRes) : res) rest
breakApart [] ((sep, e) : rest)
= breakApart [(sep, [("",e)])] rest
imports = zipWithSeparators ls
narrowImports :: forall dom . OrganizeImportsDomain dom
=> Bool -> [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> ImportDeclList dom -> LocalRefactor dom (ImportDeclList dom)
narrowImports noNarrowSubspecs exportedModules usedNames prelInsts prelFamInsts imps
= annListElems & traversal !~ narrowImport noNarrowSubspecs exportedModules usedNames
$ filterListIndexed (\i _ -> neededImps !! i) imps
where neededImps = neededImports exportedModules usedNames prelInsts prelFamInsts (imps ^. annListElems)
narrowImport :: OrganizeImportsDomain dom
=> Bool -> [String] -> [GHC.Name] -> ImportDecl dom -> LocalRefactor dom (ImportDecl dom)
narrowImport noNarrowSubspecs exportedModules usedNames imp
| (imp ^. importModule & moduleNameString) `elem` exportedModules
|| maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString)
= return imp
| importIsExact imp
= importSpec&annJust&importSpecList !~ narrowImportSpecs noNarrowSubspecs usedNames $ imp
| otherwise
= do namedThings <- mapM lookupName actuallyImported
let
hasPatSyn = any (\case Just (AConLike (PatSynCon _)) -> True; _ -> False) namedThings
groups = groupThings noNarrowSubspecs (semanticsImported imp) (catMaybes namedThings)
return $ if not hasPatSyn && length groups < 4
then importSpec .- replaceWithJust (createImportSpec groups) $ imp
else imp
where actuallyImported = semanticsImported imp `intersect` usedNames
groupThings :: Bool -> [GHC.Name] -> [TyThing] -> [(GHC.Name, Bool)]
groupThings noNarrowSubspecs importable
= map last . groupBy ((==) `on` fst) . sort . map createImportFromTyThing
where createImportFromTyThing :: TyThing -> (GHC.Name, Bool)
createImportFromTyThing tt | Just td <- getTopDef tt
= if (td `elem` importable) then (td, True)
else (getName tt, False)
createImportFromTyThing tt@(ATyCon {}) = (getName tt, noNarrowSubspecs)
createImportFromTyThing tt = (getName tt, False)
getTopDef :: TyThing -> Maybe GHC.Name
getTopDef (AnId id) | isRecordSelector id
= Just $ case recordSelectorTyCon id of RecSelData tc -> getName tc
RecSelPatSyn ps -> getName ps
getTopDef (AnId id) = fmap (getName . dataConTyCon) (isDataConWorkId_maybe id <|> isDataConId_maybe id)
<|> fmap getName (isClassOpId_maybe id)
getTopDef (AConLike (RealDataCon dc)) = Just (getName $ dataConTyCon dc)
getTopDef (AConLike (PatSynCon _)) = error "getTopDef: should not be called with pattern synonyms"
getTopDef (ATyCon _) = Nothing
createImportSpec :: [(GHC.Name, Bool)] -> ImportSpec dom
createImportSpec elems = mkImportSpecList $ map createIESpec elems
where createIESpec (n, False) = mkIESpec (mkUnqualName' (GHC.getName n)) Nothing
createIESpec (n, True) = mkIESpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll)
neededImports :: OrganizeImportsDomain dom
=> [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> [ImportDecl dom] -> [Bool]
neededImports exportedModules usedNames prelInsts prelFamInsts imps = neededImports' usedNames [] imps
where neededImports' _ _ [] = []
neededImports' usedNames kept (imp : rest)
| not (null actuallyImported)
|| (imp ^. importModule & moduleNameString) `elem` exportedModules
|| maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString)
= True : neededImports' usedNames (imp : kept) rest
where actuallyImported = semanticsImported imp `intersect` usedNames
neededImports' usedNames kept (imp : rest)
= needed : neededImports' usedNames (if needed then imp : kept else kept) rest
where needed = any (`notElem` otherClsInstances) (map is_dfun $ semanticsOrphanInsts imp)
|| any (`notElem` otherFamInstances) (map fi_axiom $ semanticsFamInsts imp)
otherClsInstances = map is_dfun (concatMap semanticsOrphanInsts kept ++ prelInsts)
otherFamInstances = map fi_axiom (concatMap semanticsFamInsts kept ++ prelFamInsts)
narrowImportSpecs :: forall dom . OrganizeImportsDomain dom
=> Bool -> [GHC.Name] -> IESpecList dom -> LocalRefactor dom (IESpecList dom)
narrowImportSpecs noNarrowSubspecs usedNames
= (if noNarrowSubspecs then return else (annList !~ narrowSpecSubspec usedNames))
>=> return . filterList isNeededSpec
where narrowSpecSubspec :: [GHC.Name] -> IESpec dom -> LocalRefactor dom (IESpec dom)
narrowSpecSubspec usedNames spec
= do let Just specName = semanticsName =<< (spec ^? ieName&simpleName)
Just tt <- GHC.lookupName (getName specName)
let subspecsInScope = case tt of ATyCon tc | not (isClassTyCon tc)
-> (map getName (tyConDataCons tc) ++ map flSelector (tyConFieldLabels tc)) `intersect` usedNames
_ -> usedNames
ieSubspec !- narrowImportSubspecs subspecsInScope $ spec
isNeededSpec :: IESpec dom -> Bool
isNeededSpec ie =
fmap getName (semanticsName =<< (ie ^? ieName&simpleName)) `elem` map Just usedNames
|| ((ie ^? ieSubspec&annJust&essList&annList) /= [])
|| (case ie ^? ieSubspec&annJust of Just SubAll -> True; _ -> False)
narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> MaybeSubSpec dom -> MaybeSubSpec dom
narrowImportSubspecs [] = replaceWithNothing
narrowImportSubspecs usedNames
= annJust & essList .- filterList (\n -> fmap getName (semanticsName =<< (n ^? simpleName)) `elem` map Just usedNames)