diff --git a/Language/Haskell/Tools/Refactor.hs b/Language/Haskell/Tools/Refactor.hs --- a/Language/Haskell/Tools/Refactor.hs +++ b/Language/Haskell/Tools/Refactor.hs @@ -1,5 +1,5 @@ -- | Defines the API for refactorings -module Language.Haskell.Tools.Refactor +module Language.Haskell.Tools.Refactor ( module Language.Haskell.Tools.AST.SemaInfoClasses , module Language.Haskell.Tools.AST.Rewrite , module Language.Haskell.Tools.AST.References @@ -17,6 +17,7 @@ , sourceTemplateNodeRange, sourceTemplateNodeElems , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter + , SourceTemplateTextElem(..), sourceTemplateText ) where -- Important: Haddock doesn't support the rename all exported modules and export them at once hack diff --git a/Language/Haskell/Tools/Refactor/ChangeAST.hs b/Language/Haskell/Tools/Refactor/ChangeAST.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/ChangeAST.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE LambdaCase, TupleSections, AllowAmbiguousTypes #-} +-- | Operations for changing the AST +module Language.Haskell.Tools.Refactor.ChangeAST (removeChild, removeSeparator) where + +import Control.Reference +import Control.Monad.State +import Control.Monad.Writer +import Data.List +import Data.Maybe +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Transform +import Language.Haskell.Tools.Refactor.RefactorBase +import SrcLoc + +import Debug.Trace + +-- | Remove a separator from the AST while keeping the textual parts of it that should not be removed (like preprocessor pragmas). +removeSeparator :: ([SourceTemplateTextElem], SrcSpan) -> LocalRefactor dom () +removeSeparator (txts, range) = tell staying + where staying = mapMaybe (\case StayingText str lnEnd -> Just (Right (range, str, lnEnd)) + _ -> Nothing) txts + +-- | Remove an element from the AST while keeping the textual parts of it that should not be removed (like preprocessor pragmas). +removeChild :: (SourceInfoTraversal e) => e dom SrcTemplateStage -> LocalRefactor dom () +removeChild e = tell $ map Right $ keptText e + +-- | Extracts all text elements that should be kept +keptText :: SourceInfoTraversal e => e dom SrcTemplateStage -> [(SrcSpan,String,String)] +keptText = execWriter . sourceInfoTraverse (SourceInfoTrf + (\ni -> mapM_ writeStaying (mapMaybe (\case (TextElem elems range) -> Just (elems,range) + _ -> Nothing) + (ni ^? sourceTemplateNodeElems & traversal)) >> return ni) + (\ni -> mapM_ writeStaying (ni ^. srcTmpSeparators) >> return ni) + pure) + +-- | Writes the elements to be kept into a writer monad with ranges and default line ending. +writeStaying :: ([SourceTemplateTextElem], SrcSpan) -> Writer [(SrcSpan,String,String)] () +writeStaying (txts, range) = tell staying + where staying = mapMaybe (\case StayingText str lnEnd -> Just (range, str, lnEnd) + _ -> Nothing) txts diff --git a/Language/Haskell/Tools/Refactor/GetModules.hs b/Language/Haskell/Tools/Refactor/GetModules.hs --- a/Language/Haskell/Tools/Refactor/GetModules.hs +++ b/Language/Haskell/Tools/Refactor/GetModules.hs @@ -104,7 +104,10 @@ instance Show ModuleRecord where show (ModuleNotLoaded code) = "ModuleNotLoaded " ++ show code - show mr = GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS + show mr@(ModuleParsed {}) = "ModuleParsed (" ++ (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS) ++ ")" + show mr@(ModuleRenamed {}) = "ModuleRenamed (" ++ (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS) ++ ")" + show mr@(ModuleTypeChecked {}) = "ModuleTypeChecked (" ++ (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS) ++ ")" + show mr@(ModuleCodeGenerated {}) = "ModuleCodeGenerated (" ++ (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS) ++ ")" -- | Find the module collection where the given module is. lookupModuleColl :: String -> [ModuleCollection] -> Maybe (ModuleCollection) @@ -122,7 +125,7 @@ needsGeneratedCode :: SourceFileKey -> [ModuleCollection] -> Bool needsGeneratedCode key = maybe False (\case (_, ModuleCodeGenerated {}) -> True; (_, ModuleNotLoaded True) -> True; _ -> False) - . find ((key ==) . fst) . concatMap (Map.assocs . (^. mcModules)) + . find (((sfkIsBoot .= NormalHs $ key) ==) . fst) . concatMap (Map.assocs . (^. mcModules)) codeGeneratedFor :: SourceFileKey -> [ModuleCollection] -> [ModuleCollection] codeGeneratedFor key = map (mcModules .- Map.adjust (\case (ModuleTypeChecked mod ms) -> ModuleCodeGenerated mod ms diff --git a/Language/Haskell/Tools/Refactor/Helpers.hs b/Language/Haskell/Tools/Refactor/Helpers.hs --- a/Language/Haskell/Tools/Refactor/Helpers.hs +++ b/Language/Haskell/Tools/Refactor/Helpers.hs @@ -6,29 +6,33 @@ module Language.Haskell.Tools.Refactor.Helpers where import Control.Reference +import Control.Monad.Writer +import Control.Monad.State import Data.Function (on) -import Data.List (sortBy, nubBy) +import Data.List (sortBy, nubBy, partition) +import Data.Maybe import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.Rewrite as AST import Language.Haskell.Tools.Refactor.ListOperations (filterList) -import SrcLoc (srcSpanStart) +import SrcLoc +import Language.Haskell.Tools.Transform -replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom +replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom replaceWithJust e = annMaybe .= Just e -replaceWithNothing :: AnnMaybe e dom -> AnnMaybe e dom +replaceWithNothing :: AnnMaybe e dom -> AnnMaybe e dom replaceWithNothing = annMaybe .= Nothing -- | Remove the container (where or let) when the last binding is removed. -removeEmptyBnds :: Simple Traversal (Module dom) (ValueBind dom) +removeEmptyBnds :: Simple Traversal (Module dom) (ValueBind dom) -> Simple Traversal (Module dom) (Expr dom) -> AST.Module dom -> AST.Module dom removeEmptyBnds binds exprs = (binds .- removeEmptyBindsAndGuards) . (exprs .- removeEmptyLetsAndStmts) - where removeEmptyBindsAndGuards sb@(SimpleBind _ _ _) + where removeEmptyBindsAndGuards sb@(SimpleBind _ _ _) = (valBindLocals .- removeIfEmpty) . (valBindRhs .- removeEmptyGuards) $ sb - removeEmptyBindsAndGuards fb@(FunctionBind _) + removeEmptyBindsAndGuards fb@(FunctionBind _) = (funBindMatches & annList & matchBinds .- removeIfEmpty) . (funBindMatches & annList & matchRhs .- removeEmptyGuards) $ fb removeEmptyGuards rhs = rhsGuards & annList & guardStmts .- filterList (\case GuardLet (AnnList []) -> False; _ -> True) $ rhs @@ -39,7 +43,7 @@ removeEmptyLetsAndStmts (Let (AnnList []) e) = e removeEmptyLetsAndStmts e = exprStmts .- removeEmptyStmts $ e - removeEmptyStmts ls = (annList & cmdStmtBinds .- removeEmptyStmts) + removeEmptyStmts ls = (annList & cmdStmtBinds .- removeEmptyStmts) . filterList (\case LetStmt (AnnList []) -> False; _ -> True) $ ls -- | Puts the elements in the orginal order and remove duplicates (elements with the same source range) diff --git a/Language/Haskell/Tools/Refactor/ListOperations.hs b/Language/Haskell/Tools/Refactor/ListOperations.hs --- a/Language/Haskell/Tools/Refactor/ListOperations.hs +++ b/Language/Haskell/Tools/Refactor/ListOperations.hs @@ -4,34 +4,59 @@ module Language.Haskell.Tools.Refactor.ListOperations where import Control.Reference +import Control.Applicative +import Control.Monad.IO.Class import Data.List (findIndices) import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.Rewrite (AnnList) -import Language.Haskell.Tools.Transform (srcTmpDefaultSeparator, srcTmpSeparators, srcTmpIndented) +import Language.Haskell.Tools.Transform +import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.ChangeAST +import SrcLoc -- | Filters the elements of the list. By default it removes the separator before the element. -- Of course, if the first element is removed, the following separator is removed as well. -filterList :: (Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom -> AnnList e dom +filterList :: SourceInfoTraversal e => (Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom -> AnnList e dom filterList pred = filterListIndexed (const pred) -filterListIndexed :: (Int -> Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom -> AnnList e dom +filterListIndexed :: SourceInfoTraversal e => (Int -> Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom -> AnnList e dom filterListIndexed pred (AnnListG (NodeInfo sema src) elems) - = AnnListG (NodeInfo sema (srcTmpIndented .- fmap filterIndents $ srcTmpSeparators .- filterSeparators $ src)) filteredElems + = AnnListG (NodeInfo sema (srcTmpIndented .- fmap filterIndents $ srcTmpSeparators .- filterSeparators $ src)) filteredElems where elementsKept = findIndices (uncurry pred) (zip [0..] elems) filteredElems = sublist elementsKept elems filterIndents = sublist elementsKept filterSeparators = take (length elementsKept - 1) . sublist elementsKept +-- | A version of filterList that cares about keeping non-removable code elements (like preprocessor pragmas) +filterListSt :: SourceInfoTraversal e => (Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom -> LocalRefactor dom (AnnList e dom) +filterListSt pred = filterListIndexedSt (const pred) + +-- | A version of filterListIndexed that cares about keeping non-removable code elements (like preprocessor pragmas) +filterListIndexedSt :: SourceInfoTraversal e => (Int -> Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom -> LocalRefactor dom (AnnList e dom) +filterListIndexedSt pred (AnnListG (NodeInfo sema src) elems) + = do mapM_ removeChild removedElems + mapM_ removeSeparator removedSeparators + return $ AnnListG (NodeInfo sema (srcTmpIndented .- fmap filterIndents $ srcTmpSeparators .- filterSeparators $ src)) filteredElems + where elementsKept = findIndices (uncurry pred) (zip [0..] elems) + filteredElems = sublist elementsKept elems + removedSeparators :: [([SourceTemplateTextElem], SrcSpan)] + removedSeparators = notSublist elementsKept (src ^. srcTmpSeparators) ++ lastSepRemoved + lastSepRemoved = if (length elems - 1) `notElem` elementsKept + then take 1 (reverse (sublist elementsKept $ src ^. srcTmpSeparators)) else [] + removedElems = notSublist elementsKept elems + filterIndents = sublist elementsKept + filterSeparators = take (length elementsKept - 1) . sublist elementsKept + + -- | Selects the given indices from a list sublist :: [Int] -> [a] -> [a] -sublist = sublist' 0 - where sublist' i [] _ = [] - sublist' i _ [] = [] - sublist' i (ind:more) (e:rest) - | i == ind = e : sublist' (i+1) more rest - | otherwise = sublist' (i+1) (ind:more) rest +sublist indices = map snd . filter ((`elem` indices) . fst) . zip [0..] +-- | Selects all but the given indices from a list +notSublist :: [Int] -> [a] -> [a] +notSublist indices = map snd . filter ((`notElem` indices) . fst) . zip [0..] + -- | Inserts the element in the places where the two positioning functions (one checks the element before, one the element after) -- allows the placement. insertWhere :: Bool -> Ann e dom SrcTemplateStage -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) @@ -45,7 +70,7 @@ $ (if isEmptyAnnList then id else annListAnnot&sourceInfo .- setIndented ind . addDefaultSeparator ind) $ al where setIndented i = srcTmpIndented .- fmap (insertAt i indented) - addDefaultSeparator i al = srcTmpSeparators .- insertAt i (al ^. srcTmpDefaultSeparator) $ al + addDefaultSeparator i al = srcTmpSeparators .- insertAt i ([NormalText $ al ^. srcTmpDefaultSeparator], noSrcSpan) $ al insertAt n e ls = let (bef,aft) = splitAt n ls in bef ++ [e] ++ aft isEmptyAnnList = (null :: [x] -> Bool) $ (al ^? annList) @@ -69,10 +94,10 @@ -- | Gets the elements and separators from a list. The first separator is zipped to the second element. -- To the first element, the "" string is zipped. -zipWithSeparators :: AnnList e dom -> [(String, Ann e dom SrcTemplateStage)] +zipWithSeparators :: AnnList e dom -> [(([SourceTemplateTextElem], SrcSpan), Ann e dom SrcTemplateStage)] zipWithSeparators (AnnListG (NodeInfo _ src) elems) | [] <- src ^. srcTmpSeparators - = zip ("" : repeat (src ^. srcTmpDefaultSeparator)) elems + = zip (([], noSrcSpan) : repeat ([NormalText $ src ^. srcTmpDefaultSeparator], noSrcSpan)) elems | otherwise - = zip ("" : seps ++ repeat (last seps)) elems + = zip (([], noSrcSpan) : seps ++ repeat (_2 .= noSrcSpan $ last seps)) elems where seps = src ^. srcTmpSeparators diff --git a/Language/Haskell/Tools/Refactor/Predefined/InlineBinding.hs b/Language/Haskell/Tools/Refactor/Predefined/InlineBinding.hs --- a/Language/Haskell/Tools/Refactor/Predefined/InlineBinding.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/InlineBinding.hs @@ -30,7 +30,7 @@ type InlineBindingDomain dom = ( HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom, HasModuleInfo dom ) inlineBinding :: forall dom . InlineBindingDomain dom => RealSrcSpan -> Refactoring dom -inlineBinding span namedMod@(_,mod) mods +inlineBinding span namedMod@(_,mod) mods = let topLevel :: Simple Traversal (Module dom) (DeclList dom) topLevel = nodesContaining span local :: Simple Traversal (Module dom) (LocalBindList dom) @@ -40,58 +40,58 @@ elemAccess :: (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom) elemAccess = getValBindInList span removed = catMaybes $ map elemAccess (mod ^? topLevel) ++ map elemAccess (mod ^? local) - in case reverse removed of + in case reverse removed of [] -> refactError "No binding is selected." - removedBinding:_ -> + removedBinding:_ -> let [removedBindingName] = nub $ catMaybes $ map semanticsName (removedBinding ^? bindingName) in if | any (containInlined removedBindingName) mods - -> refactError "Cannot inline the definition, it is used in other modules." - | _:_ <- mod ^? modHead & annJust & mhExports & annJust & biplateRef + -> refactError "Cannot inline the definition, it is used in other modules." + | _:_ <- mod ^? modHead & annJust & mhExports & annJust & biplateRef & filtered (\n -> semanticsName (n :: QualifiedName dom) == Just removedBindingName) -> refactError "Cannot inline the definition, it is present in the export list." | otherwise -> localRefactoring (inlineBinding' topLevel local exprs removedBinding removedBindingName) namedMod mods -- | Performs the inline binding on a single module. -inlineBinding' :: InlineBindingDomain dom - => Simple Traversal (Module dom) (DeclList dom) - -> Simple Traversal (Module dom) (LocalBindList dom) - -> Simple Traversal (Module dom) (Expr dom) +inlineBinding' :: InlineBindingDomain dom + => Simple Traversal (Module dom) (DeclList dom) + -> Simple Traversal (Module dom) (LocalBindList dom) + -> Simple Traversal (Module dom) (Expr dom) -> ValueBind dom -> GHC.Name -> LocalRefactoring dom inlineBinding' topLevelRef localRef exprRef removedBinding removedBindingName mod = do replacement <- createReplacement removedBinding let RealSrcSpan bindingSpan = getRange removedBinding (mod', used) <- runStateT (descendBiM (replaceInvocations bindingSpan removedBindingName replacement) mod) False - if not used + if not used then refactError "The selected definition is not used, it can be safely deleted." else return $ removeBindingAndSig topLevelRef localRef exprRef removedBindingName mod' -- | True if the given module contains the name of the inlined definition. containInlined :: forall dom . InlineBindingDomain dom => GHC.Name -> ModuleDom dom -> Bool -containInlined name (_,mod) +containInlined name (_,mod) = any (\qn -> semanticsName qn == Just name) $ (mod ^? biplateRef :: [QualifiedName dom]) -- | Removes the inlined binding and the accompanying type and fixity signatures. -removeBindingAndSig :: InlineBindingDomain dom - => Simple Traversal (Module dom) (DeclList dom) - -> Simple Traversal (Module dom) (LocalBindList dom) - -> Simple Traversal (Module dom) (Expr dom) +removeBindingAndSig :: InlineBindingDomain dom + => Simple Traversal (Module dom) (DeclList dom) + -> Simple Traversal (Module dom) (LocalBindList dom) + -> Simple Traversal (Module dom) (Expr dom) -> GHC.Name -> AST.Module dom -> AST.Module dom removeBindingAndSig topLevelRef localRef exprRef name - = removeEmptyBnds (topLevelRef & annList & declValBind &+& localRef & annList & localVal) exprRef + = removeEmptyBnds (topLevelRef & annList & declValBind &+& localRef & annList & localVal) exprRef . (topLevelRef .- removeBindingAndSig' name) . (localRef .- removeBindingAndSig' name) -removeBindingAndSig' :: (InlineBindingDomain dom, BindingElem d) => GHC.Name -> AnnList d dom -> AnnList d dom +removeBindingAndSig' :: SourceInfoTraversal d => (InlineBindingDomain dom, BindingElem d) => GHC.Name -> AnnList d dom -> AnnList d dom removeBindingAndSig' name = (annList .- removeNameFromSigBind) . filterList notThatBindOrSig - where notThatBindOrSig e + where notThatBindOrSig e | Just sb <- e ^? sigBind = nub (map semanticsName (sb ^? tsName & annList & simpleName)) /= [Just name] | Just vb <- e ^? valBind = nub (map semanticsName (vb ^? bindingName)) /= [Just name] | Just fs <- e ^? fixitySig = nub (map semanticsName (fs ^? fixityOperators & annList & operatorName)) /= [Just name] | otherwise = True - - removeNameFromSigBind d - | Just sb <- d ^? sigBind + + removeNameFromSigBind d + | Just sb <- d ^? sigBind = createTypeSig $ tsName .- filterList (\n -> semanticsName (n ^. simpleName) /= Just name) $ sb | Just fs <- d ^? fixitySig = createFixitySig $ fixityOperators .- filterList (\n -> semanticsName (n ^. operatorName) /= Just name) $ fs @@ -99,22 +99,22 @@ -- | As a top-down transformation, replaces the occurrences of the binding with generated expressions. This method passes -- the captured arguments of the function call to generate simpler results. -replaceInvocations :: InlineBindingDomain dom +replaceInvocations :: InlineBindingDomain dom => RealSrcSpan -> GHC.Name -> ([[GHC.Name]] -> [Expr dom] -> Expr dom) -> Expr dom -> StateT Bool (LocalRefactor dom) (Expr dom) replaceInvocations bindingRange name replacement expr | (Var n, args) <- splitApps expr , semanticsName (n ^. simpleName) == Just name - = case getRange expr of + = case getRange expr of RealSrcSpan ownRange | bindingRange `containsSpan` ownRange -> lift $ refactError "Cannot inline definitions containing direct recursion." _ -> do put True replacement (semanticsScope expr) <$> mapM (descendM (replaceInvocations bindingRange name replacement)) args - | otherwise + | otherwise = descendM (replaceInvocations bindingRange name replacement) expr -- | Splits an application into function and arguments. Works also for operators. splitApps :: Expr dom -> (Expr dom, [Expr dom]) -splitApps (App f a) = case splitApps f of (fun, args) -> (fun, args ++ [a]) +splitApps (App f a) = case splitApps f of (fun, args) -> (fun, args ++ [a]) splitApps (InfixApp l (NormalOp qn) r) = (mkVar (mkParenName qn), [l,r]) splitApps (InfixApp l (BacktickOp qn) r) = (mkVar (mkNormalName qn), [l,r]) splitApps (Paren expr) = splitApps expr @@ -127,7 +127,7 @@ -- | Create an expression that is equivalent to calling the given bind. createReplacement :: InlineBindingDomain dom => ValueBind dom -> LocalRefactor dom ([[GHC.Name]] -> [Expr dom] -> Expr dom) -createReplacement (SimpleBind (VarPat _) (UnguardedRhs e) locals) +createReplacement (SimpleBind (VarPat _) (UnguardedRhs e) locals) = return $ \_ args -> joinApps (parenIfNeeded $ wrapLocals locals e) args createReplacement (SimpleBind _ _ _) = refactError "Cannot inline, illegal simple bind. Only variable left-hand sides and unguarded right-hand sides are accepted." @@ -140,9 +140,9 @@ -- function bind has at least one match = return $ \sc args -> let numArgs = getArgNum (head (matches ^? annList & matchLhs)) - length args newArgs = take numArgs $ map mkName $ filter notInScope $ map (("x" ++ ) . show @Int) [1..] - notInScope str = not $ any (any ((== str) . occNameString . getOccName)) sc - in parenIfNeeded $ createLambda (map mkVarPat newArgs) - $ mkCase (mkTuple $ map mkVar newArgs ++ args) + notInScope str = not $ any (any ((== str) . occNameString . getOccName)) sc + in parenIfNeeded $ createLambda (map mkVarPat newArgs) + $ mkCase (mkTuple $ map mkVar newArgs ++ args) $ map replaceMatch (matches ^? annList) where getArgNum (MatchLhs _ (AnnList args)) = length args getArgNum (InfixLhs _ _ _ (AnnList more)) = length more + 2 @@ -150,7 +150,7 @@ -- | Replaces names with expressions according to a mapping. replaceExprs :: InlineBindingDomain dom => [(GHC.Name, Expr dom)] -> Expr dom -> Expr dom replaceExprs [] = id -replaceExprs replaces = (uniplateRef .-) $ \case +replaceExprs replaces = (uniplateRef .-) $ \case Var n | Just name <- semanticsName (n ^. simpleName) , Just replace <- lookup name replaces -> replace @@ -159,10 +159,10 @@ -- | Matches a pattern list with an expression list and generates bindings. Matches until an argument cannot be matched. matchArguments :: InlineBindingDomain dom => [Pattern dom] -> [Expr dom] -> ([(GHC.Name, Expr dom)], [Pattern dom], [Expr dom]) matchArguments (ParenPat p : pats) exprs = matchArguments (p:pats) exprs -matchArguments (p:pats) (e:exprs) +matchArguments (p:pats) (e:exprs) | Just replacement <- staticPatternMatch p e = case matchArguments pats exprs of (replacements, patterns, expressions) -> (replacement ++ replacements, patterns, expressions) - | otherwise + | otherwise = ([], p:pats, e:exprs) matchArguments pats [] = ([], pats, []) matchArguments [] exprs = ([], [], exprs) @@ -172,9 +172,9 @@ staticPatternMatch (VarPat n) e | Just name <- semanticsName $ n ^. simpleName = Just [(name, e)] -staticPatternMatch (AppPat n (AnnList args)) e +staticPatternMatch (AppPat n (AnnList args)) e | (Var n', exprs) <- splitApps e - , length args == length exprs + , length args == length exprs && semanticsName (n ^. simpleName) == semanticsName (n' ^. simpleName) , Just subs <- sequence $ zipWith staticPatternMatch args exprs = Just $ concat subs @@ -195,9 +195,9 @@ toAltGuardedRhs (GuardedRhs (AnnList guards) expr) = mkGuardedCaseRhs guards expr wrapLocals :: MaybeLocalBinds dom -> Expr dom -> Expr dom -wrapLocals bnds = case bnds ^? annJust & localBinds & annList of +wrapLocals bnds = case bnds ^? annJust & localBinds & annList of [] -> id - localBinds -> mkLet localBinds + localBinds -> mkLet localBinds -- | True for patterns that need to be parenthesized if in a lambda compositePat :: Pattern dom -> Bool @@ -223,4 +223,4 @@ createLambda :: [Pattern dom] -> Expr dom -> Expr dom createLambda [] = id -createLambda pats = mkLambda (map (\p -> if compositePat p then mkParenPat p else p) pats) +createLambda pats = mkLambda (map (\p -> if compositePat p then mkParenPat p else p) pats) diff --git a/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs b/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs --- a/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs @@ -22,6 +22,7 @@ import OccName (HasOccName(..), isSymOcc) import qualified PrelNames as GHC (fromStringName) import TyCon (TyCon(..), tyConFamInst_maybe) +import SrcLoc import Control.Applicative ((<$>), Alternative(..)) import Control.Monad @@ -33,6 +34,8 @@ 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 @@ -86,22 +89,26 @@ -- | Sorts the imports in alphabetical order sortImports :: forall dom . ImportDeclList dom -> ImportDeclList dom -sortImports ls = srcInfo & srcTmpSeparators .= filter (not . null) (concatMap (\(sep,elems) -> sep : map fst elems) reordered) +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 :: [(String, [(String, ImportDecl dom)])] + 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 :: [(String, [(String, ImportDecl dom)])] -> [(String, ImportDecl dom)] -> [(String, [(String, ImportDecl dom)])] + -- break up the list of imports to import groups + 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 - = breakApart ((sep, [("",e)]) : res) rest + 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, [("",e)])] rest + = breakApart [(sep, [(([], noSrcSpan),e)])] rest imports = zipWithSeparators ls @@ -109,8 +116,8 @@ 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 - $ filterListIndexed (\i _ -> impsNeeded !! i) 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) -- | Reduces the number of definitions used from an import diff --git a/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs b/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs --- a/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs @@ -10,9 +10,15 @@ #-} module Language.Haskell.Tools.Refactor.Predefined.RenameDefinition (renameDefinition, renameDefinition', DomainRenameDefinition) where -import qualified GHC (RealSrcSpan, NamedThing(..), Name) +import qualified GHC import Name (OccName(..), NamedThing(..), occNameString) import SrcLoc (RealSrcSpan) +import Id +import IdInfo +import Outputable +import Type +import TyCon +import DataCon import Control.Monad.State import Control.Reference as Ref @@ -20,6 +26,7 @@ import Data.List import Data.List.Split (splitOn) import Data.Maybe +import Debug.Trace import Language.Haskell.Tools.Refactor @@ -34,16 +41,17 @@ where bindsWithSameName :: GHC.Name -> [FieldWildcard dom] -> [GHC.Name] bindsWithSameName name wcs = catMaybes $ map ((lookup name) . semanticsImplicitFlds) wcs Nothing -> case getNodeContaining sp (snd mod) of - Just modName -> renameModule (modName ^. moduleNameString) str mod mods + Just modName -> renameModule (any @[] (sp `isInside`) ((snd mod) ^? modImports&annList&importAs)) + (modName ^. moduleNameString) str mod mods Nothing -> refactError "No name is selected" -renameModule :: forall dom . DomainRenameDefinition dom => String -> String -> Refactoring dom -renameModule from to m mods +renameModule :: forall dom . DomainRenameDefinition dom => Bool -> String -> String -> Refactoring dom +renameModule isAlias from to m mods | any (nameConflict to) (map snd $ m:mods) = refactError "Name conflict when renaming module" | isJust (validModuleName to) = refactError $ "The given name is not a valid module name: " ++ fromJust (validModuleName to) | otherwise = -- here it is important that the delete is the last, because rename -- can still use the info about the deleted module - fmap (\ls -> map (alterChange from to) ls ++ [ModuleRemoved from]) + (if isAlias then id else (fmap (\ls -> map (alterChange from to) ls ++ [ModuleRemoved from]))) $ mapM (\(name,mod) -> ContentChanged . (name,) <$> localRefactoringRes id mod (replaceModuleNames =<< alterNormalNames mod)) (m:mods) where alterChange from to (ContentChanged (mod,res)) | (mod ^. sfkModuleName) == from @@ -54,14 +62,9 @@ replaceModuleNames = biplateRef @_ @(ModuleName dom) & filtered (\e -> (e ^. moduleNameString) == from) != mkModuleName to alterNormalNames :: LocalRefactoring dom - alterNormalNames mod = if from `elem` moduleQualifiers mod - then biplateRef @_ @(QualifiedName dom) & filtered (\e -> concat (intersperse "." (e ^? qualifiers&annList&simpleNameStr)) == from) - !- (\e -> mkQualifiedName (splitOn "." to) (e ^. unqualifiedName&simpleNameStr)) $ mod - else return mod - - moduleQualifiers :: Module dom -> [String] - moduleQualifiers mod = mod ^? modImports & annList & filtered (\m -> isAnnNothing (m ^. importAs)) - & importModule & moduleNameString + alterNormalNames mod = + biplateRef @_ @(QualifiedName dom) & filtered (\e -> concat (intersperse "." (e ^? qualifiers&annList&simpleNameStr)) == from) + !- (\e -> mkQualifiedName (splitOn "." to) (e ^. unqualifiedName&simpleNameStr)) $ mod nameConflict :: String -> Module dom -> Bool nameConflict to mod @@ -81,16 +84,21 @@ renameInAModule :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> ModuleDom dom -> StateT Bool Refactor (Maybe (ModuleDom dom)) renameInAModule toChangeOrig toChangeWith newName (name, mod) = mapStateT (localRefactoringRes (\f (a,s) -> (fmap (\(n,r) -> (n, f r)) a,s)) mod) $ - do (res, isChanged) <- runStateT (biplateRef !~ changeName toChangeOrig toChangeWith newName $ mod) False + do origTT <- GHC.lookupName toChangeOrig + let origId = case origTT of + Just (GHC.AnId id) -> Just id + _ -> Nothing + (res, isChanged) <- runStateT (biplateRef !~ changeName toChangeOrig origId toChangeWith newName $ mod) False if isChanged then return $ Just (name, res) else return Nothing - changeName :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> QualifiedName dom + changeName :: DomainRenameDefinition dom => GHC.Name -> Maybe Id -> [GHC.Name] -> String -> QualifiedName dom -> StateT Bool (StateT Bool (LocalRefactor dom)) (QualifiedName dom) - changeName toChangeOrig toChangeWith str name + changeName toChangeOrig origId toChangeWith str name | maybe False (`elem` toChange) actualName && semanticsDefining name == False - && any @[] ((str ==) . occNameString . getOccName) (semanticsScope name ^? Ref.element 0 & traversal & filtered (sameNamespace toChangeOrig)) + && any @[] (\n -> str == occNameString (getOccName n) && not (mergeableFields origId n)) + (scopeUpToDef (semanticsScope name) ^? traversal & traversal & filtered (sameNamespace toChangeOrig)) = refactError $ "The definition clashes with an existing one at: " ++ shortShowSpan (getRange name) -- name clash with an external definition | maybe False (`elem` toChange) actualName = do put True -- state that something is changed in the local state @@ -99,13 +107,24 @@ return $ unqualifiedName .= mkNamePart str $ name -- found the changed name (or a name that have to be changed too) | let namesInScope = semanticsScope name in case semanticsName name of - Just (getName -> exprName) -> str == occNameString (getOccName exprName) && sameNamespace toChangeOrig exprName + Just (getName -> exprName) -> str == occNameString (getOccName exprName) + && sameNamespace toChangeOrig exprName && conflicts toChangeOrig exprName namesInScope + && not (mergeableFields origId exprName) Nothing -> False -- ambiguous names = refactError $ "The definition clashes with an existing one: " ++ shortShowSpan (getRange name) -- local name clash | otherwise = return name -- not the changed name, leave as before where toChange = toChangeOrig : toChangeWith actualName = fmap getName (semanticsName name) + scopeUpToDef sc = let (inside, outside) = span (null . (toChange `intersect`)) sc + in inside ++ take 1 outside + mergeableFields (Just orig) conflict + | isRecordSelector orig + , RecSelData tc <- recordSelectorTyCon orig + = let selectorsWithTypes = concatMap (\dc -> map (\fld -> (flSelector fld, dataConFieldType dc (flLabel fld))) (dataConFieldLabels dc)) + (filter (\dc -> toChangeOrig `notElem` map flSelector (dataConFieldLabels dc)) (tyConDataCons tc)) + in maybe False (`eqType` funResultTy (idType orig)) (lookup conflict selectorsWithTypes) + mergeableFields _ _ = False conflicts :: GHC.Name -> GHC.Name -> [[GHC.Name]] -> Bool conflicts overwrites overwritten (scopeBlock : scope) diff --git a/Language/Haskell/Tools/Refactor/RefactorBase.hs b/Language/Haskell/Tools/Refactor/RefactorBase.hs --- a/Language/Haskell/Tools/Refactor/RefactorBase.hs +++ b/Language/Haskell/Tools/Refactor/RefactorBase.hs @@ -8,12 +8,14 @@ , TypeSynonymInstances , MultiWayIf , TemplateHaskell + , ViewPatterns #-} -- | Basic utilities and types for defining refactorings. module Language.Haskell.Tools.Refactor.RefactorBase where import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.Transform import Bag as GHC import DynFlags (HasDynFlags(..)) @@ -26,14 +28,17 @@ import qualified PrelNames as GHC import qualified TyCon as GHC import qualified TysWiredIn as GHC +import SrcLoc import Control.Exception import Control.Monad.Reader -import Control.Monad.State +import qualified Control.Monad.State as LazySt +import Control.Monad.State.Strict import Control.Monad.Trans.Except import Control.Monad.Writer import Control.Reference hiding (element) import Data.Char +import Data.Either import Data.Function (on) import Data.List import Data.List.Split @@ -109,9 +114,78 @@ -> Refactor a localRefactoringRes access mod trf = let init = RefactorCtx (semanticsModule $ mod ^. semantics) mod (mod ^? modImports&annList) - in flip runReaderT init $ do (mod, newNames) <- runWriterT (fromRefactorT trf) - return $ access (addGeneratedImports newNames) mod + in flip runReaderT init $ do (mod, recorded) <- runWriterT (fromRefactorT trf) + return $ access (insertText (rights recorded) . addGeneratedImports (lefts recorded)) mod +-- | Re-inserts the elements removed from the AST that should be kept (for example preprocessor directives) +insertText :: SourceInfoTraversal p => [(SrcSpan,String,String)] -> p dom SrcTemplateStage -> p dom SrcTemplateStage +insertText [] p = p +insertText inserted p + -- this traverses the AST and finds the positions where the removed elements can be added + = evalState (sourceInfoTraverseUp (SourceInfoTrf + (\stn -> sourceTemplateNodeElems !~ takeWhatPrecedesElem (stn ^. sourceTemplateNodeRange) $ stn) + (srcTmpSeparators !~ takeWhatPrecedesSep) + pure) (return ()) (return ()) p) (map Right $ sortOn (^. _1) inserted) + where + -- insert fragments into list separators + takeWhatPrecedesSep :: [([SourceTemplateTextElem], SrcSpan)] -> State [Either SrcSpan (SrcSpan,String,String)] [([SourceTemplateTextElem], SrcSpan)] + takeWhatPrecedesSep seps = takeWhatPrecedes Nothing (Just . (^. _2)) + (\str -> _1 .- (++ [StayingText str ""])) + (\str -> _1 .- ([StayingText str ""] ++)) + seps + + -- insert fragments into AST elements + takeWhatPrecedesElem :: SrcSpan -> [SourceTemplateElem] -> State [Either SrcSpan (SrcSpan,String,String)] [SourceTemplateElem] + takeWhatPrecedesElem rng elems = takeWhatPrecedes (Just rng) (^? sourceTemplateTextRange) + (\s -> sourceTemplateTextElem .- (++ [StayingText s ""])) + (\s -> sourceTemplateTextElem .- ([StayingText s ""] ++)) + elems + + -- finds the position of the fragment where there are elements in the template both before and after the fragment + -- puts holes into the list of inserted fragments where child elements are located + -- uses these holes to determine where should the fragment be added + takeWhatPrecedes :: Maybe SrcSpan -> (a -> Maybe SrcSpan) -> (String -> a -> a) -> (String -> a -> a) -> [a] -> State [Either SrcSpan (SrcSpan,String,String)] [a] + takeWhatPrecedes rng access append prepend elems + | ranges <- mapMaybe access elems + , not (null ranges) + = do let start = srcSpanStart $ fromMaybe (head ranges) rng + end = srcSpanEnd $ fromMaybe (last ranges) rng + toInsert <- get + let (prefix,rest) = break ((>= start) . srcSpanStart . either id (\(sp,_,_) -> sp)) toInsert + (middle,suffix) = break ((> end) . srcSpanEnd . either id (\(sp,_,_) -> sp)) rest + put $ prefix ++ Left (mkSrcSpan start end) : suffix + return $ mergeInserted access append prepend False middle elems + where mergeInserted :: (a -> Maybe SrcSpan) -> (String -> a -> a) -> (String -> a -> a) -> Bool -> [Either SrcSpan (SrcSpan,String,String)] -> [a] -> [a] + -- no fragments left + mergeInserted _ _ _ _ [] elems = elems + mergeInserted access append prepend prep insert@(Right (insertSpan,insertStr,ln):toInsert) (fstElem:elems) + -- insert a fragment to the end of the current element if the next elment is after the fragment + | Just fstElemSpace <- access fstElem -- TODO: is this needed? + , not prep && case mapMaybe access elems of sp:_ -> srcSpanStart sp >= srcSpanEnd insertSpan + _ -> True + = mergeInserted access append prepend prep toInsert (append (ln ++ insertStr ++ ln) fstElem : elems) + -- insert the fragment before the current elem if we need an element before (we skipped a child) + -- and the current element is after the inserted fragment + | Just fstElemSpace <- access fstElem + , prep && srcSpanStart fstElemSpace >= srcSpanEnd insertSpan + = mergeInserted access append prepend prep toInsert (prepend (ln ++ insertStr ++ ln) fstElem : elems) + | isJust (access fstElem) && prep + = mergeInserted access append prepend False insert (fstElem : elems) -- switch back to append mode + | otherwise + = fstElem : mergeInserted access append prepend (if isJust (access fstElem) then False else prep) insert elems -- move on and switch back to append mode + -- when found a hole + mergeInserted access append prepend prep insert@(Left sp : toInsert) (fstElem:elems) + | Just fstElemSpace <- access fstElem + = if srcSpanStart fstElemSpace > srcSpanEnd sp + -- switch to prepend mode + then mergeInserted access append prepend True toInsert (fstElem:elems) + -- skip elements that are not after the fragment + else fstElem : mergeInserted access append prepend prep insert elems + | otherwise + = fstElem : mergeInserted access append prepend True toInsert elems -- switch to prepend mode and move on + mergeInserted _ _ _ _ _ [] = [] -- maybe error + takeWhatPrecedes _ _ _ _ elems = return elems + -- | Adds the imports that bring names into scope that are needed by the refactoring addGeneratedImports :: [GHC.Name] -> Ann UModule dom SrcTemplateStage -> Ann UModule dom SrcTemplateStage addGeneratedImports names m = modImports&annListElems .- (++ addImports names) $ m @@ -145,6 +219,18 @@ gcatch r c = StateT (\ctx -> runStateT r ctx `gcatch` (flip runStateT ctx . c)) gmask m = StateT $ \ctx -> gmask (\f -> runStateT (m (\a -> StateT $ \ctx' -> f (runStateT a ctx'))) ctx) +instance (Monad m, HasDynFlags m) => HasDynFlags (LazySt.StateT s m) where + getDynFlags = lift getDynFlags + +instance (GhcMonad m) => GhcMonad (LazySt.StateT s m) where + getSession = lift getSession + setSession env = lift (setSession env) + +instance (ExceptionMonad m) => ExceptionMonad (LazySt.StateT s m) where + gcatch r c = LazySt.StateT (\ctx -> LazySt.runStateT r ctx `gcatch` (flip LazySt.runStateT ctx . c)) + gmask m = LazySt.StateT $ \ctx -> gmask (\f -> LazySt.runStateT (m (\a -> LazySt.StateT $ \ctx' -> f (LazySt.runStateT a ctx'))) ctx) + + instance GhcMonad m => GhcMonad (ReaderT s m) where getSession = lift getSession setSession env = lift (setSession env) @@ -163,8 +249,8 @@ -- | Input and output information for the refactoring -newtype LocalRefactorT dom m a = LocalRefactorT { fromRefactorT :: WriterT [GHC.Name] (ReaderT (RefactorCtx dom) m) a } - deriving (Functor, Applicative, Monad, MonadReader (RefactorCtx dom), MonadWriter [GHC.Name], MonadIO, HasDynFlags, ExceptionMonad, GhcMonad) +newtype LocalRefactorT dom m a = LocalRefactorT { fromRefactorT :: WriterT [Either GHC.Name (SrcSpan, String, String)] (ReaderT (RefactorCtx dom) m) a } + deriving (Functor, Applicative, Monad, MonadReader (RefactorCtx dom), MonadWriter [Either GHC.Name (SrcSpan, String, String)], MonadIO, HasDynFlags, ExceptionMonad, GhcMonad) -- | The information a refactoring can use data RefactorCtx dom = RefactorCtx { refModuleName :: GHC.Module @@ -192,6 +278,10 @@ refactError = lift . refactError liftGhc = lift . liftGhc +instance RefactorMonad m => RefactorMonad (LazySt.StateT s m) where + refactError = lift . refactError + liftGhc = lift . liftGhc + -- | The refactoring monad for a given module type LocalRefactor dom = LocalRefactorT dom Refactor @@ -232,7 +322,7 @@ else let possibleImports = filter ((name `elem`) . (\imp -> semanticsImported $ imp ^. semantics)) imports fromPrelude = name `elem` semanticsImplicitImports (mod ^. semantics) in if | fromPrelude -> return $ makeName [] name - | null possibleImports -> do tell [name] + | null possibleImports -> do tell [Left name] return $ makeName [] name | otherwise -> return $ referenceBy makeName name possibleImports -- use it according to the best available import diff --git a/Language/Haskell/Tools/Refactor/Session.hs b/Language/Haskell/Tools/Refactor/Session.hs --- a/Language/Haskell/Tools/Refactor/Session.hs +++ b/Language/Haskell/Tools/Refactor/Session.hs @@ -5,7 +5,7 @@ module Language.Haskell.Tools.Refactor.Session where import Control.Exception -import Control.Monad.State +import Control.Monad.State.Strict import Control.Reference import qualified Data.List as List import qualified Data.Map as Map @@ -27,8 +27,6 @@ import Language.Haskell.Tools.Refactor.Prepare import Language.Haskell.Tools.Refactor.RefactorBase -import Debug.Trace - -- | The state common for refactoring tools, carrying the state of modules. data RefactorSessionState = RefactorSessionState { __refSessMCs :: [ModuleCollection] @@ -59,10 +57,10 @@ lift $ mapM_ addTarget $ map (\mod -> (Target (TargetModule (GHC.mkModuleName mod)) True Nothing)) modNames handleErrors $ withAlteredDynFlags (liftIO . setupLoadFlags allModColls) $ do modsForColls <- lift $ depanal [] True - liftIO $ loadCallback modsForColls let modsToParse = flattenSCCs $ topSortModuleGraph False modsForColls Nothing - actuallyCompiled = filter (not . (`elem` alreadyExistingMods) . modSumName) modsToParse - void $ checkEvaluatedMods report modsToParse + actuallyCompiled = filter (\ms -> modSumName ms `notElem` alreadyExistingMods) modsToParse + liftIO $ loadCallback actuallyCompiled + void $ checkEvaluatedMods (\_ -> return ()) modsToParse mods <- mapM (loadModule report) actuallyCompiled return (mods, ignored) @@ -115,20 +113,21 @@ allModColls <- gets (^. refSessMCs) withAlteredDynFlags (liftIO . setupLoadFlags allModColls) $ do allMods <- lift $ depanal [] True - liftIO $ loadCallback (filter selected allMods) let (allModsGraph, lookup) = moduleGraphNodes False allMods changedMods = catMaybes $ map (\ms -> lookup (ms_hsc_src ms) (moduleName $ ms_mod ms)) $ filter selected allMods recompMods = map (ms_mod . getModFromNode) $ reachablesG (transposeG allModsGraph) changedMods sortedMods = reverse $ topologicalSortG allModsGraph - return $ filter ((`elem` recompMods) . ms_mod) $ map getModFromNode sortedMods + sortedRecompMods = filter ((`elem` recompMods) . ms_mod) $ map getModFromNode sortedMods + liftIO $ loadCallback sortedRecompMods + return sortedRecompMods -- | Reload a given module. Perform a callback. reloadModule :: IsRefactSessionState st => (ModSummary -> IO a) -> ModSummary -> StateT st Ghc a reloadModule report ms = do mcs <- gets (^. refSessMCs) let modName = modSumName ms - codeGen = hasGeneratedCode (keyFromMS ms) mcs + codeGen = needsGeneratedCode (keyFromMS ms) mcs case lookupModuleColl modName mcs of Just mc -> do let dfs = ms_hspp_opts ms @@ -150,7 +149,9 @@ where reloadIfNeeded ms mcs = let key = keyFromMS ms in if not (hasGeneratedCode key mcs) - then do modify $ refSessMCs .- codeGeneratedFor key + then do md <- gets (^. refSessMCs) + modify $ refSessMCs .- codeGeneratedFor key + md <- gets (^. refSessMCs) if (isAlreadyLoaded key mcs) then -- The module is already loaded but code is not generated. Need to reload. Just <$> lift (codeGenForModule report (codeGeneratedFor key mcs) ms) diff --git a/examples/CPP/ConditionalImport.hs b/examples/CPP/ConditionalImport.hs --- a/examples/CPP/ConditionalImport.hs +++ b/examples/CPP/ConditionalImport.hs @@ -3,7 +3,7 @@ import Data.List #ifndef USE_DATA_LIST -import Control.Monad +import Control.Monad (Monad(..)) #endif import Data.List diff --git a/examples/CPP/ConditionalImportBegin.hs b/examples/CPP/ConditionalImportBegin.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportBegin.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportBegin where + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif +import Data.List +import Data.List + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportBegin_res.hs b/examples/CPP/ConditionalImportBegin_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportBegin_res.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportBegin where + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif + + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportEnd.hs b/examples/CPP/ConditionalImportEnd.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportEnd.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportEnd where + +import Data.List +import Data.List +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportEnd_res.hs b/examples/CPP/ConditionalImportEnd_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportEnd_res.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportEnd where + + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportHalfRemoved.hs b/examples/CPP/ConditionalImportHalfRemoved.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportHalfRemoved.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportHalfRemoved where + +import Data.List +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif +import Control.Applicative ((<$>)) + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportHalfRemoved_res.hs b/examples/CPP/ConditionalImportHalfRemoved_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportHalfRemoved_res.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportHalfRemoved where + + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif +import Control.Applicative ((<$>)) + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportMulti.hs b/examples/CPP/ConditionalImportMulti.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportMulti.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportMulti where + +import Data.List +#ifndef USE_DATA_LIST +import Control.Applicative ((<$>)) +import Control.Monad ((>>)) +#endif +import Data.List + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportMulti_res.hs b/examples/CPP/ConditionalImportMulti_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportMulti_res.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportMulti where + + +#ifndef USE_DATA_LIST +import Control.Applicative ((<$>)) +import Control.Monad ((>>)) +#endif + + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportOrder.hs b/examples/CPP/ConditionalImportOrder.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportOrder.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportOrder where + +import Data.List (intersperse) +#ifndef USE_DATA_LIST +import Control.Monad (Monad(..)) +#endif +import Control.Applicative ((<$>)) + +a = Nothing >> Nothing + +b = id <$> Nothing +c = intersperse "," ["a","b"] diff --git a/examples/CPP/ConditionalImportOrder_res.hs b/examples/CPP/ConditionalImportOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportOrder_res.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportOrder where + +import Data.List (intersperse) +#ifndef USE_DATA_LIST +import Control.Monad (Monad(..)) +#endif +import Control.Applicative ((<$>)) + +a = Nothing >> Nothing + +b = id <$> Nothing +c = intersperse "," ["a","b"] diff --git a/examples/CPP/ConditionalImport_res.hs b/examples/CPP/ConditionalImport_res.hs --- a/examples/CPP/ConditionalImport_res.hs +++ b/examples/CPP/ConditionalImport_res.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} module CPP.ConditionalImport where + #ifndef USE_DATA_LIST import Control.Monad (Monad(..)) #endif + a = Nothing >> Nothing diff --git a/examples/Module/Import.hs b/examples/Module/Import.hs --- a/examples/Module/Import.hs +++ b/examples/Module/Import.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, Safe #-} module Module.Import where import Data.List @@ -8,4 +8,4 @@ import Data.List as List import Data.List(map,(++)) import Data.Function hiding ((&)) -import Control.Monad.Writer hiding (Alt, Writer()) +import safe Control.Monad.Writer hiding (Alt, Writer()) diff --git a/examples/Refactor/RenameDefinition/CrossRename.hs b/examples/Refactor/RenameDefinition/CrossRename.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/CrossRename.hs @@ -0,0 +1,8 @@ +module Refactor.RenameDefinition.CrossRename where + +-- Renaming f to g should fail +f x = x + +ff x = g + where + g = f 'g' diff --git a/examples/Refactor/RenameDefinition/ImplicitParams.hs b/examples/Refactor/RenameDefinition/ImplicitParams.hs deleted file mode 100644 --- a/examples/Refactor/RenameDefinition/ImplicitParams.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -module Refactor.RenameDefinition.ImplicitParams where - -import Data.List - -sort' :: (?cmp :: a -> a -> Ordering) => [a] -> [a] -sort' = sortBy ?cmp - -main = let ?cmp = compare in putStrLn (show (sort' [3,1,2])) diff --git a/examples/Refactor/RenameDefinition/ImplicitParams_res.hs b/examples/Refactor/RenameDefinition/ImplicitParams_res.hs deleted file mode 100644 --- a/examples/Refactor/RenameDefinition/ImplicitParams_res.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -module Refactor.RenameDefinition.ImplicitParams where - -import Data.List - -sort' :: (?compare :: a -> a -> Ordering) => [a] -> [a] -sort' = sortBy ?compare - -main = let ?cmp = compare in putStrLn (show (sort' [3,1,2])) diff --git a/examples/Refactor/RenameDefinition/MergeFields.hs b/examples/Refactor/RenameDefinition/MergeFields.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields.hs @@ -0,0 +1,10 @@ +module Refactor.RenameDefinition.MergeFields where + +data A = B { x :: Double } | C { y :: Double } + +data A2 = A2 { x2 :: Double, y2 :: Double } + +data A3 = B3 { x3 :: Double } | C3 { y3 :: Int } + +f a = case a of B {} -> x a + C {} -> y a diff --git a/examples/Refactor/RenameDefinition/MergeFields_RenameY.hs b/examples/Refactor/RenameDefinition/MergeFields_RenameY.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields_RenameY.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.MergeFields_RenameY where + +data A = B { x :: Double } | C { y :: Double } + +f a = case a of B {} -> x a + C {} -> y a diff --git a/examples/Refactor/RenameDefinition/MergeFields_RenameY_res.hs b/examples/Refactor/RenameDefinition/MergeFields_RenameY_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields_RenameY_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.MergeFields_RenameY where + +data A = B { x :: Double } | C { x :: Double } + +f a = case a of B {} -> x a + C {} -> x a diff --git a/examples/Refactor/RenameDefinition/MergeFields_res.hs b/examples/Refactor/RenameDefinition/MergeFields_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields_res.hs @@ -0,0 +1,10 @@ +module Refactor.RenameDefinition.MergeFields where + +data A = B { y :: Double } | C { y :: Double } + +data A2 = A2 { x2 :: Double, y2 :: Double } + +data A3 = B3 { x3 :: Double } | C3 { y3 :: Int } + +f a = case a of B {} -> y a + C {} -> y a diff --git a/examples/Refactor/RenameDefinition/RenameModuleAlias.hs b/examples/Refactor/RenameDefinition/RenameModuleAlias.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModuleAlias.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.RenameModuleAlias where + +import Data.List as LL +foo = LL.intersperse "," ["a","b"] diff --git a/examples/Refactor/RenameDefinition/RenameModuleAlias_res.hs b/examples/Refactor/RenameDefinition/RenameModuleAlias_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModuleAlias_res.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.RenameModuleAlias where + +import Data.List as L +foo = L.intersperse "," ["a","b"] diff --git a/haskell-tools-refactor.cabal b/haskell-tools-refactor.cabal --- a/haskell-tools-refactor.cabal +++ b/haskell-tools-refactor.cabal @@ -1,5 +1,5 @@ name: haskell-tools-refactor -version: 0.6.0.0 +version: 0.7.0.0 synopsis: Refactoring Tool for Haskell description: Contains a set of refactorings based on the Haskell-Tools framework to easily transform a Haskell program. For the descriptions of the implemented refactorings, see the homepage. homepage: https://github.com/haskell-tools/haskell-tools @@ -61,6 +61,7 @@ , Language.Haskell.Tools.Refactor.ListOperations , Language.Haskell.Tools.Refactor.Session , Language.Haskell.Tools.Refactor.Helpers + , Language.Haskell.Tools.Refactor.ChangeAST , Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature , Language.Haskell.Tools.Refactor.Predefined.OrganizeImports @@ -90,10 +91,10 @@ , template-haskell >= 2.11 && < 2.12 , ghc >= 8.0 && < 8.1 , Cabal >= 1.24 && < 1.25 - , haskell-tools-ast >= 0.6 && < 0.7 - , haskell-tools-backend-ghc >= 0.6 && < 0.7 - , haskell-tools-rewrite >= 0.6 && < 0.7 - , haskell-tools-prettyprint >= 0.6 && < 0.7 + , haskell-tools-ast >= 0.7 && < 0.8 + , haskell-tools-backend-ghc >= 0.7 && < 0.8 + , haskell-tools-rewrite >= 0.7 && < 0.8 + , haskell-tools-prettyprint >= 0.7 && < 0.8 default-language: Haskell2010 test-suite haskell-tools-test @@ -118,11 +119,11 @@ , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , Cabal >= 1.24 && < 1.25 - , haskell-tools-ast >= 0.6 && < 0.7 - , haskell-tools-backend-ghc >= 0.6 && < 0.7 - , haskell-tools-rewrite >= 0.6 && < 0.7 - , haskell-tools-prettyprint >= 0.6 && < 0.7 - , haskell-tools-refactor >= 0.6 && < 0.7 + , haskell-tools-ast >= 0.7 && < 0.8 + , haskell-tools-backend-ghc >= 0.7 && < 0.8 + , haskell-tools-rewrite >= 0.7 && < 0.8 + , haskell-tools-prettyprint >= 0.7 && < 0.8 + , haskell-tools-refactor >= 0.7 && < 0.8 -- libraries used by the examples , old-time >= 1.1 && < 1.2 , polyparse >= 1.12 && < 1.13 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -253,6 +253,11 @@ , "Refactor.OrganizeImports.TemplateHaskell" , "Refactor.OrganizeImports.NarrowType" , "CPP.ConditionalImport" + , "CPP.ConditionalImportBegin" + , "CPP.ConditionalImportEnd" + , "CPP.ConditionalImportHalfRemoved" + , "CPP.ConditionalImportMulti" + , "CPP.ConditionalImportOrder" ] generateSignatureTests = @@ -309,12 +314,14 @@ , ("Refactor.RenameDefinition.TypeOperators", "4:13-4:15", "x1") , ("Refactor.RenameDefinition.NoPrelude", "4:1-4:2", "map") , ("Refactor.RenameDefinition.UnusedDef", "3:1-3:2", "map") - , ("Refactor.RenameDefinition.ImplicitParams", "8:17-8:20", "compare") , ("Refactor.RenameDefinition.SameCtorAndType", "3:6-3:13", "P2D") , ("Refactor.RenameDefinition.RoleAnnotation", "4:11-4:12", "AA") , ("Refactor.RenameDefinition.TypeBracket", "6:6-6:7", "B") , ("Refactor.RenameDefinition.ValBracket", "8:11-8:12", "B") , ("Refactor.RenameDefinition.FunnyDo", "3:1-3:2", "aaa") + , ("Refactor.RenameDefinition.RenameModuleAlias", "3:21-3:23", "L") + , ("Refactor.RenameDefinition.MergeFields", "3:14-3:15", "y") + , ("Refactor.RenameDefinition.MergeFields_RenameY", "3:34-3:35", "x") ] wrongRenameDefinitionTests = @@ -330,6 +337,12 @@ , ("Refactor.RenameDefinition.WrongName", "9:19-9:19", ".+++.") , ("Refactor.RenameDefinition.WrongName", "11:3-11:3", ":+++:") , ("Refactor.RenameDefinition.IllegalQualRename", "4:30-4:34", "Bl") + , ("Refactor.RenameDefinition.CrossRename", "4:1-4:2", "g") + , ("Refactor.RenameDefinition.MergeFields", "5:16-5:18", "y2") -- fld in the same ctor + , ("Refactor.RenameDefinition.MergeFields", "5:30-5:32", "x2") -- fld in the same ctor + , ("Refactor.RenameDefinition.MergeFields", "5:16-5:18", "y") -- fld belongs to other type + , ("Refactor.RenameDefinition.MergeFields", "7:16-7:18", "y3") -- types does not match + , ("Refactor.RenameDefinition.MergeFields", "7:38-7:40", "x3") -- types does not match ] extractBindingTests =