diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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.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 diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -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 diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs --- a/src/Refact/Fixity.hs +++ b/src/Refact/Fixity.hs @@ -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 diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Refact/Internal.hs @@ -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) +-} diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -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 diff --git a/src/Refact/Utils.hs b/src/Refact/Utils.hs --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -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