module Language.Haskell.Tools.Refactor.Predefined.OrganizeImports (organizeImports, OrganizeImportsDomain, projectOrganizeImports) where
import ConLike (ConLike(..))
import DataCon (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 OccName (HasOccName(..), isSymOcc)
import qualified PrelNames as GHC (fromStringName)
import TyCon (TyCon(..), tyConFamInst_maybe)
import SrcLoc
import Control.Applicative ((<$>), Alternative(..))
import Control.Monad
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
import Debug.Trace
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 usedTyThings <- catMaybes <$> mapM lookupName usedNames
let dfs = semanticsDynFlags mod
noNarrowingImports
= xopt TemplateHaskell dfs
|| xopt QuasiQuotes dfs
|| (xopt FlexibleInstances dfs && noNarrowingSubspecs)
noNarrowingSubspecs
=
xopt GHC.StandaloneDeriving dfs || hasMarshalling
|| patternSynonymAreUsed usedTyThings
if noNarrowingImports
then
return $ modImports .- sortImports $ mod
else modImports !~ narrowImports noNarrowingSubspecs exportedModules (addFromString dfs usedNames) exportedNames prelInstances prelFamInsts . sortImports $ mod
where prelInstances = semanticsPrelOrphanInsts mod
prelFamInsts = semanticsPrelFamInsts mod
addFromString dfs = if xopt OverloadedStrings dfs then (GHC.fromStringName :) else id
usedNames = map getName $ catMaybes $ map semanticsName
$ (universeBi (mod ^. modHead) ++ universeBi (mod ^. modDecl) :: [QualifiedName dom])
exportedModules = "Prelude" : (mod ^? modHead & annJust & mhExports & annJust
& espExports & annList & exportModuleName & moduleNameString)
exports = mod ^? modHead & annJust & mhExports & annJust & espExports & annList & exportDecl
exportedNames = catMaybes $ map getExported exports
getExported e = fmap (,hasChild) name
where name = semanticsName (e ^. ieName & simpleName)
hasChild = (case e ^? ieSubspec & annJust of Just SubAll -> True; _ -> False)
|| not (null @[] (e ^? ieSubspec & annJust & essList & annList))
hasMarshalling = not $ null @[] (mod ^? modDecl & annList & declForeignType)
patternSynonymAreUsed tts = any (\case AConLike (PatSynCon _) -> True; _ -> False) tts
sortImports :: forall dom . ImportDeclList dom -> ImportDeclList dom
sortImports ls = srcInfo & srcTmpSeparators .= filter (not . null . fst) (concatMap (\(sep,elems) -> sep : map fst elems) reordered)
$ annListElems .= concatMap (map snd . snd) reordered
$ ls
where reordered :: [(([SourceTemplateTextElem], SrcSpan), [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)])]
reordered = map (_2 .- sortBy (compare `on` (^. _2 & importModule & AST.moduleNameString))) parts
parts = map (_2 .- reverse) $ reverse $ breakApart [] imports
breakApart :: [(([SourceTemplateTextElem], SrcSpan), [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)])]
-> [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)]
-> [(([SourceTemplateTextElem], SrcSpan), [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)])]
breakApart res [] = res
breakApart res ((sep, e) : rest) | length (filter ('\n' ==) (sep ^? _1 & traversal & sourceTemplateText & traversal)) > 1
|| "\n#" `isInfixOf` (sep ^? _1 & traversal & sourceTemplateText & traversal)
= breakApart ((sep, [(([], noSrcSpan),e)]) : res) rest
breakApart ((lastSep, lastRes) : res) (elem : rest)
= breakApart ((lastSep, elem : lastRes) : res) rest
breakApart [] ((sep, e) : rest)
= breakApart [(sep, [(([], noSrcSpan),e)])] rest
imports = zipWithSeparators ls
narrowImports :: forall dom . OrganizeImportsDomain dom
=> Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> [ClsInst] -> [FamInst] -> ImportDeclList dom -> LocalRefactor dom (ImportDeclList dom)
narrowImports noNarrowSubspecs exportedModules usedNames exportedNames prelInsts prelFamInsts imps
= (annListElems & traversal !~ narrowImport noNarrowSubspecs exportedModules usedNames exportedNames)
=<< filterListIndexedSt (\i _ -> impsNeeded !! i) imps
where impsNeeded = neededImports exportedModules (usedNames ++ map fst exportedNames) prelInsts prelFamInsts (imps ^. annListElems)
narrowImport :: OrganizeImportsDomain dom
=> Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> ImportDecl dom -> LocalRefactor dom (ImportDecl dom)
narrowImport noNarrowSubspecs exportedModules usedNames exportedNames 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 exportedNames $ imp
| importIsHiding imp
= return imp
| otherwise
= do namedThings <- mapM lookupName actuallyImported
let
hasRiskyDef = any isRiskyDef namedThings
groups = groupThings noNarrowSubspecs (semanticsImported imp)
(filter ((`elem` semanticsImported imp) . fst) exportedNames) (catMaybes namedThings)
return $ if not hasRiskyDef && length groups < 4
then importSpec .- replaceWithJust (createImportSpec groups) $ imp
else imp
where actuallyImported = semanticsImported imp `intersect` usedNames
isRiskyDef (Just (AConLike (PatSynCon _))) = True
isRiskyDef (Just (ATyCon tc)) = isSymOcc (occName (tyConName tc))
isRiskyDef _ = False
groupThings :: Bool -> [GHC.Name] -> [(GHC.Name, Bool)] -> [TyThing] -> [(GHC.Name, Bool)]
groupThings noNarrowSubspecs importable exported
= map last . groupBy ((==) `on` fst) . sort . (exported ++) . map createImportFromTyThing
where createImportFromTyThing :: TyThing -> (GHC.Name, Bool)
createImportFromTyThing tt | Just (td, isDataType) <- getTopDef tt
= if (td `elem` importable || isDataType) then (td, True)
else (getName tt, False)
createImportFromTyThing tt@(ATyCon {}) = (getName tt, noNarrowSubspecs)
createImportFromTyThing tt = (getName tt, False)
getTopDef :: TyThing -> Maybe (GHC.Name, Bool)
getTopDef (AnId id) | isRecordSelector id
= case recordSelectorTyCon id of RecSelData tc -> Just (getName tc, True)
RecSelPatSyn ps -> Just (getName ps, False)
getTopDef (AnId id)
| Just n <- fmap (getName . dataConTyCon) (isDataConWorkId_maybe id <|> isDataConId_maybe id)
= Just (n, True)
getTopDef (AnId id) = fmap ((,False) . getName) (isClassOpId_maybe id)
getTopDef (AConLike (RealDataCon dc))
= case tyConFamInst_maybe (dataConTyCon dc) of
Just (dataFam, _) -> Just (getName dataFam, True)
_ -> Just (getName $ dataConTyCon dc, True)
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] -> [(GHC.Name, Bool)] -> IESpecList dom -> LocalRefactor dom (IESpecList dom)
narrowImportSpecs noNarrowSubspecs usedNames exportedNames
= (if noNarrowSubspecs then return else return . (annList .- narrowImportSubspecs neededNames exportedNames))
>=> return . filterList isNeededSpec
where neededNames = usedNames ++ map fst exportedNames
isNeededSpec :: IESpec dom -> Bool
isNeededSpec ie =
(semanticsName (ie ^. ieName&simpleName)) `elem` map Just neededNames
|| ((ie ^? ieSubspec&annJust&essList&annList) /= [])
|| (case ie ^? ieSubspec&annJust of Just SubAll -> True; _ -> False)
narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> [(GHC.Name, Bool)] -> IESpec dom -> IESpec dom
narrowImportSubspecs neededNames exportedNames ss | noNarrowingForThis = ss
| otherwise
= ieSubspec & annJust & essList .- filterList (\n -> (semanticsName (n ^. simpleName)) `elem` map Just neededNames) $ ss
where noNarrowingForThis = case semanticsName (ss ^. ieName&simpleName) of
Just name -> lookup name exportedNames == Just True
_ -> False