apply-refact 0.8.2.0 → 0.8.2.1
raw patch · 7 files changed
+677/−654 lines, 7 filesdep −mtldep ~ghc-exactprintPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: mtl
Dependency ranges changed: ghc-exactprint
API changes (from Hackage documentation)
- Refact.Apply: instance GHC.Classes.Eq Refact.Apply.Verbosity
- Refact.Apply: instance GHC.Classes.Ord Refact.Apply.Verbosity
- Refact.Apply: instance GHC.Show.Show Refact.Apply.Verbosity
Files
- CHANGELOG +5/−0
- apply-refact.cabal +8/−8
- src/Refact/Apply.hs +4/−580
- src/Refact/Fixity.hs +1/−1
- src/Refact/Internal.hs +654/−0
- src/Refact/Run.hs +4/−64
- src/Refact/Utils.hs +1/−1
CHANGELOG view
@@ -1,3 +1,8 @@+v0.8.2.1++ * support GHC 8.8.4+ * remove dependency on mtl+ v0.8.2.0 * #75, support refactoring for Eta reduce
apply-refact.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: apply-refact-version: 0.8.2.0+version: 0.8.2.1 synopsis: Perform refactorings specified by the refact library. description: Perform refactorings specified by the refact library. It is primarily used with HLint's --refactor flag. license: BSD3@@ -18,7 +18,7 @@ , tests/examples/*.hs.refact , tests/examples/*.hs.expected cabal-version: >=1.10-tested-with: GHC == 8.10.1, GHC == 8.8.3, GHC == 8.6.5+tested-with: GHC == 8.10.1, GHC == 8.8.4, GHC == 8.6.5 source-repository head@@ -29,15 +29,15 @@ exposed-modules: Refact.Utils , Refact.Apply , Refact.Fixity+ other-modules: Refact.Internal GHC-Options: -Wall build-depends: base >=4.12 && < 5 , refact >= 0.2- , ghc-exactprint >= 0.6.3.1+ , ghc-exactprint >= 0.6.3.2 , ghc >= 8.6 , containers >= 0.6.0.1 , extra >= 1.7.3 , syb- , mtl , process , transformers , filemanip@@ -52,6 +52,7 @@ Paths_apply_refact Refact.Apply Refact.Fixity+ Refact.Internal Refact.Utils Refact.Run hs-source-dirs: src@@ -59,13 +60,12 @@ ghc-options: -Wall -fno-warn-unused-do-bind build-depends: base >= 4.12 && < 5 , refact >= 0.2- , ghc-exactprint >= 0.6.3.1+ , ghc-exactprint >= 0.6.3.2 , ghc >= 8.6 , ghc-boot-th >= 8.6 , containers >= 0.6.0.1 , extra >= 1.7.3 , syb- , mtl , process , directory , optparse-applicative >= 0.15.1.0@@ -83,6 +83,7 @@ Refact.Run Refact.Apply Refact.Fixity+ Refact.Internal Refact.Utils GHC-Options: -threaded Default-language: Haskell2010@@ -93,13 +94,12 @@ , tasty-expected-failure , base < 5 , refact >= 0.2- , ghc-exactprint >= 0.6.3.1+ , ghc-exactprint >= 0.6.3.2 , ghc >= 8.6 , ghc-boot-th >= 8.6 , containers >= 0.6.0.1 , extra >= 1.7.3 , syb- , mtl , process , directory , optparse-applicative
src/Refact/Apply.hs view
@@ -1,16 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeApplications #-}+ module Refact.Apply- (- runRefactoring+ ( runRefactoring , applyRefactorings -- * Support for runPipe in the main process@@ -21,573 +12,6 @@ , type Errors , onError , mkErr- ) where--import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Annotate-import Language.Haskell.GHC.ExactPrint.Delta-import Language.Haskell.GHC.ExactPrint.Parsers-import Language.Haskell.GHC.ExactPrint.Print-import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn)-import Language.Haskell.GHC.ExactPrint.Utils--import Control.Arrow-import Control.Monad-import Control.Monad.State-import Control.Monad.Identity-import Data.Char-import Data.Data-import Data.Generics.Schemes-import Data.Maybe-import Data.List-import Data.Ord--#if __GLASGOW_HASKELL__ >= 810-import GHC.Hs.Expr as GHC hiding (Stmt)-import GHC.Hs.ImpExp-import GHC.Hs hiding (Pat, Stmt)-import Outputable hiding ((<>))-import ErrUtils-import Bag-#else-import HsExpr as GHC hiding (Stmt)-import HsImpExp-import HsSyn hiding (Pat, Stmt, noExt)-import Debug.Trace-#endif--import SrcLoc-import qualified GHC hiding (parseModule)-import qualified Name as GHC-import qualified RdrName as GHC-import Data.Generics hiding (GT)--import qualified Data.Map as Map--import System.IO.Unsafe---import Refact.Fixity-import Refact.Types hiding (SrcSpan)-import qualified Refact.Types as R-import Refact.Utils (Stmt, Pat, Name, Decl, M, Expr, Type, FunBind- , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, setSrcSpanFile)--#if __GLASGOW_HASKELL__ >= 810-type Errors = ErrorMessages-onError :: String -> Errors -> a-onError s = pprPanic s . vcat . pprErrMsgBagWithLoc-#else-type Errors = (SrcSpan, String)-onError :: String -> Errors -> a-onError _ = error . show-#endif--#if __GLASGOW_HASKELL__ <= 806-composeSrcSpan :: a -> a-composeSrcSpan = id--decomposeSrcSpan :: a -> a-decomposeSrcSpan = id--type SrcSpanLess a = a-#endif---- library access to perform the substitutions--refactOptions :: PrintOptions Identity String-refactOptions = stringOptions { epRigidity = RigidLayout }--rigidLayout :: DeltaOptions-rigidLayout = deltaOptions RigidLayout---- | Apply a set of refactorings as supplied by hlint-applyRefactorings :: Maybe (Int, Int) -> [(String, [Refactoring R.SrcSpan])] -> FilePath -> IO String-applyRefactorings optionsPos inp file = do- (as, m) <- either (onError "apply") (uncurry applyFixities)- <$> parseModuleWithOptions rigidLayout file- let noOverlapInp = removeOverlap Silent inp- refacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp-- posFilter (_, rs) =- case optionsPos of- Nothing -> True- Just p -> any (flip spans p . pos) rs- filtRefacts = filter posFilter refacts-- -- need a check here to avoid overlap- (ares, res) <- return . flip evalState 0 $- foldM (uncurry runRefactoring) (as, m) (concatMap snd filtRefacts)- let output = runIdentity $ exactPrintWithOptions refactOptions res ares- return output--data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord)---- Filters out overlapping ideas, picking the first idea in a set of overlapping ideas.--- If two ideas start in the exact same place, pick the largest edit.-removeOverlap :: Verbosity -> [(String, [Refactoring R.SrcSpan])] -> [(String, [Refactoring R.SrcSpan])]-removeOverlap verb = dropOverlapping . sortBy f . summarize- where- -- We want to consider all Refactorings of a single idea as a unit, so compute a summary- -- SrcSpan that encompasses all the Refactorings within each idea.- summarize :: [(String, [Refactoring R.SrcSpan])] -> [(String, (R.SrcSpan, [Refactoring R.SrcSpan]))]- summarize ideas = [ (s, (foldr1 summary (map pos rs), rs)) | (s, rs) <- ideas, not (null rs) ]-- summary (R.SrcSpan sl1 sc1 el1 ec1)- (R.SrcSpan sl2 sc2 el2 ec2) =- let (sl, sc) = case compare sl1 sl2 of- LT -> (sl1, sc1)- EQ -> (sl1, min sc1 sc2)- GT -> (sl2, sc2)- (el, ec) = case compare el1 el2 of- LT -> (el2, ec2)- EQ -> (el2, max ec1 ec2)- GT -> (el1, ec1)- in R.SrcSpan sl sc el ec-- -- Order by span start. If starting in same place, order by size.- f (_,(s1,_)) (_,(s2,_)) =- comparing startLine s1 s2 <> -- s1 first if it starts on earlier line- comparing startCol s1 s2 <> -- or on earlier column- comparing endLine s2 s1 <> -- they start in same place, s2 comes- comparing endCol s2 s1 -- first if it ends later- -- else, completely same span, so s1 will be first-- dropOverlapping [] = []- dropOverlapping (p:ps) = go p ps- go (s,(_,rs)) [] = [(s,rs)]- go p@(s,(_,rs)) (x:xs)- | p `overlaps` x = (if verb > Silent- then trace ("Ignoring " ++ show (snd (snd x)) ++ " due to overlap.")- else id) go p xs- | otherwise = (s,rs) : go x xs- -- for overlaps, we know s1 always starts <= s2, due to our sort- overlaps (_,(s1,_)) (_,(s2,_)) =- case compare (startLine s2) (endLine s1) of- LT -> True- EQ -> startCol s2 <= endCol s1- GT -> False---- ------------------------------------------------------------------------- Perform the substitutions--getSeed :: State Int Int-getSeed = get <* modify (+1)---- | Peform a @Refactoring@.-runRefactoring :: Data a => Anns -> a -> Refactoring GHC.SrcSpan -> State Int (Anns, a)-runRefactoring as m r@Replace{} = do- seed <- getSeed- return $ case rtype r of- Expr -> replaceWorker as m parseExpr seed r- Decl -> replaceWorker as m parseDecl seed r- Type -> replaceWorker as m parseType seed r- Pattern -> replaceWorker as m parsePattern seed r- Stmt -> replaceWorker as m parseStmt seed r- Bind -> replaceWorker as m parseBind seed r- R.Match -> replaceWorker as m parseMatch seed r- ModuleName -> replaceWorker as m (parseModuleName (pos r)) seed r- Import -> replaceWorker as m parseImport seed r--runRefactoring as m ModifyComment{..} =- return (Map.map go as, m)- where- go a@Ann{ annPriorComments, annsDP } =- a { annsDP = map changeComment annsDP- , annPriorComments = map (first change) annPriorComments }- changeComment (AnnComment d, dp) = (AnnComment (change d), dp)- changeComment e = e- change old@Comment{..}= if ss2pos commentIdentifier == ss2pos pos- then old { commentContents = newComment}- else old-runRefactoring as m Delete{rtype, pos} = do- let f = case rtype of- Stmt -> doDeleteStmt ((/= pos) . getLoc)- Import -> doDeleteImport ((/= pos) . getLoc)- _ -> id- return (as, f m)- {--runRefactoring as m Rename{nameSubts} = (as, m)- --(as, doRename nameSubts m)- -}-runRefactoring as m InsertComment{..} =- let exprkey = mkAnnKey (findDecl m pos) in- return (insertComment exprkey newComment as, m)-runRefactoring as m RemoveAsKeyword{..} =- return (as, removeAsKeyword m)- where- removeAsKeyword = everywhere (mkT go)- go :: LImportDecl GHC.GhcPs -> LImportDecl GHC.GhcPs- go imp@(GHC.L l i) | l == pos = GHC.L l (i { ideclAs = Nothing })- | otherwise = imp---- Specialised parsers-mkErr :: GHC.DynFlags -> SrcSpan -> String -> Errors-#if __GLASGOW_HASKELL__ >= 810-mkErr df l s = unitBag (mkPlainErrMsg df l (text s))-#else-mkErr = const (,)-#endif--parseModuleName :: GHC.SrcSpan -> Parser (GHC.Located GHC.ModuleName)-parseModuleName ss _ _ s =- let newMN = GHC.L ss (GHC.mkModuleName s)- newAnns = relativiseApiAnns newMN (Map.empty, Map.empty)- in return (newAnns, newMN)-parseBind :: Parser (GHC.LHsBind GHC.GhcPs)-parseBind dyn fname s =- case parseDecl dyn fname s of- -- Safe as we add no annotations to the ValD- Right (as, GHC.L l (GHC.ValD _ b)) -> Right (as, GHC.L l b)- Right (_, GHC.L l _) -> Left (mkErr dyn l "Not a HsBind")- Left e -> Left e-parseMatch :: Parser (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs))-parseMatch dyn fname s =- case parseBind dyn fname s of- Right (as, GHC.L l GHC.FunBind{fun_matches}) ->- case unLoc (GHC.mg_alts fun_matches) of- [x] -> Right (as, x)- _ -> Left (mkErr dyn l "Not a single match")- Right (_, GHC.L l _) -> Left (mkErr dyn l "Not a funbind")- Left e -> Left e---- Substitute variables into templates--- Finds places in the templates where we need to insert variables.--substTransform :: (Data a, Data b) => b -> [(String, GHC.SrcSpan)] -> a -> M a-substTransform m ss = everywhereM (mkM (typeSub m ss)- `extM` identSub m ss- `extM` patSub m ss- `extM` stmtSub m ss- `extM` exprSub m ss- )--stmtSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Stmt -> M Stmt-stmtSub m subs old@(GHC.L _ (BodyStmt _ (GHC.L _ (HsVar _ (L _ name))) _ _) ) =- resolveRdrName m (findStmt m) old subs name-stmtSub _ _ e = return e--patSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Pat -> M Pat-patSub m subs old@(GHC.L _ (VarPat _ (L _ name))) =- resolveRdrName m (findPat m) old subs name-patSub _ _ e = return e--typeSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Type -> M Type-typeSub m subs old@(GHC.L _ (HsTyVar _ _ (L _ name))) =- resolveRdrName m (findType m) old subs name-typeSub _ _ e = return e--exprSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Expr -> M Expr-exprSub m subs old@(GHC.L _ (HsVar _ (L _ name))) =- resolveRdrName m (findExpr m) old subs name-exprSub _ _ e = return e----- Used for Monad10, Monad11 tests.--- The issue being that in one case the information is attached to a VarPat--- but we need to move the annotations onto the actual name------ This looks convoluted but we can't match directly on a located name as--- it is not specific enough. Instead we match on some bigger context which--- is contains the located name we want to replace.-identSub :: Data a => a -> [(String, GHC.SrcSpan)] -> FunBind -> M FunBind-identSub m subs old@(GHC.FunRhs (GHC.L _ name) _ _) =- resolveRdrName' subst (findName m) old subs name- where- subst :: FunBind -> Name -> M FunBind- subst (GHC.FunRhs n b s) new = do- let fakeExpr :: Located (GHC.Pat GhcPs)- fakeExpr = GHC.L (getLoc new) (GHC.VarPat noExt new)- -- Low level version as we need to combine the annotation information- -- from the template RdrName and the original VarPat.- modify (\r -> replaceAnnKey r (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr))- return $ GHC.FunRhs new b s- subst o _ = return o-identSub _ _ e = return e------ g is usually modifyAnnKey--- f is usually a function which checks the locations are equal-resolveRdrName' :: (a -> b -> M a) -- How to combine the value to insert and the replaced value- -> (SrcSpan -> b) -- How to find the new value, when given the location it is in- -> a -- The old thing which we are going to possibly replace- -> [(String, GHC.SrcSpan)] -- Substs- -> GHC.RdrName -- The name of the position in the template- --we are replacing into- -> M a-resolveRdrName' g f old subs name =- case name of- -- Todo: this should replace anns as well?- GHC.Unqual (GHC.occNameString . GHC.occName -> oname)- -> case lookup oname subs of- Just (f -> new) -> g old new- Nothing -> return old- _ -> return old--resolveRdrName :: (Data old, Data a)- => a- -> (SrcSpan -> Located old)- -> Located old- -> [(String, SrcSpan)]- -> GHC.RdrName- -> M (Located old)-resolveRdrName m = resolveRdrName' (modifyAnnKey m)--insertComment :: AnnKey -> String- -> Map.Map AnnKey Annotation- -> Map.Map AnnKey Annotation-insertComment k s as =- let comment = Comment s GHC.noSrcSpan Nothing in- Map.adjust (\a@Ann{..} -> a { annPriorComments = annPriorComments ++ [(comment, DP (1,0))]- , annEntryDelta = DP (1,0) }) k as----- Substitute the template into the original AST.-#if __GLASGOW_HASKELL__ <= 806-doGenReplacement- :: forall ast a. (Data ast, Data a)- => a- -> (GHC.Located ast -> Bool)- -> GHC.Located ast- -> GHC.Located ast- -> State (Anns, Bool) (GHC.Located ast)-#else-doGenReplacement- :: forall ast a. (Data (SrcSpanLess ast), HasSrcSpan ast, Data a)- => a- -> (ast -> Bool)- -> ast- -> ast- -> State (Anns, Bool) ast-#endif-doGenReplacement m p new old- | p old = do- anns <- gets fst- let n = decomposeSrcSpan new- o = decomposeSrcSpan old- newAnns = execState (modifyAnnKey m o n) anns- put (newAnns, True)- pure new- -- If "f a = body where local" doesn't satisfy the predicate, but "f a = body" does,- -- run the replacement on "f a = body", and add "local" back afterwards.- -- This is useful for hints like "Eta reduce" and "Redundant where".- | Just Refl <- eqT @(SrcSpanLess ast) @(HsDecl GHC.GhcPs)- , L _ (ValD xvald newBind@FunBind{}) <- decomposeSrcSpan new- , Just (oldNoLocal, oldLocal) <- stripLocalBind (decomposeSrcSpan old)- , newLoc@(RealSrcSpan newLocReal) <- getLoc new- , p (composeSrcSpan oldNoLocal) = do- anns <- gets fst- let n = decomposeSrcSpan new- o = decomposeSrcSpan old- intAnns = execState (modifyAnnKey m o n) anns- newFile = srcSpanFile newLocReal- newLocal = everywhere (mkT $ setSrcSpanFile newFile) oldLocal- newLocalLoc = getLoc newLocal- ensureLoc = combineSrcSpans newLocalLoc- newMG = fun_matches newBind- L locMG [L locMatch newMatch] = mg_alts newMG- newGRHSs = m_grhss newMatch- finalLoc = ensureLoc newLoc- newWithLocalBinds = setLocalBind newLocal xvald newBind finalLoc- newMG (ensureLoc locMG) newMatch (ensureLoc locMatch) newGRHSs-- -- Ensure the new Anns properly reflects the local binds we added back.- addLocalBindsToAnns = addAnnWhere- . Map.fromList- . map (first (expandTemplateLoc . updateFile . expandGRHSLoc))- . Map.toList- where- addAnnWhere :: Anns -> Anns- addAnnWhere oldAnns =- let oldAnns' = Map.toList oldAnns- po = \case- (AnnKey loc@(RealSrcSpan r) con, _) ->- loc == getLoc old && con == CN "Match" && srcSpanFile r /= newFile- _ -> False- pn = \case- (AnnKey loc@(RealSrcSpan r) con, _) ->- loc == finalLoc && con == CN "Match" && srcSpanFile r == newFile- _ -> False- in fromMaybe oldAnns $ do- oldAnn <- snd <$> find po oldAnns'- annWhere <- find ((== G GHC.AnnWhere) . fst) (annsDP oldAnn)- newKey <- fst <$> find pn oldAnns'- pure $ Map.adjust (\ann -> ann {annsDP = annsDP ann ++ [annWhere]}) newKey oldAnns-- -- Expand the SrcSpan of the "GRHS" entry in the new file to include the local binds- expandGRHSLoc = \case- AnnKey loc@(RealSrcSpan r) con- | con == CN "GRHS", srcSpanFile r == newFile -> AnnKey (ensureLoc loc) con- other -> other-- -- If an Anns entry corresponds to the local binds, update its file to point to the new file.- updateFile = \case- AnnKey loc con- | loc `isSubspanOf` getLoc oldLocal -> AnnKey (setSrcSpanFile newFile loc) con- other -> other-- -- For each SrcSpan in the new file that is the entire newLoc, set it to finalLoc- expandTemplateLoc = \case- AnnKey loc con- | loc == newLoc -> AnnKey finalLoc con- other -> other-- newAnns = addLocalBindsToAnns intAnns- put (newAnns, True)- pure $ composeSrcSpan newWithLocalBinds- | otherwise = pure old---- | If the input is a FunBind with a single match, e.g., "foo a = body where x = y"--- return "Just (foo a = body, x = y)". Otherwise return Nothing.-stripLocalBind- :: LHsDecl GHC.GhcPs- -> Maybe (LHsDecl GHC.GhcPs, LHsLocalBinds GHC.GhcPs)-stripLocalBind = \case- L _ (ValD xvald origBind@FunBind{})- | let origMG = fun_matches origBind- , L locMG [L locMatch origMatch] <- mg_alts origMG- , let origGRHSs = m_grhss origMatch- , [L _ (GRHS _ _ (L loc2 _))] <- grhssGRHSs origGRHSs ->- let loc1 = getLoc (fun_id origBind)- newLoc = combineSrcSpans loc1 loc2- withoutLocalBinds = setLocalBind (noLoc (EmptyLocalBinds noExt)) xvald origBind newLoc origMG locMG- origMatch locMatch origGRHSs- in Just (withoutLocalBinds, grhssLocalBinds origGRHSs)- _ -> Nothing---- | Set the local binds in a HsBind.-setLocalBind- :: LHsLocalBinds GHC.GhcPs- -> XValD GhcPs- -> HsBind GhcPs- -> SrcSpan- -> MatchGroup GhcPs (LHsExpr GhcPs)- -> SrcSpan- -> Match GhcPs (LHsExpr GhcPs)- -> SrcSpan- -> GRHSs GhcPs (LHsExpr GhcPs)- -> LHsDecl GhcPs-setLocalBind newLocalBinds xvald origBind newLoc origMG locMG origMatch locMatch origGRHSs =- L newLoc (ValD xvald newBind)- where- newGRHSs = origGRHSs{grhssLocalBinds = newLocalBinds}- newMatch = origMatch{m_grhss = newGRHSs}- newMG = origMG{mg_alts = L locMG [L locMatch newMatch]}- newBind = origBind{fun_matches = newMG}--#if __GLASGOW_HASKELL__ <= 806-replaceWorker :: (Annotate a, Data mod)- => Anns- -> mod- -> Parser (GHC.Located a)- -> Int- -> Refactoring GHC.SrcSpan- -> (Anns, mod)-#else-replaceWorker :: (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a))- => Anns- -> mod- -> Parser a- -> Int- -> Refactoring GHC.SrcSpan- -> (Anns, mod)-#endif-replaceWorker as m parser seed Replace{..} =- let replExprLocation = pos- uniqueName = "template" ++ show seed- p s = unsafePerformIO (withDynFlags (\d -> parser d uniqueName s))- (relat, template) = case p orig of- Right xs -> xs- Left err -> onError "replaceWorked" err-- (newExpr, newAnns) = runState (substTransform m subts template) (mergeAnns as relat)- lst = listToMaybe . reverse . GHC.occNameString . GHC.rdrNameOcc- adjacent (srcSpanEnd -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) = loc1 == loc2- adjacent _ _ = False-- -- Ensure that there is a space between two alphanumeric names, otherwise- -- 'y = f(x)' would be refactored into 'y = fx'.- ensureSpace :: Anns -> Anns- ensureSpace = fromMaybe id $ do- (L _ (HsVar _ (L _ newName))) :: LHsExpr GhcPs <- cast newExpr- hd <- listToMaybe $ case newName of- GHC.Unqual occName -> GHC.occNameString occName- GHC.Qual moduleName _ -> GHC.moduleNameString moduleName- GHC.Orig modu _ -> GHC.moduleNameString (GHC.moduleName modu)- GHC.Exact name -> GHC.occNameString (GHC.nameOccName name)- guard $ isAlphaNum hd- let prev :: [LHsExpr GhcPs] =- listify- (\case- (L loc (HsVar _ (L _ rdr))) -> maybe False isAlphaNum (lst rdr) && adjacent loc pos- _ -> False- )- m- guard . not . null $ prev- pure . flip Map.adjust (mkAnnKey newExpr) $ \ann ->- if annEntryDelta ann == DP (0, 0)- then ann { annEntryDelta = DP (0, 1) }- else ann-- replacementPred (GHC.L l _) = l == replExprLocation- transformation = everywhereM (mkM (doGenReplacement m (replacementPred . decomposeSrcSpan) newExpr))- in case runState (transformation m) (newAnns, False) of- (finalM, (finalAs, True)) -> (ensureSpace finalAs, finalM)- -- Failed to find a replacment so don't make any changes- _ -> (as, m)-replaceWorker as m _ _ _ = (as, m)---- Find the largest expression with a given SrcSpan-findGen :: forall ast a . (Data ast, Data a) => String -> a -> SrcSpan -> GHC.Located ast-findGen s m ss = fromMaybe (error (s ++ " " ++ showGhc ss)) (doTrans m)- where- doTrans :: a -> Maybe (GHC.Located ast)- doTrans = something (mkQ Nothing (findLargestExpression ss))--findExpr :: Data a => a -> SrcSpan -> Expr-findExpr = findGen "expr"--findPat :: Data a => a -> SrcSpan -> Pat-findPat = findGen "pat"--findType :: Data a => a -> SrcSpan -> Type-findType = findGen "type"--findDecl :: Data a => a -> SrcSpan -> Decl-findDecl = findGen "decl"--findStmt :: Data a => a -> SrcSpan -> Stmt-findStmt = findGen "stmt"--findName :: Data a => a -> SrcSpan -> Name-findName = findGen "name"--findLargestExpression :: SrcSpan -> GHC.Located ast- -> Maybe (GHC.Located ast)-findLargestExpression ss e@(GHC.L l _) =- if l == ss- then Just e- else Nothing---- Deletion from a list--doDeleteStmt :: Data a => (Stmt -> Bool) -> a -> a-doDeleteStmt p = everywhere (mkT (filter p))--doDeleteImport :: Data a => (Import -> Bool) -> a -> a-doDeleteImport p = everywhere (mkT (filter p))--{---- Renaming+ ) where -doRename :: [(String, String)] -> Module -> Module-doRename ss = everywhere (mkT rename)- where- rename :: GHC.OccName -> GHC.OccName- rename v = GHC.mkOccName n s'- where- (s, n) = (GHC.occNameString v, GHC.occNameSpace v)- s' = fromMaybe s (lookup s ss)--}+import Refact.Internal
src/Refact/Fixity.hs view
@@ -23,7 +23,7 @@ import Data.Maybe import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn) -import Control.Monad.State+import Control.Monad.Trans.State import qualified Data.Map as Map import Data.Tuple
+ src/Refact/Internal.hs view
@@ -0,0 +1,654 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+module Refact.Internal+ ( apply+ , runRefactoring+ , applyRefactorings++ -- * Support for runPipe in the main process+ , Verbosity(..)+ , rigidLayout+ , removeOverlap+ , refactOptions+ , type Errors+ , onError+ , mkErr+ ) where++import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.Annotate+import Language.Haskell.GHC.ExactPrint.Delta+import Language.Haskell.GHC.ExactPrint.Parsers+import Language.Haskell.GHC.ExactPrint.Print+import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn)+import Language.Haskell.GHC.ExactPrint.Utils++import Control.Arrow+import Control.Monad+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.State+import Data.Char (isAlphaNum)+import Data.Data+import Data.Functor.Identity (Identity(..))+import Data.Generics hiding (GT)+import qualified Data.Map as Map+import Data.Maybe+import Data.List+import Data.Ord+import System.IO+import System.IO.Unsafe++import Debug.Trace++#if __GLASGOW_HASKELL__ >= 810+import GHC.Hs.Expr as GHC hiding (Stmt)+import GHC.Hs.ImpExp+import GHC.Hs hiding (Pat, Stmt)+import Outputable hiding ((<>))+import ErrUtils+import Bag+#else+import HsExpr as GHC hiding (Stmt)+import HsImpExp+import HsSyn hiding (Pat, Stmt, noExt)+#endif++import SrcLoc+import qualified GHC hiding (parseModule)+import qualified Name as GHC+import qualified RdrName as GHC++import Refact.Fixity+import Refact.Types hiding (SrcSpan)+import qualified Refact.Types as R+import Refact.Utils (Stmt, Pat, Name, Decl, M, Module, Expr, Type, FunBind+ , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, setSrcSpanFile)++#if __GLASGOW_HASKELL__ >= 810+type Errors = ErrorMessages+onError :: String -> Errors -> a+onError s = pprPanic s . vcat . pprErrMsgBagWithLoc+#else+type Errors = (SrcSpan, String)+onError :: String -> Errors -> a+onError _ = error . show+#endif++#if __GLASGOW_HASKELL__ <= 806+composeSrcSpan :: a -> a+composeSrcSpan = id++decomposeSrcSpan :: a -> a+decomposeSrcSpan = id++type SrcSpanLess a = a+#endif++-- library access to perform the substitutions++refactOptions :: PrintOptions Identity String+refactOptions = stringOptions { epRigidity = RigidLayout }++rigidLayout :: DeltaOptions+rigidLayout = deltaOptions RigidLayout++-- | Apply a set of refactorings as supplied by hlint+apply+ :: Maybe (Int, Int)+ -> Bool+ -> [(String, [Refactoring R.SrcSpan])]+ -> FilePath+ -> Verbosity+ -> Anns+ -> Module+ -> IO String+apply mpos step inp file verb as0 m0 = do+ let noOverlapInp = removeOverlap verb inp+ allRefacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp++ posFilter (_, rs) =+ case mpos of+ Nothing -> True+ Just p -> any (flip spans p . pos) rs+ filtRefacts = filter posFilter allRefacts+ refacts = concatMap snd filtRefacts++ when (verb >= Normal) (traceM $ "Applying " ++ show (length refacts) ++ " hints")+ when (verb == Loud) (traceM $ show filtRefacts)++ -- need a check here to avoid overlap+ (as, m) <- if step+ then fromMaybe (as0, m0) <$> runMaybeT (refactoringLoop as0 m0 filtRefacts)+ else pure . flip evalState 0 $+ foldM (uncurry runRefactoring) (as0, m0) refacts+ pure . runIdentity $ exactPrintWithOptions refactOptions m as++data LoopOption = LoopOption+ { desc :: String+ , perform :: MaybeT IO (Anns, Module) }++refactoringLoop :: Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])]+ -> MaybeT IO (Anns, Module)+refactoringLoop as m [] = pure (as, m)+refactoringLoop as m ((_, []): rs) = refactoringLoop as m rs+refactoringLoop as m hints@((hintDesc, rs): rss) =+ do inp <- liftIO $ do+ putStrLn hintDesc+ putStrLn $ "Apply hint [" ++ intercalate ", " (map fst opts) ++ "]"+ -- In case that the input also comes from stdin+ withFile "/dev/tty" ReadMode hGetLine+ maybe loopHelp perform (lookup inp opts)+ where+ opts =+ [ ("y", LoopOption "Apply current hint" yAction)+ , ("n", LoopOption "Don't apply the current hint" (refactoringLoop as m rss))+ , ("q", LoopOption "Apply no further hints" (return (as, m)))+ , ("d", LoopOption "Discard previous changes" mzero )+ , ("v", LoopOption "View current file" (liftIO (putStrLn (exactPrint m as))+ >> refactoringLoop as m hints))+ , ("?", LoopOption "Show this help menu" loopHelp)]+ loopHelp = do+ liftIO . putStrLn . unlines . map mkLine $ opts+ refactoringLoop as m hints+ mkLine (c, opt) = c ++ " - " ++ desc opt+ -- Force to force bottoms+ yAction =+ let (!r1, !r2) = flip evalState 0 $ foldM (uncurry runRefactoring) (as, m) rs+ in do+ exactPrint r2 r1 `seq` return ()+ refactoringLoop r1 r2 rss++-- | Apply a set of refactorings as supplied by hlint+applyRefactorings+ :: Maybe (Int, Int)+ -- ^ Apply hints relevant to a specific position+ -> [(String, [Refactoring R.SrcSpan])]+ -- ^ A list of (hint description, refactorings) pairs.+ -> FilePath+ -- ^ Target file+ -> IO String+applyRefactorings optionsPos inp file = do+ (as, m) <- either (onError "apply") (uncurry applyFixities)+ <$> parseModuleWithOptions rigidLayout file+ apply optionsPos False inp file Silent as m++data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord)++-- Filters out overlapping ideas, picking the first idea in a set of overlapping ideas.+-- If two ideas start in the exact same place, pick the largest edit.+removeOverlap :: Verbosity -> [(String, [Refactoring R.SrcSpan])] -> [(String, [Refactoring R.SrcSpan])]+removeOverlap verb = dropOverlapping . sortBy f . summarize+ where+ -- We want to consider all Refactorings of a single idea as a unit, so compute a summary+ -- SrcSpan that encompasses all the Refactorings within each idea.+ summarize :: [(String, [Refactoring R.SrcSpan])] -> [(String, (R.SrcSpan, [Refactoring R.SrcSpan]))]+ summarize ideas = [ (s, (foldr1 summary (map pos rs), rs)) | (s, rs) <- ideas, not (null rs) ]++ summary (R.SrcSpan sl1 sc1 el1 ec1)+ (R.SrcSpan sl2 sc2 el2 ec2) =+ let (sl, sc) = case compare sl1 sl2 of+ LT -> (sl1, sc1)+ EQ -> (sl1, min sc1 sc2)+ GT -> (sl2, sc2)+ (el, ec) = case compare el1 el2 of+ LT -> (el2, ec2)+ EQ -> (el2, max ec1 ec2)+ GT -> (el1, ec1)+ in R.SrcSpan sl sc el ec++ -- Order by span start. If starting in same place, order by size.+ f (_,(s1,_)) (_,(s2,_)) =+ comparing startLine s1 s2 <> -- s1 first if it starts on earlier line+ comparing startCol s1 s2 <> -- or on earlier column+ comparing endLine s2 s1 <> -- they start in same place, s2 comes+ comparing endCol s2 s1 -- first if it ends later+ -- else, completely same span, so s1 will be first++ dropOverlapping [] = []+ dropOverlapping (p:ps) = go p ps+ go (s,(_,rs)) [] = [(s,rs)]+ go p@(s,(_,rs)) (x:xs)+ | p `overlaps` x = (if verb > Silent+ then trace ("Ignoring " ++ show (snd (snd x)) ++ " due to overlap.")+ else id) go p xs+ | otherwise = (s,rs) : go x xs+ -- for overlaps, we know s1 always starts <= s2, due to our sort+ overlaps (_,(s1,_)) (_,(s2,_)) =+ case compare (startLine s2) (endLine s1) of+ LT -> True+ EQ -> startCol s2 <= endCol s1+ GT -> False++-- ---------------------------------------------------------------------++-- Perform the substitutions++getSeed :: State Int Int+getSeed = get <* modify (+1)++-- | Peform a @Refactoring@.+runRefactoring :: Data a => Anns -> a -> Refactoring GHC.SrcSpan -> State Int (Anns, a)+runRefactoring as m r@Replace{} = do+ seed <- getSeed+ return $ case rtype r of+ Expr -> replaceWorker as m parseExpr seed r+ Decl -> replaceWorker as m parseDecl seed r+ Type -> replaceWorker as m parseType seed r+ Pattern -> replaceWorker as m parsePattern seed r+ Stmt -> replaceWorker as m parseStmt seed r+ Bind -> replaceWorker as m parseBind seed r+ R.Match -> replaceWorker as m parseMatch seed r+ ModuleName -> replaceWorker as m (parseModuleName (pos r)) seed r+ Import -> replaceWorker as m parseImport seed r++runRefactoring as m ModifyComment{..} =+ return (Map.map go as, m)+ where+ go a@Ann{ annPriorComments, annsDP } =+ a { annsDP = map changeComment annsDP+ , annPriorComments = map (first change) annPriorComments }+ changeComment (AnnComment d, dp) = (AnnComment (change d), dp)+ changeComment e = e+ change old@Comment{..}= if ss2pos commentIdentifier == ss2pos pos+ then old { commentContents = newComment}+ else old+runRefactoring as m Delete{rtype, pos} = do+ let f = case rtype of+ Stmt -> doDeleteStmt ((/= pos) . getLoc)+ Import -> doDeleteImport ((/= pos) . getLoc)+ _ -> id+ return (as, f m)+ {-+runRefactoring as m Rename{nameSubts} = (as, m)+ --(as, doRename nameSubts m)+ -}+runRefactoring as m InsertComment{..} =+ let exprkey = mkAnnKey (findDecl m pos) in+ return (insertComment exprkey newComment as, m)+runRefactoring as m RemoveAsKeyword{..} =+ return (as, removeAsKeyword m)+ where+ removeAsKeyword = everywhere (mkT go)+ go :: LImportDecl GHC.GhcPs -> LImportDecl GHC.GhcPs+ go imp@(GHC.L l i) | l == pos = GHC.L l (i { ideclAs = Nothing })+ | otherwise = imp++-- Specialised parsers+mkErr :: GHC.DynFlags -> SrcSpan -> String -> Errors+#if __GLASGOW_HASKELL__ >= 810+mkErr df l s = unitBag (mkPlainErrMsg df l (text s))+#else+mkErr = const (,)+#endif++parseModuleName :: GHC.SrcSpan -> Parser (GHC.Located GHC.ModuleName)+parseModuleName ss _ _ s =+ let newMN = GHC.L ss (GHC.mkModuleName s)+ newAnns = relativiseApiAnns newMN (Map.empty, Map.empty)+ in return (newAnns, newMN)+parseBind :: Parser (GHC.LHsBind GHC.GhcPs)+parseBind dyn fname s =+ case parseDecl dyn fname s of+ -- Safe as we add no annotations to the ValD+ Right (as, GHC.L l (GHC.ValD _ b)) -> Right (as, GHC.L l b)+ Right (_, GHC.L l _) -> Left (mkErr dyn l "Not a HsBind")+ Left e -> Left e+parseMatch :: Parser (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs))+parseMatch dyn fname s =+ case parseBind dyn fname s of+ Right (as, GHC.L l GHC.FunBind{fun_matches}) ->+ case unLoc (GHC.mg_alts fun_matches) of+ [x] -> Right (as, x)+ _ -> Left (mkErr dyn l "Not a single match")+ Right (_, GHC.L l _) -> Left (mkErr dyn l "Not a funbind")+ Left e -> Left e++-- Substitute variables into templates+-- Finds places in the templates where we need to insert variables.++substTransform :: (Data a, Data b) => b -> [(String, GHC.SrcSpan)] -> a -> M a+substTransform m ss = everywhereM (mkM (typeSub m ss)+ `extM` identSub m ss+ `extM` patSub m ss+ `extM` stmtSub m ss+ `extM` exprSub m ss+ )++stmtSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Stmt -> M Stmt+stmtSub m subs old@(GHC.L _ (BodyStmt _ (GHC.L _ (HsVar _ (L _ name))) _ _) ) =+ resolveRdrName m (findStmt m) old subs name+stmtSub _ _ e = return e++patSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Pat -> M Pat+patSub m subs old@(GHC.L _ (VarPat _ (L _ name))) =+ resolveRdrName m (findPat m) old subs name+patSub _ _ e = return e++typeSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Type -> M Type+typeSub m subs old@(GHC.L _ (HsTyVar _ _ (L _ name))) =+ resolveRdrName m (findType m) old subs name+typeSub _ _ e = return e++exprSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Expr -> M Expr+exprSub m subs old@(GHC.L _ (HsVar _ (L _ name))) =+ resolveRdrName m (findExpr m) old subs name+exprSub _ _ e = return e+++-- Used for Monad10, Monad11 tests.+-- The issue being that in one case the information is attached to a VarPat+-- but we need to move the annotations onto the actual name+--+-- This looks convoluted but we can't match directly on a located name as+-- it is not specific enough. Instead we match on some bigger context which+-- is contains the located name we want to replace.+identSub :: Data a => a -> [(String, GHC.SrcSpan)] -> FunBind -> M FunBind+identSub m subs old@(GHC.FunRhs (GHC.L _ name) _ _) =+ resolveRdrName' subst (findName m) old subs name+ where+ subst :: FunBind -> Name -> M FunBind+ subst (GHC.FunRhs n b s) new = do+ let fakeExpr :: Located (GHC.Pat GhcPs)+ fakeExpr = GHC.L (getLoc new) (GHC.VarPat noExt new)+ -- Low level version as we need to combine the annotation information+ -- from the template RdrName and the original VarPat.+ modify (\r -> replaceAnnKey r (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr))+ return $ GHC.FunRhs new b s+ subst o _ = return o+identSub _ _ e = return e++++-- g is usually modifyAnnKey+-- f is usually a function which checks the locations are equal+resolveRdrName' :: (a -> b -> M a) -- How to combine the value to insert and the replaced value+ -> (SrcSpan -> b) -- How to find the new value, when given the location it is in+ -> a -- The old thing which we are going to possibly replace+ -> [(String, GHC.SrcSpan)] -- Substs+ -> GHC.RdrName -- The name of the position in the template+ --we are replacing into+ -> M a+resolveRdrName' g f old subs name =+ case name of+ -- Todo: this should replace anns as well?+ GHC.Unqual (GHC.occNameString . GHC.occName -> oname)+ -> case lookup oname subs of+ Just (f -> new) -> g old new+ Nothing -> return old+ _ -> return old++resolveRdrName :: (Data old, Data a)+ => a+ -> (SrcSpan -> Located old)+ -> Located old+ -> [(String, SrcSpan)]+ -> GHC.RdrName+ -> M (Located old)+resolveRdrName m = resolveRdrName' (modifyAnnKey m)++insertComment :: AnnKey -> String+ -> Map.Map AnnKey Annotation+ -> Map.Map AnnKey Annotation+insertComment k s as =+ let comment = Comment s GHC.noSrcSpan Nothing in+ Map.adjust (\a@Ann{..} -> a { annPriorComments = annPriorComments ++ [(comment, DP (1,0))]+ , annEntryDelta = DP (1,0) }) k as+++-- Substitute the template into the original AST.+#if __GLASGOW_HASKELL__ <= 806+doGenReplacement+ :: forall ast a. (Data ast, Data a)+ => a+ -> (GHC.Located ast -> Bool)+ -> GHC.Located ast+ -> GHC.Located ast+ -> State (Anns, Bool) (GHC.Located ast)+#else+doGenReplacement+ :: forall ast a. (Data (SrcSpanLess ast), HasSrcSpan ast, Data a)+ => a+ -> (ast -> Bool)+ -> ast+ -> ast+ -> State (Anns, Bool) ast+#endif+doGenReplacement m p new old+ | p old = do+ anns <- gets fst+ let n = decomposeSrcSpan new+ o = decomposeSrcSpan old+ newAnns = execState (modifyAnnKey m o n) anns+ put (newAnns, True)+ pure new+ -- If "f a = body where local" doesn't satisfy the predicate, but "f a = body" does,+ -- run the replacement on "f a = body", and add "local" back afterwards.+ -- This is useful for hints like "Eta reduce" and "Redundant where".+ | Just Refl <- eqT @(SrcSpanLess ast) @(HsDecl GHC.GhcPs)+ , L _ (ValD xvald newBind@FunBind{}) <- decomposeSrcSpan new+ , Just (oldNoLocal, oldLocal) <- stripLocalBind (decomposeSrcSpan old)+ , newLoc@(RealSrcSpan newLocReal) <- getLoc new+ , p (composeSrcSpan oldNoLocal) = do+ anns <- gets fst+ let n = decomposeSrcSpan new+ o = decomposeSrcSpan old+ intAnns = execState (modifyAnnKey m o n) anns+ newFile = srcSpanFile newLocReal+ newLocal = everywhere (mkT $ setSrcSpanFile newFile) oldLocal+ newLocalLoc = getLoc newLocal+ ensureLoc = combineSrcSpans newLocalLoc+ newMG = fun_matches newBind+ L locMG [L locMatch newMatch] = mg_alts newMG+ newGRHSs = m_grhss newMatch+ finalLoc = ensureLoc newLoc+ newWithLocalBinds = setLocalBind newLocal xvald newBind finalLoc+ newMG (ensureLoc locMG) newMatch (ensureLoc locMatch) newGRHSs++ -- Ensure the new Anns properly reflects the local binds we added back.+ addLocalBindsToAnns = addAnnWhere+ . Map.fromList+ . map (first (expandTemplateLoc . updateFile . expandGRHSLoc))+ . Map.toList+ where+ addAnnWhere :: Anns -> Anns+ addAnnWhere oldAnns =+ let oldAnns' = Map.toList oldAnns+ po = \case+ (AnnKey loc@(RealSrcSpan r) con, _) ->+ loc == getLoc old && con == CN "Match" && srcSpanFile r /= newFile+ _ -> False+ pn = \case+ (AnnKey loc@(RealSrcSpan r) con, _) ->+ loc == finalLoc && con == CN "Match" && srcSpanFile r == newFile+ _ -> False+ in fromMaybe oldAnns $ do+ oldAnn <- snd <$> find po oldAnns'+ annWhere <- find ((== G GHC.AnnWhere) . fst) (annsDP oldAnn)+ newKey <- fst <$> find pn oldAnns'+ pure $ Map.adjust (\ann -> ann {annsDP = annsDP ann ++ [annWhere]}) newKey oldAnns++ -- Expand the SrcSpan of the "GRHS" entry in the new file to include the local binds+ expandGRHSLoc = \case+ AnnKey loc@(RealSrcSpan r) con+ | con == CN "GRHS", srcSpanFile r == newFile -> AnnKey (ensureLoc loc) con+ other -> other++ -- If an Anns entry corresponds to the local binds, update its file to point to the new file.+ updateFile = \case+ AnnKey loc con+ | loc `isSubspanOf` getLoc oldLocal -> AnnKey (setSrcSpanFile newFile loc) con+ other -> other++ -- For each SrcSpan in the new file that is the entire newLoc, set it to finalLoc+ expandTemplateLoc = \case+ AnnKey loc con+ | loc == newLoc -> AnnKey finalLoc con+ other -> other++ newAnns = addLocalBindsToAnns intAnns+ put (newAnns, True)+ pure $ composeSrcSpan newWithLocalBinds+ | otherwise = pure old++-- | If the input is a FunBind with a single match, e.g., "foo a = body where x = y"+-- return "Just (foo a = body, x = y)". Otherwise return Nothing.+stripLocalBind+ :: LHsDecl GHC.GhcPs+ -> Maybe (LHsDecl GHC.GhcPs, LHsLocalBinds GHC.GhcPs)+stripLocalBind = \case+ L _ (ValD xvald origBind@FunBind{})+ | let origMG = fun_matches origBind+ , L locMG [L locMatch origMatch] <- mg_alts origMG+ , let origGRHSs = m_grhss origMatch+ , [L _ (GRHS _ _ (L loc2 _))] <- grhssGRHSs origGRHSs ->+ let loc1 = getLoc (fun_id origBind)+ newLoc = combineSrcSpans loc1 loc2+ withoutLocalBinds = setLocalBind (noLoc (EmptyLocalBinds noExt)) xvald origBind newLoc origMG locMG+ origMatch locMatch origGRHSs+ in Just (withoutLocalBinds, grhssLocalBinds origGRHSs)+ _ -> Nothing++-- | Set the local binds in a HsBind.+setLocalBind+ :: LHsLocalBinds GHC.GhcPs+ -> XValD GhcPs+ -> HsBind GhcPs+ -> SrcSpan+ -> MatchGroup GhcPs (LHsExpr GhcPs)+ -> SrcSpan+ -> Match GhcPs (LHsExpr GhcPs)+ -> SrcSpan+ -> GRHSs GhcPs (LHsExpr GhcPs)+ -> LHsDecl GhcPs+setLocalBind newLocalBinds xvald origBind newLoc origMG locMG origMatch locMatch origGRHSs =+ L newLoc (ValD xvald newBind)+ where+ newGRHSs = origGRHSs{grhssLocalBinds = newLocalBinds}+ newMatch = origMatch{m_grhss = newGRHSs}+ newMG = origMG{mg_alts = L locMG [L locMatch newMatch]}+ newBind = origBind{fun_matches = newMG}++#if __GLASGOW_HASKELL__ <= 806+replaceWorker :: (Annotate a, Data mod)+ => Anns+ -> mod+ -> Parser (GHC.Located a)+ -> Int+ -> Refactoring GHC.SrcSpan+ -> (Anns, mod)+#else+replaceWorker :: (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a))+ => Anns+ -> mod+ -> Parser a+ -> Int+ -> Refactoring GHC.SrcSpan+ -> (Anns, mod)+#endif+replaceWorker as m parser seed Replace{..} =+ let replExprLocation = pos+ uniqueName = "template" ++ show seed+ p s = unsafePerformIO (withDynFlags (\d -> parser d uniqueName s))+ (relat, template) = case p orig of+ Right xs -> xs+ Left err -> onError "replaceWorked" err++ (newExpr, newAnns) = runState (substTransform m subts template) (mergeAnns as relat)+ lst = listToMaybe . reverse . GHC.occNameString . GHC.rdrNameOcc+ adjacent (srcSpanEnd -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) = loc1 == loc2+ adjacent _ _ = False++ -- Ensure that there is a space between two alphanumeric names, otherwise+ -- 'y = f(x)' would be refactored into 'y = fx'.+ ensureSpace :: Anns -> Anns+ ensureSpace = fromMaybe id $ do+ (L _ (HsVar _ (L _ newName))) :: LHsExpr GhcPs <- cast newExpr+ hd <- listToMaybe $ case newName of+ GHC.Unqual occName -> GHC.occNameString occName+ GHC.Qual moduleName _ -> GHC.moduleNameString moduleName+ GHC.Orig modu _ -> GHC.moduleNameString (GHC.moduleName modu)+ GHC.Exact name -> GHC.occNameString (GHC.nameOccName name)+ guard $ isAlphaNum hd+ let prev :: [LHsExpr GhcPs] =+ listify+ (\case+ (L loc (HsVar _ (L _ rdr))) -> maybe False isAlphaNum (lst rdr) && adjacent loc pos+ _ -> False+ )+ m+ guard . not . null $ prev+ pure . flip Map.adjust (mkAnnKey newExpr) $ \ann ->+ if annEntryDelta ann == DP (0, 0)+ then ann { annEntryDelta = DP (0, 1) }+ else ann++ replacementPred (GHC.L l _) = l == replExprLocation+ transformation = everywhereM (mkM (doGenReplacement m (replacementPred . decomposeSrcSpan) newExpr))+ in case runState (transformation m) (newAnns, False) of+ (finalM, (finalAs, True)) -> (ensureSpace finalAs, finalM)+ -- Failed to find a replacment so don't make any changes+ _ -> (as, m)+replaceWorker as m _ _ _ = (as, m)++-- Find the largest expression with a given SrcSpan+findGen :: forall ast a . (Data ast, Data a) => String -> a -> SrcSpan -> GHC.Located ast+findGen s m ss = fromMaybe (error (s ++ " " ++ showGhc ss)) (doTrans m)+ where+ doTrans :: a -> Maybe (GHC.Located ast)+ doTrans = something (mkQ Nothing (findLargestExpression ss))++findExpr :: Data a => a -> SrcSpan -> Expr+findExpr = findGen "expr"++findPat :: Data a => a -> SrcSpan -> Pat+findPat = findGen "pat"++findType :: Data a => a -> SrcSpan -> Type+findType = findGen "type"++findDecl :: Data a => a -> SrcSpan -> Decl+findDecl = findGen "decl"++findStmt :: Data a => a -> SrcSpan -> Stmt+findStmt = findGen "stmt"++findName :: Data a => a -> SrcSpan -> Name+findName = findGen "name"++findLargestExpression :: SrcSpan -> GHC.Located ast+ -> Maybe (GHC.Located ast)+findLargestExpression ss e@(GHC.L l _) =+ if l == ss+ then Just e+ else Nothing++-- Deletion from a list++doDeleteStmt :: Data a => (Stmt -> Bool) -> a -> a+doDeleteStmt p = everywhere (mkT (filter p))++doDeleteImport :: Data a => (Import -> Bool) -> a -> a+doDeleteImport p = everywhere (mkT (filter p))++{-+-- Renaming++doRename :: [(String, String)] -> Module -> Module+doRename ss = everywhere (mkT rename)+ where+ rename :: GHC.OccName -> GHC.OccName+ rename v = GHC.mkOccName n s'+ where+ (s, n) = (GHC.occNameString v, GHC.occNameSpace v)+ s' = fromMaybe s (lookup s ss)+-}
src/Refact/Run.hs view
@@ -1,16 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE ViewPatterns #-}+ module Refact.Run where import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Print import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP ( defaultCppOptions , ghcWrapper@@ -24,22 +23,19 @@ import Refact.Types hiding (SrcSpan) import Refact.Apply import Refact.Fixity-import Refact.Utils (toGhcSrcSpan, Module)+import Refact.Internal (apply) import DynFlags import HeaderInfo (getOptions) import HscTypes (handleSourceError) import qualified GHC (setSessionDynFlags, ParsedSource) import Panic (handleGhcException)-import qualified SrcLoc as GHC import SrcLoc import StringBuffer (stringToStringBuffer) import GHC.LanguageExtensions.Type (Extension(..)) import Control.Monad-import Control.Monad.State-import Control.Monad.Identity-import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class (MonadIO(..)) import Data.Char import Data.List hiding (find) import qualified Data.List as List@@ -254,27 +250,7 @@ (as, m) <- either (onError "runPipe") (uncurry applyFixities) <$> parseModuleWithArgs optionsLanguage file when optionsDebug (putStrLn (showAnnData as 0 m))-- let noOverlapInp = removeOverlap verb inp- allRefacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp-- posFilter (_, rs) =- case optionsPos of- Nothing -> True- Just p -> any (flip spans p . pos) rs- filtRefacts = filter posFilter allRefacts- refacts = concatMap snd filtRefacts-- when (verb >= Normal) (traceM $ "Applying " ++ show (length refacts) ++ " hints")- when (verb == Loud) (traceM $ show filtRefacts)-- -- need a check here to avoid overlap- (ares, res) <- if optionsStep- then fromMaybe (as, m) <$> runMaybeT (refactoringLoop as m filtRefacts)- else return . flip evalState 0 $- foldM (uncurry runRefactoring) (as, m) refacts- when optionsDebug (putStrLn (showAnnData ares 0 res))- pure . runIdentity $ exactPrintWithOptions refactOptions res ares+ apply optionsPos optionsStep inp file verb as m if optionsInplace && isJust optionsTarget then writeFileUTF8 file output@@ -283,42 +259,6 @@ Just f -> do when (verb == Loud) (traceM $ "Writing result to " ++ f) writeFileUTF8 f output--data LoopOption = LoopOption- { desc :: String- , perform :: MaybeT IO (Anns, Module) }--refactoringLoop :: Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])]- -> MaybeT IO (Anns, Module)-refactoringLoop as m [] = pure (as, m)-refactoringLoop as m ((_, []): rs) = refactoringLoop as m rs-refactoringLoop as m hints@((hintDesc, rs): rss) =- do inp <- liftIO $ do- putStrLn hintDesc- putStrLn $ "Apply hint [" ++ intercalate ", " (map fst opts) ++ "]"- -- In case that the input also comes from stdin- withFile "/dev/tty" ReadMode hGetLine- maybe loopHelp perform (lookup inp opts)- where- opts =- [ ("y", LoopOption "Apply current hint" yAction)- , ("n", LoopOption "Don't apply the current hint" (refactoringLoop as m rss))- , ("q", LoopOption "Apply no further hints" (return (as, m)))- , ("d", LoopOption "Discard previous changes" mzero )- , ("v", LoopOption "View current file" (liftIO (putStrLn (exactPrint m as))- >> refactoringLoop as m hints))- , ("?", LoopOption "Show this help menu" loopHelp)]- loopHelp = do- liftIO . putStrLn . unlines . map mkLine $ opts- refactoringLoop as m hints- mkLine (c, opt) = c ++ " - " ++ desc opt- -- Force to force bottoms- yAction =- let (!r1, !r2) = flip evalState 0 $ foldM (uncurry runRefactoring) (as, m) rs- in do- exactPrint r2 r1 `seq` return ()- refactoringLoop r1 r2 rss- getHints :: Maybe FilePath -> IO String getHints (Just hintFile) = readFileUTF8' hintFile
src/Refact/Utils.hs view
@@ -49,7 +49,7 @@ import HsImpExp #endif -import Control.Monad.State+import Control.Monad.Trans.State import qualified Data.Map as Map import Data.Maybe