diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,7 @@ +v0.8.2.0 + + * #75, support refactoring for Eta reduce + v0.8.1.0 * #68, support GHC 8.6 diff --git a/apply-refact.cabal b/apply-refact.cabal --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: apply-refact -version: 0.8.1.0 +version: 0.8.2.0 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 diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} module Refact.Apply ( runRefactoring @@ -38,7 +39,7 @@ import Data.Data import Data.Generics.Schemes import Data.Maybe -import Data.List hiding (find) +import Data.List import Data.Ord #if __GLASGOW_HASKELL__ >= 810 @@ -70,7 +71,7 @@ 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) + , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, setSrcSpanFile) #if __GLASGOW_HASKELL__ >= 810 type Errors = ErrorMessages @@ -88,6 +89,8 @@ decomposeSrcSpan :: a -> a decomposeSrcSpan = id + +type SrcSpanLess a = a #endif -- library access to perform the substitutions @@ -343,30 +346,137 @@ -- Substitute the template into the original AST. #if __GLASGOW_HASKELL__ <= 806 -doGenReplacement :: (Data ast, Data a) - => a - -> (GHC.Located ast -> Bool) - -> GHC.Located ast - -> GHC.Located ast - -> State (Anns, Bool) (GHC.Located ast) +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 :: (Data (SrcSpanLess ast), HasSrcSpan ast, Data a) - => a - -> (ast -> Bool) - -> ast - -> ast - -> State (Anns, Bool) ast +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 = - if p old then do - s <- get - let n = decomposeSrcSpan new - o = decomposeSrcSpan old - (v, st) = runState (modifyAnnKey m o n) (fst s) - modify (const (st, True)) - return $ composeSrcSpan v - else return old +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 @@ -428,8 +538,6 @@ -- 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 diff --git a/src/Refact/Utils.hs b/src/Refact/Utils.hs --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -23,6 +23,7 @@ , modifyAnnKey , replaceAnnKey , toGhcSrcSpan + , setSrcSpanFile , findParent ) where @@ -32,6 +33,7 @@ import Data.Data +import FastString (FastString) import SrcLoc import qualified SrcLoc as GHC import qualified RdrName as GHC @@ -172,3 +174,12 @@ toGhcSrcSpan file R.SrcSpan{..} = mkSrcSpan (f startLine startCol) (f endLine endCol) where f = mkSrcLoc (GHC.mkFastString file) + +setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan +setSrcSpanFile file s + | RealSrcLoc start <- srcSpanStart s + , RealSrcLoc end <- srcSpanEnd s + = let start' = mkSrcLoc file (srcLocLine start) (srcLocCol start) + end' = mkSrcLoc file (srcLocLine end) (srcLocCol end) + in mkSrcSpan start' end' +setSrcSpanFile _ s = s diff --git a/tests/examples/Default71.hs.expected b/tests/examples/Default71.hs.expected --- a/tests/examples/Default71.hs.expected +++ b/tests/examples/Default71.hs.expected @@ -1,1 +1,1 @@ -fooer input = mapMaybe Just $ input +fooer = catMaybes . map Just diff --git a/tests/examples/Default71.hs.refact b/tests/examples/Default71.hs.refact --- a/tests/examples/Default71.hs.refact +++ b/tests/examples/Default71.hs.refact @@ -1,1 +1,1 @@ -[("tests/examples/Default71.hs:1:1-42: Warning: Eta reduce\nFound:\n fooer input = catMaybes . map Just $ input\nPerhaps:\n fooer = catMaybes . map Just\n",[]),("tests/examples/Default71.hs:1:15-34: Warning: Use mapMaybe\nFound:\n catMaybes . map Just\nPerhaps:\n mapMaybe Just\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 15, endLine = 1, endCol = 35}, subts = [("f",SrcSpan {startLine = 1, startCol = 31, endLine = 1, endCol = 35})], orig = "mapMaybe f"}])] +[("tests/examples/Default71.hs:1:1-42: Warning: Eta reduce\nFound:\n fooer input = catMaybes . map Just $ input\nPerhaps:\n fooer = catMaybes . map Just\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 43}, subts = [("body",SrcSpan {startLine = 1, startCol = 15, endLine = 1, endCol = 35})], orig = "fooer = body"}]),("tests/examples/Default71.hs:1:15-34: Warning: Use mapMaybe\nFound:\n catMaybes . map Just\nPerhaps:\n mapMaybe Just\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 15, endLine = 1, endCol = 35}, subts = [("f",SrcSpan {startLine = 1, startCol = 31, endLine = 1, endCol = 35})], orig = "mapMaybe f"}])] diff --git a/tests/examples/Lambda37.hs b/tests/examples/Lambda37.hs --- a/tests/examples/Lambda37.hs +++ b/tests/examples/Lambda37.hs @@ -1,1 +1,1 @@ -foo a b c = bar (flux ++ quux) c where flux = a +foo d a c b = bar (flux ++ quux) c b where flux = d diff --git a/tests/examples/Lambda37.hs.expected b/tests/examples/Lambda37.hs.expected --- a/tests/examples/Lambda37.hs.expected +++ b/tests/examples/Lambda37.hs.expected @@ -1,1 +1,1 @@ -foo a b c = bar (flux ++ quux) c where flux = a +foo d a = bar (flux ++ quux) where flux = d diff --git a/tests/examples/Lambda37.hs.refact b/tests/examples/Lambda37.hs.refact --- a/tests/examples/Lambda37.hs.refact +++ b/tests/examples/Lambda37.hs.refact @@ -1,1 +1,1 @@ -[("tests/examples/Lambda37.hs:1:1-32: Warning: Eta reduce\nFound:\n foo a b c = bar (flux ++ quux) c\nPerhaps:\n foo a b = bar (flux ++ quux)\n",[])] +[("tests/examples/Lambda37.hs:1:1-36: Warning: Eta reduce\nFound:\n foo d a c b = bar (flux ++ quux) c b\nPerhaps:\n foo d a = bar (flux ++ quux)\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 37}, subts = [("body",SrcSpan {startLine = 1, startCol = 15, endLine = 1, endCol = 33}),("a",SrcSpan {startLine = 1, startCol = 5, endLine = 1, endCol = 6}),("b",SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 8})], orig = "foo a b = body"}])] diff --git a/tests/examples/Lambda4.hs.expected b/tests/examples/Lambda4.hs.expected --- a/tests/examples/Lambda4.hs.expected +++ b/tests/examples/Lambda4.hs.expected @@ -1,1 +1,1 @@ -fun x y z = f x y z +fun = f diff --git a/tests/examples/Lambda4.hs.refact b/tests/examples/Lambda4.hs.refact --- a/tests/examples/Lambda4.hs.refact +++ b/tests/examples/Lambda4.hs.refact @@ -1,1 +1,1 @@ -[("tests/examples/Lambda4.hs:1:1-19: Warning: Eta reduce\nFound:\n fun x y z = f x y z\nPerhaps:\n fun = f\n",[])] +[("tests/examples/Lambda4.hs:1:1-19: Warning: Eta reduce\nFound:\n fun x y z = f x y z\nPerhaps:\n fun = f\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 20}, subts = [("body",SrcSpan {startLine = 1, startCol = 13, endLine = 1, endCol = 14})], orig = "fun = body"}])] diff --git a/tests/examples/Lambda5.hs.expected b/tests/examples/Lambda5.hs.expected --- a/tests/examples/Lambda5.hs.expected +++ b/tests/examples/Lambda5.hs.expected @@ -1,1 +1,1 @@ -fun x y z = f x x y z +fun x = f x x diff --git a/tests/examples/Lambda5.hs.refact b/tests/examples/Lambda5.hs.refact --- a/tests/examples/Lambda5.hs.refact +++ b/tests/examples/Lambda5.hs.refact @@ -1,1 +1,1 @@ -[("tests/examples/Lambda5.hs:1:1-21: Warning: Eta reduce\nFound:\n fun x y z = f x x y z\nPerhaps:\n fun x = f x x\n",[])] +[("tests/examples/Lambda5.hs:1:1-21: Warning: Eta reduce\nFound:\n fun x y z = f x x y z\nPerhaps:\n fun x = f x x\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 22}, subts = [("body",SrcSpan {startLine = 1, startCol = 13, endLine = 1, endCol = 18}),("a",SrcSpan {startLine = 1, startCol = 5, endLine = 1, endCol = 6})], orig = "fun a = body"}])] diff --git a/tests/examples/Lambda6.hs.expected b/tests/examples/Lambda6.hs.expected --- a/tests/examples/Lambda6.hs.expected +++ b/tests/examples/Lambda6.hs.expected @@ -1,1 +1,1 @@ -fun x y z = f g z +fun x y = f g diff --git a/tests/examples/Lambda6.hs.refact b/tests/examples/Lambda6.hs.refact --- a/tests/examples/Lambda6.hs.refact +++ b/tests/examples/Lambda6.hs.refact @@ -1,1 +1,1 @@ -[("tests/examples/Lambda6.hs:1:1-17: Warning: Eta reduce\nFound:\n fun x y z = f g z\nPerhaps:\n fun x y = f g\n",[])] +[("tests/examples/Lambda6.hs:1:1-17: Warning: Eta reduce\nFound:\n fun x y z = f g z\nPerhaps:\n fun x y = f g\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 18}, subts = [("body",SrcSpan {startLine = 1, startCol = 13, endLine = 1, endCol = 16}),("a",SrcSpan {startLine = 1, startCol = 5, endLine = 1, endCol = 6}),("b",SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 8})], orig = "fun a b = body"}])] diff --git a/tests/examples/Lambda7.hs.expected b/tests/examples/Lambda7.hs.expected --- a/tests/examples/Lambda7.hs.expected +++ b/tests/examples/Lambda7.hs.expected @@ -1,1 +1,1 @@ -fun mr = y mr +fun = y diff --git a/tests/examples/Lambda7.hs.refact b/tests/examples/Lambda7.hs.refact --- a/tests/examples/Lambda7.hs.refact +++ b/tests/examples/Lambda7.hs.refact @@ -1,1 +1,1 @@ -[("tests/examples/Lambda7.hs:1:1-13: Warning: Eta reduce\nFound:\n fun mr = y mr\nPerhaps:\n fun = y\n",[])] +[("tests/examples/Lambda7.hs:1:1-13: Warning: Eta reduce\nFound:\n fun mr = y mr\nPerhaps:\n fun = y\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 14}, subts = [("body",SrcSpan {startLine = 1, startCol = 10, endLine = 1, endCol = 11})], orig = "fun = body"}])]