{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} module Refact.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.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 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) -}