apply-refact 0.9.3.0 → 0.10.0.0
raw patch · 15 files changed
+395/−609 lines, 15 filesdep +ghc-pathsdep ~basedep ~ghcdep ~ghc-exactprint
Dependencies added: ghc-paths
Dependency ranges changed: base, ghc, ghc-exactprint
Files
- CHANGELOG +3/−0
- README.md +2/−0
- apply-refact.cabal +8/−6
- src/Refact/Apply.hs +4/−5
- src/Refact/Compat.hs +29/−39
- src/Refact/Fixity.hs +39/−64
- src/Refact/Internal.hs +226/−307
- src/Refact/Run.hs +5/−5
- src/Refact/Utils.hs +71/−182
- tests/Test.hs +5/−1
- tests/examples/Bracket47.hs +1/−0
- tests/examples/Bracket47.hs.expected +1/−0
- tests/examples/Bracket47.hs.refact +1/−0
- tests/examples/Pragma4.hs.expected +0/−0
- tests/examples/Pragma7.hs.expected +0/−0
CHANGELOG view
@@ -1,3 +1,6 @@+v0.10.0.0+ * support GHC 9.2; drop support for GHC <= 9.0 (@alanz)+ v0.9.3.0 * #113, Fix Annotation when context parens are removed
README.md view
@@ -2,6 +2,8 @@ [`refact`](https://hackage.haskell.org/package/refact) package. It is currently integrated into [HLint](https://github.com/ndmitchell/hlint) to enable the automatic application of suggestions. +apply-refact 0.10.x supports GHC 9.2, and 0.9.x supports GHC 8.6 through 9.0.+ # Install ```shell
apply-refact.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: apply-refact-version: 0.9.3.0+version: 0.10.0.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: BSD-3-Clause@@ -18,7 +18,7 @@ , tests/examples/*.hs , tests/examples/*.hs.refact , tests/examples/*.hs.expected-tested-with: GHC == 9.0.1, GHC == 8.10.4, GHC == 8.8.4, GHC == 8.6.5+tested-with: GHC == 9.2.1 source-repository head@@ -32,11 +32,12 @@ , Refact.Internal , Refact.Compat GHC-Options: -Wall- build-depends: base >=4.12 && < 5+ build-depends: base >=4.16 && < 5 , refact >= 0.2- , ghc-exactprint >= 0.6.4- , ghc >= 8.6+ , ghc-exactprint >= 1.5.0+ , ghc >= 9.2 , ghc-boot-th+ , ghc-paths , containers >= 0.6.0.1 && < 0.7 , extra >= 1.7.3 , syb >= 0.7.1@@ -46,7 +47,6 @@ , uniplate >= 1.6.13 , unix-compat >= 0.5.2 , directory >= 1.3- , uniplate >= 1.6.13 default-extensions: FlexibleContexts , FlexibleInstances , FunctionalDependencies@@ -84,6 +84,7 @@ , ghc-exactprint , ghc , ghc-boot-th+ , ghc-paths , containers , extra , syb@@ -132,6 +133,7 @@ , ghc-exactprint , ghc , ghc-boot-th+ , ghc-paths , containers , extra , syb
src/Refact/Apply.hs view
@@ -8,7 +8,6 @@ import Control.Monad (unless) import Data.List (intercalate)-import Language.Haskell.GHC.ExactPrint.Types (Anns) import Refact.Compat (Module) import Refact.Fixity (applyFixities) import Refact.Internal@@ -39,10 +38,10 @@ applyRefactorings optionsPos inp file exts = do let (enabled, disabled, invalid) = parseExtensions exts unless (null invalid) . fail $ "Unsupported extensions: " ++ intercalate ", " invalid- (as, m) <-- either (onError "apply") (uncurry applyFixities)+ m <-+ either (onError "apply") applyFixities =<< parseModuleWithArgs (enabled, disabled) file- apply optionsPos False ((mempty,) <$> inp) (Just file) Silent as m+ apply optionsPos False ((mempty,) <$> inp) (Just file) Silent m -- | Like 'applyRefactorings', but takes a parsed module rather than a file path to parse. applyRefactorings' ::@@ -50,7 +49,7 @@ [[Refactoring SrcSpan]] -> -- | ghc-exactprint AST annotations. This can be obtained from -- 'Language.Haskell.GHC.ExactPrint.Parsers.postParseTransform'.- Anns ->+ -- Anns -> -- | Parsed module Module -> IO String
src/Refact/Compat.hs view
@@ -5,9 +5,10 @@ module Refact.Compat ( -- * ApiAnnotation / GHC.Parser.ApiAnnotation AnnKeywordId (..),+ DeltaPos(..), -- * BasicTypes / GHC.Types.Basic- Fixity (..),+ Fixity(..), SourceText (..), -- * DynFlags / GHC.Driver.Session@@ -24,7 +25,6 @@ Errors, ErrorMessages, onError,- pprErrMsgBagWithLoc, -- * FastString / GHC.Data.FastString FastString,@@ -82,7 +82,7 @@ impliedXFlags, -- * Non-GHC stuff- AnnKeyMap,+ -- AnnKeyMap, FunBind, DoGenReplacement, Module,@@ -96,24 +96,26 @@ setRealSrcSpanFile, setSrcSpanFile, srcSpanToAnnSpan,+ AnnSpan, ) where #if __GLASGOW_HASKELL__ >= 900-import GHC.Data.Bag (unitBag)+import GHC.Data.Bag (unitBag, bagToList ) import GHC.Data.FastString (FastString, mkFastString) import GHC.Data.StringBuffer (stringToStringBuffer) import GHC.Driver.Session hiding (initDynFlags) import GHC.Parser.Annotation import GHC.Parser.Header (getOptions)-import GHC.Types.Basic (Fixity (..), SourceText (..))+import GHC.Types.Fixity ( Fixity(..) )+import GHC.Utils.Error hiding (mkErr) import GHC.Types.Name (nameOccName, occName, occNameString) import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) import GHC.Types.SrcLoc hiding (spans)-import GHC.Utils.Error+import GHC.Types.SourceText+import GHC.Utils.Panic (pprPanic) import GHC.Utils.Outputable ( ppr, showSDocUnsafe,- pprPanic, text, vcat, )@@ -158,21 +160,11 @@ import HsSyn hiding (Pat, Stmt) #endif -import Control.Monad.Trans.State ( StateT )-import Data.Data ( Data )-import Data.Map.Strict (Map)+import Control.Monad.Trans.State.Strict (StateT)+import Data.Data (Data) import qualified GHC-import Language.Haskell.GHC.ExactPrint.Annotate (Annotate)-import Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns ) import Language.Haskell.GHC.ExactPrint.Parsers (Parser)-import Language.Haskell.GHC.ExactPrint.Types- ( Anns,- AnnKey (..),- AnnSpan,-#if __GLASGOW_HASKELL__ >= 900- badRealSrcSpan,-#endif- )+import Language.Haskell.GHC.ExactPrint.Utils import Refact.Types (Refactoring) #if __GLASGOW_HASKELL__ <= 806@@ -181,8 +173,6 @@ type MonadFail' = MonadFail #endif -type AnnKeyMap = Map AnnKey [AnnKey]- #if __GLASGOW_HASKELL__ >= 900 type Module = Located HsModule #else@@ -192,7 +182,9 @@ #if __GLASGOW_HASKELL__ >= 810 type Errors = ErrorMessages onError :: String -> Errors -> a-onError s = pprPanic s . vcat . pprErrMsgBagWithLoc+onError s = pprPanic s . vcat . ppp+ppp :: Errors -> [SDoc]+ppp pst = concatMap unDecorated $ fmap errMsgDiagnostic $ bagToList pst #else type Errors = (SrcSpan, String) onError :: String -> Errors -> a@@ -235,6 +227,7 @@ type SrcSpanLess a = a #endif +type AnnSpan = RealSrcSpan badAnnSpan :: AnnSpan badAnnSpan = #if __GLASGOW_HASKELL__ >= 900@@ -286,29 +279,28 @@ mkErr :: DynFlags -> SrcSpan -> String -> Errors #if __GLASGOW_HASKELL__ >= 810-mkErr df l s = unitBag (mkPlainErrMsg df l (text s))+mkErr _df l s = unitBag (mkPlainMsgEnvelope l (text s)) #else mkErr = const (,) #endif -parseModuleName :: SrcSpan -> Parser (Located GHC.ModuleName)+parseModuleName :: SrcSpan -> Parser (LocatedA GHC.ModuleName) parseModuleName ss _ _ s =- let newMN = GHC.L ss (GHC.mkModuleName s)+ let newMN = GHC.L (GHC.noAnnSrcSpan ss) (GHC.mkModuleName s) #if __GLASGOW_HASKELL__ >= 900- newAnns = relativiseApiAnns newMN (GHC.ApiAnns mempty Nothing mempty mempty) #else newAnns = relativiseApiAnns newMN mempty #endif- in pure (newAnns, newMN)+ in pure newMN #if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900-type DoGenReplacement ast a =+type DoGenReplacement an ast a = (Data ast, Data a) => a ->- (Located ast -> Bool) ->- Located ast ->- Located ast ->- StateT ((Anns, AnnKeyMap), Bool) IO (Located ast)+ (LocatedAn an ast -> Bool) ->+ LocatedAn an ast ->+ LocatedAn an ast ->+ StateT Bool IO (LocatedAn an ast) #else type DoGenReplacement ast a = (Data (SrcSpanLess ast), HasSrcSpan ast, Data a) =>@@ -321,17 +313,15 @@ #if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 type ReplaceWorker a mod =- (Annotate a, Data mod) =>- Anns ->+ (Data a, Data mod) => mod ->- AnnKeyMap ->- Parser (Located a) ->+ Parser (GHC.LocatedA a) -> Int -> Refactoring SrcSpan ->- IO (Anns, mod, AnnKeyMap)+ IO mod #else type ReplaceWorker a mod =- (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>+ (Data a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) => Anns -> mod -> AnnKeyMap ->
src/Refact/Fixity.hs view
@@ -4,116 +4,91 @@ import Control.Monad.Trans.State import Data.Generics hiding (Fixity)-import Data.List-import qualified Data.Map as Map import Data.Maybe-import Data.Tuple import qualified GHC-import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcRn, GhcTc)+import Language.Haskell.GHC.ExactPrint import Refact.Compat (Fixity (..), SourceText (..), occNameString, rdrNameOcc) import Refact.Utils -- | Rearrange infix expressions to account for fixity. -- The set of fixities is wired in and includes all fixities in base.-applyFixities :: Anns -> Module -> IO (Anns, Module)-applyFixities as m = swap <$> runStateT (everywhereM (mkM expFix) m) as+applyFixities :: Module -> IO Module+applyFixities m = fst <$> runStateT (everywhereM (mkM expFix) m) ()+ -- Note: everywhereM is a bottom-up transformation -expFix :: Expr -> StateT Anns IO Expr-expFix (GHC.L loc (GHC.OpApp _ l op r)) =- mkOpAppRn baseFixities loc l op (findFixity baseFixities op) r+expFix :: Expr -> StateT () IO Expr+expFix (GHC.L loc (GHC.OpApp an l op r)) =+ mkOpAppRn baseFixities loc an l op (findFixity baseFixities op) r expFix e = return e getIdent :: Expr -> String getIdent (GHC.unLoc -> GHC.HsVar _ (GHC.L _ n)) = occNameString . rdrNameOcc $ n getIdent _ = error "Must be HsVar" --- | Move the delta position from one annotation to another:------ * When rewriting '(e11 `op1` e12) `op2` e2' into 'e11 `op1` (e12 `op2` e2)', move the delta position--- from 'e12' to '(e12 `op2` e2)'.--- * When rewriting '(- neg_arg) `op` e2' into '- (neg_arg `op` e2)', move the delta position--- from 'neg_arg' to '(neg_arg `op` e2)'.-moveDelta :: Annotation -> AnnKey -> AnnKey -> StateT Anns IO ()-moveDelta oldAnn oldKey newKey = do- -- If the old annotation has a unary minus operator, add it to the new annotation.- let newAnnsDP- | Just dp <- find ((== G GHC.AnnMinus) . fst) (annsDP oldAnn) = [dp]- | otherwise = []- modify . Map.insert newKey $- annNone- { annEntryDelta = annEntryDelta oldAnn,- annPriorComments = annPriorComments oldAnn,- annsDP = newAnnsDP- }-- -- If the old key is still there, reset the value.- modify $ Map.adjust (\a -> a {annEntryDelta = DP (0, 0), annPriorComments = []}) oldKey- --------------------------- -- Modified from GHC Renamer mkOpAppRn :: [(String, GHC.Fixity)] ->- GHC.SrcSpan ->- Expr -> -- Left operand; already rearrange+ GHC.SrcSpanAnnA ->+ GHC.EpAnn [GHC.AddEpAnn] ->+ Expr -> -- Left operand; already rearranged Expr -> GHC.Fixity -> -- Operator and fixity Expr -> -- Right operand (not an OpApp, but might -- be a NegApp)- StateT Anns IO Expr+ StateT () IO Expr -- (e11 `op1` e12) `op2` e2-mkOpAppRn fs loc e1@(GHC.L _ (GHC.OpApp x1 e11 op1 e12)) op2 fix2 e2+mkOpAppRn fs loc an e1@(GHC.L _ (GHC.OpApp x1 e11 op1 e12)) op2 fix2 e2 | nofix_error =- return $ GHC.L loc (GHC.OpApp noExt e1 op2 e2)+ return $ GHC.L loc (GHC.OpApp an e1 op2 e2) | associate_right = do- let oldKey = mkAnnKey e12- oldAnn <- gets $ Map.findWithDefault annNone oldKey- new_e <- mkOpAppRn fs loc' e12 op2 fix2 e2- let newKey = mkAnnKey new_e- moveDelta oldAnn oldKey newKey- return $ GHC.L loc (GHC.OpApp x1 e11 op1 new_e)+ -- liftIO $ putStrLn $ "mkOpAppRn:1:e1" ++ showAst e1+ let e12' = setEntryDP e12 (GHC.SameLine 0)+ new_e <- mkOpAppRn fs loc' an e12' op2 fix2 e2+ let (new_e',_,_) = runTransform $ transferEntryDP e12 new_e+ let res = GHC.L loc (GHC.OpApp x1 e11 op1 new_e')+ -- liftIO $ putStrLn $ "mkOpAppRn:1:res" ++ showAst res+ return res where- loc' = GHC.combineLocs e12 e2+ loc' = GHC.combineLocsA e12 e2 fix1 = findFixity fs op1 (nofix_error, associate_right) = GHC.compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2-mkOpAppRn fs loc e1@(GHC.L _ (GHC.NegApp _ neg_arg neg_name)) op2 fix2 e2+mkOpAppRn fs loc an e1@(GHC.L _ (GHC.NegApp an' neg_arg neg_name)) op2 fix2 e2 | nofix_error =- return (GHC.L loc (GHC.OpApp noExt e1 op2 e2))+ return (GHC.L loc (GHC.OpApp an e1 op2 e2)) | associate_right = do- let oldKey = mkAnnKey neg_arg- oldAnn <- gets $ Map.findWithDefault annNone oldKey- new_e <- mkOpAppRn fs loc' neg_arg op2 fix2 e2- let newKey = mkAnnKey new_e- moveDelta oldAnn oldKey newKey- let res = GHC.L loc (GHC.NegApp noExt new_e neg_name)- key = mkAnnKey res- ak = AnnKey (srcSpanToAnnSpan loc) (CN "OpApp")- opAnn <- gets (fromMaybe annNone . Map.lookup ak)- negAnns <- gets (fromMaybe annNone . Map.lookup (mkAnnKey e1))- modify $ Map.insert key (annNone {annEntryDelta = annEntryDelta opAnn, annsDP = annsDP negAnns})- modify $ Map.delete (mkAnnKey e1)+ -- liftIO $ putStrLn $ "mkOpAppRn:2:e1" ++ showAst e1+ new_e <- mkOpAppRn fs loc' an neg_arg op2 fix2 e2+ let new_e' = setEntryDP new_e (GHC.SameLine 0)+ let res = setEntryDP (GHC.L loc (GHC.NegApp an' new_e' neg_name)) (GHC.SameLine 0)+ -- liftIO $ putStrLn $ "mkOpAppRn:2:res" ++ showAst res return res where- loc' = GHC.combineLocs neg_arg e2+ loc' = GHC.combineLocsA neg_arg e2 (nofix_error, associate_right) = GHC.compareFixity GHC.negateFixity fix2 --------------------------- -- e1 `op` - neg_arg-mkOpAppRn _ loc e1 op1 fix1 e2@(GHC.L _ GHC.NegApp {}) -- NegApp can occur on the right+mkOpAppRn _ loc an e1 op1 fix1 e2@(GHC.L _ GHC.NegApp {}) -- NegApp can occur on the right | not associate_right -- We *want* right association- =- return $ GHC.L loc (GHC.OpApp noExt e1 op1 e2)+ = do+ -- liftIO $ putStrLn $ "mkOpAppRn:3:e1" ++ showAst (GHC.L loc (GHC.OpApp an e1 op1 e2))+ return $ GHC.L loc (GHC.OpApp an e1 op1 e2) where (_, associate_right) = GHC.compareFixity fix1 GHC.negateFixity --------------------------- -- Default case-mkOpAppRn _ loc e1 op _fix e2 -- Default case, no rearrangment- =- return $ GHC.L loc (GHC.OpApp noExt e1 op e2)+mkOpAppRn _ loc an e1 op _fix e2 -- Default case, no rearrangment+ = do+ -- liftIO $ putStrLn $ "mkOpAppRn:4:e1" ++ showAst (GHC.L loc (GHC.OpApp an e1 op e2))+ return $ GHC.L loc (GHC.OpApp an e1 op e2)++-- --------------------------------------------------------------------- findFixity :: [(String, GHC.Fixity)] -> Expr -> GHC.Fixity findFixity fs r = askFix fs (getIdent r)
src/Refact/Internal.hs view
@@ -12,7 +12,6 @@ -- * Support for runPipe in the main process Verbosity (..),- rigidLayout, refactOptions, type Errors, onError,@@ -24,43 +23,38 @@ 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 Control.Monad.Trans.State.Strict import Data.Data import Data.Foldable (foldlM, for_) import Data.Functor.Identity (Identity (..))-import Data.Generics (everywhereM, extM, listify, mkM, mkQ, something)-import Data.Generics.Uniplate.Data (transformBi, transformBiM, universeBi)+import Data.Generics (everywhere, everywhereM, extM, listify, mkM, mkQ, mkT, something)+import Data.Generics.Uniplate.Data (transformBi, transformBiM) import Data.IORef.Extra import Data.List.Extra-import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Ord (comparing)-import Data.Set (Set) import qualified Data.Set as Set import Data.Tuple.Extra import Debug.Trace import qualified GHC import GHC.IO.Exception (IOErrorType (..)) import GHC.LanguageExtensions.Type (Extension (..))+import qualified GHC.Paths import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Delta+import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers-import Language.Haskell.GHC.ExactPrint.Print-import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcRn, GhcTc)-import Language.Haskell.GHC.ExactPrint.Utils hiding (rs)+import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils import Refact.Compat- ( DoGenReplacement,+ ( AnnSpan,+ DoGenReplacement, Errors, FlagSpec (..), FunBind, Module,- RdrName (..), ReplaceWorker,- SrcSpanLess,- annSpanToSrcSpan,- badAnnSpan,- combineSrcSpans,+ -- combineSrcSpans,+ combineSrcSpansA, composeSrcSpan, decomposeSrcSpan, getOptions,@@ -68,7 +62,6 @@ handleGhcException, impliedXFlags, mkErr,- nameOccName, occName, occNameString, onError,@@ -76,7 +69,6 @@ parseModuleName, ppr, rdrNameOcc,- setAnnSpanFile, setSrcSpanFile, showSDocUnsafe, srcSpanToAnnSpan,@@ -90,8 +82,7 @@ import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R import Refact.Utils- ( AnnKeyMap,- Decl,+ ( Decl, Expr, Import, M,@@ -99,10 +90,9 @@ Pat, Stmt, Type,- foldAnnKey,- getAnnSpan,+ -- foldAnnKey,+ getAnnSpanA, modifyAnnKey,- replaceAnnKey, toGhcSrcSpan, toGhcSrcSpan', )@@ -110,12 +100,9 @@ import System.IO.Extra import System.IO.Unsafe (unsafePerformIO) -refactOptions :: PrintOptions Identity String+refactOptions :: EPOptions Identity String refactOptions = stringOptions {epRigidity = RigidLayout} -rigidLayout :: DeltaOptions-rigidLayout = deltaOptions RigidLayout- -- | Apply a set of refactorings as supplied by hlint apply :: Maybe (Int, Int) ->@@ -123,10 +110,10 @@ [(String, [Refactoring R.SrcSpan])] -> Maybe FilePath -> Verbosity ->- Anns ->+ -- Anns -> Module -> IO String-apply mpos step inp mbfile verb as0 m0 = do+apply mpos step inp mbfile verb m0 = do toGhcSS <- maybe ( case GHC.getLoc m0 of@@ -155,12 +142,14 @@ "Applying " ++ (show . sum . map (length . snd . fst) $ allRefacts) ++ " hints" when (verb == Loud) . traceM $ show (map fst allRefacts) - (as, m) <-+ m <- if step- then fromMaybe (as0, m0) <$> runMaybeT (refactoringLoop as0 m0 allRefacts)- else evalStateT (runRefactorings verb as0 m0 (first snd <$> allRefacts)) 0- pure . runIdentity $ exactPrintWithOptions refactOptions m as+ then fromMaybe m0 <$> runMaybeT (refactoringLoop m0 allRefacts)+ else evalStateT (runRefactorings verb m0 (first snd <$> allRefacts)) 0 + -- liftIO $ putStrLn $ "apply:final AST\n" ++ showAst m+ pure . snd . runIdentity $ exactPrintWithOptions refactOptions m+ spans :: R.SrcSpan -> (Int, Int) -> Bool spans R.SrcSpan {..} loc = (startLine, startCol) <= loc && loc <= (endLine, endCol) @@ -182,36 +171,34 @@ runRefactorings :: Verbosity ->- Anns -> Module -> [([Refactoring GHC.SrcSpan], R.SrcSpan)] ->- StateT Int IO (Anns, Module)-runRefactorings verb as0 m0 ((rs, ss) : rest) = do- runRefactorings' verb as0 m0 rs >>= \case- Nothing -> runRefactorings verb as0 m0 rest- Just (as, m) -> do+ StateT Int IO Module+runRefactorings verb m0 ((rs, ss) : rest) = do+ runRefactorings' verb m0 rs >>= \case+ Nothing -> runRefactorings verb m0 rest+ Just m -> do let (overlaps, rest') = span (overlap ss . snd) rest when (verb >= Normal) . for_ overlaps $ \(rs', _) -> traceM $ "Ignoring " ++ show rs' ++ " due to overlap."- runRefactorings verb as m rest'-runRefactorings _ as m [] = pure (as, m)+ runRefactorings verb m rest'+runRefactorings _ m [] = pure m runRefactorings' :: Verbosity ->- Anns -> Module -> [Refactoring GHC.SrcSpan] ->- StateT Int IO (Maybe (Anns, Module))-runRefactorings' verb as0 m0 rs = do+ StateT Int IO (Maybe Module)+runRefactorings' verb m0 rs = do seed <- get- (as, m, keyMap) <- foldlM (uncurry3 runRefactoring) (as0, m0, Map.empty) rs- if droppedComments as m keyMap+ m <- foldlM runRefactoring m0 rs+ if droppedComments rs m0 m then do put seed when (verb >= Normal) . traceM $ "Ignoring " ++ show rs ++ " since applying them would cause comments to be dropped." pure Nothing- else pure $ Just (as, m)+ else pure $ Just m overlap :: R.SrcSpan -> R.SrcSpan -> Bool overlap s1 s2 =@@ -223,42 +210,44 @@ data LoopOption = LoopOption { desc :: String,- perform :: MaybeT IO (Anns, Module)+ -- perform :: MaybeT IO (Anns, Module)+ perform :: MaybeT IO Module } refactoringLoop ::- Anns -> Module -> [((String, [Refactoring GHC.SrcSpan]), R.SrcSpan)] ->- MaybeT IO (Anns, Module)-refactoringLoop as m [] = pure (as, m)-refactoringLoop as m (((_, []), _) : rs) = refactoringLoop as m rs-refactoringLoop as0 m0 hints@(((hintDesc, rs), ss) : rss) = do- res <- liftIO . flip evalStateT 0 $ runRefactorings' Silent as0 m0 rs- let yAction = case res of- Just (as, m) -> do- exactPrint m as `seq` pure ()- refactoringLoop as m $ dropWhile (overlap ss . snd) rss+ MaybeT IO Module+refactoringLoop m [] = pure m+refactoringLoop m (((_, []), _) : rs) = refactoringLoop m rs+refactoringLoop m0 hints@(((hintDesc, rs), ss) : rss) = do+ res <- liftIO . flip evalStateT 0 $ runRefactorings' Silent m0 rs+ let yAction :: MaybeT IO Module+ yAction = case res of+ Just m -> do+ exactPrint m `seq` pure ()+ refactoringLoop m $ dropWhile (overlap ss . snd) rss Nothing -> do liftIO $ putStrLn "Hint skipped since applying it would cause comments to be dropped"- refactoringLoop as0 m0 rss+ refactoringLoop m0 rss+ opts :: [(String, LoopOption)] opts = [ ("y", LoopOption "Apply current hint" yAction),- ("n", LoopOption "Don't apply the current hint" (refactoringLoop as0 m0 rss)),- ("q", LoopOption "Apply no further hints" (pure (as0, m0))),+ ("n", LoopOption "Don't apply the current hint" (refactoringLoop m0 rss)),+ ("q", LoopOption "Apply no further hints" (pure m0)), ("d", LoopOption "Discard previous changes" mzero), ( "v", LoopOption "View current file"- ( liftIO (putStrLn (exactPrint m0 as0))- >> refactoringLoop as0 m0 hints+ ( liftIO (putStrLn (exactPrint m0))+ >> refactoringLoop m0 hints ) ), ("?", LoopOption "Show this help menu" loopHelp) ] loopHelp = do liftIO . putStrLn . unlines . map mkLine $ opts- refactoringLoop as0 m0 hints+ refactoringLoop m0 hints mkLine (c, opt) = c ++ " - " ++ desc opt inp <- liftIO $ do putStrLn hintDesc@@ -276,84 +265,106 @@ -- | Peform a @Refactoring@. runRefactoring :: Data a =>- Anns -> a ->- AnnKeyMap -> Refactoring GHC.SrcSpan ->- StateT Int IO (Anns, a, AnnKeyMap)-runRefactoring as m keyMap = \case+ StateT Int IO a+runRefactoring m = \case r@Replace {} -> do seed <- get <* modify (+ 1) liftIO $ case rtype r of- Expr -> replaceWorker as m keyMap parseExpr seed r- Decl -> replaceWorker as m keyMap parseDecl seed r- Type -> replaceWorker as m keyMap parseType seed r- Pattern -> replaceWorker as m keyMap parsePattern seed r- Stmt -> replaceWorker as m keyMap parseStmt seed r- Bind -> replaceWorker as m keyMap parseBind seed r- R.Match -> replaceWorker as m keyMap parseMatch seed r- ModuleName -> replaceWorker as m keyMap (parseModuleName (pos r)) seed r- Import -> replaceWorker as m keyMap parseImport seed r- ModifyComment {..} -> pure (Map.map go as, m, keyMap)- 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 (annSpanToSrcSpan commentIdentifier) == ss2pos pos- then old {commentContents = newComment}- else old- Delete {rtype, pos} -> pure (as, f m, keyMap)+ Expr -> replaceWorker m parseExpr seed r+ Decl -> replaceWorker m parseDecl seed r+ Type -> replaceWorker m parseType seed r+ Pattern -> replaceWorker m parsePattern seed r+ Stmt -> replaceWorker m parseStmt seed r+ Bind -> replaceWorker m parseBind seed r+ R.Match -> replaceWorker m parseMatch seed r+ ModuleName -> replaceWorker m (parseModuleName (pos r)) seed r+ Import -> replaceWorker m parseImport seed r+ ModifyComment {..} -> pure (modifyComment pos newComment m)+ Delete {rtype, pos} -> pure (f m) where annSpan = srcSpanToAnnSpan pos f = case rtype of- Stmt -> doDeleteStmt ((/= annSpan) . getAnnSpan)- Import -> doDeleteImport ((/= annSpan) . getAnnSpan)+ Stmt -> doDeleteStmt ((/= annSpan) . getAnnSpanA)+ Import -> doDeleteImport ((/= annSpan) . getAnnSpanA) _ -> id- InsertComment {..} -> do- exprkey <- mkAnnKey <$> findOrError @(GHC.HsDecl GHC.GhcPs) m (srcSpanToAnnSpan pos)- pure (insertComment exprkey newComment as, m, keyMap)- RemoveAsKeyword {..} -> pure (as, removeAsKeyword m, keyMap)+ InsertComment {..} -> pure (addComment m) where+ addComment = transformBi go+ r = srcSpanToAnnSpan pos+ go :: GHC.LHsDecl GHC.GhcPs -> GHC.LHsDecl GHC.GhcPs+ go old@(GHC.L l d) =+ if ss2pos (srcSpanToAnnSpan $ GHC.locA l) == ss2pos r+ then+ let dp = case getEntryDP old of+ GHC.SameLine 0 -> GHC.DifferentLine 1 0+ dp' -> dp'+ (GHC.L l' d') = setEntryDP (GHC.L l d) (GHC.DifferentLine 1 0)+ comment =+ GHC.L+ (GHC.Anchor r (GHC.MovedAnchor dp))+ (GHC.EpaComment (GHC.EpaLineComment newComment) r)+ l'' = GHC.addCommentsToSrcAnn l' (GHC.EpaComments [comment])+ in GHC.L l'' d'+ else old+ RemoveAsKeyword {..} -> pure (removeAsKeyword m)+ where removeAsKeyword = transformBi go go :: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs go imp@(GHC.L l i)- | srcSpanToAnnSpan l == srcSpanToAnnSpan pos = GHC.L l (i {GHC.ideclAs = Nothing})+ | srcSpanToAnnSpan (GHC.locA l) == srcSpanToAnnSpan pos = GHC.L l (i {GHC.ideclAs = Nothing}) | otherwise = imp -droppedComments :: Anns -> Module -> AnnKeyMap -> Bool-droppedComments as m keyMap = any (all (`Set.notMember` allSpans)) spanssWithComments+modifyComment :: (Data a) => GHC.SrcSpan -> String -> a -> a+modifyComment pos newComment = transformBi go where- spanssWithComments =- map (\(key, _) -> map keySpan $ key : Map.findWithDefault [] key keyMap)- . filter (\(_, v) -> notNull (annPriorComments v) || notNull (annFollowingComments v))- $ Map.toList as+ newTok :: GHC.EpaCommentTok -> GHC.EpaCommentTok+ newTok (GHC.EpaDocCommentNext _) = GHC.EpaDocCommentNext newComment+ newTok (GHC.EpaDocCommentPrev _) = GHC.EpaDocCommentPrev newComment+ newTok (GHC.EpaDocCommentNamed _) = GHC.EpaDocCommentNamed newComment+ newTok (GHC.EpaDocSection i _) = GHC.EpaDocSection i newComment+ newTok (GHC.EpaDocOptions _) = GHC.EpaDocOptions newComment+ newTok (GHC.EpaLineComment _) = GHC.EpaLineComment newComment+ newTok (GHC.EpaBlockComment _) = GHC.EpaBlockComment newComment+ newTok GHC.EpaEofComment = GHC.EpaEofComment - keySpan (AnnKey ss _) = ss+ go :: GHC.LEpaComment -> GHC.LEpaComment+ go old@(GHC.L (GHC.Anchor l o) (GHC.EpaComment t r)) =+ if ss2pos l == ss2pos (GHC.realSrcSpan pos)+ then GHC.L (GHC.Anchor l o) (GHC.EpaComment (newTok t) r)+ else old - allSpans :: Set AnnSpan- allSpans = Set.fromList . fmap srcSpanToAnnSpan $ universeBi m+droppedComments :: [Refactoring GHC.SrcSpan] -> Module -> Module -> Bool+droppedComments rs orig_m m = not (all (`Set.member` current_comments) orig_comments)+ where+ mcs = foldl' runModifyComment orig_m rs+ runModifyComment m' (ModifyComment pos newComment) = modifyComment pos newComment m'+ runModifyComment m' _ = m' + all_comments :: forall r. (Data r, Typeable r) => r -> [GHC.EpaComment]+ all_comments = listify (False `mkQ` isComment)+ isComment :: GHC.EpaComment -> Bool+ isComment _ = True+ orig_comments = all_comments mcs+ current_comments = Set.fromList $ all_comments m+ 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")+ Right (GHC.L l (GHC.ValD _ b)) -> Right (GHC.L l b)+ Right (GHC.L l _) -> Left (mkErr dyn (GHC.locA 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}) ->+ Right (GHC.L l GHC.FunBind {fun_matches}) -> case GHC.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")+ [x] -> Right x+ _ -> Left (mkErr dyn (GHC.locA l) "Not a single match")+ Right (GHC.L l _) -> Left (mkErr dyn (GHC.locA l) "Not a funbind") Left e -> Left e -- Substitute variables into templates@@ -401,13 +412,11 @@ resolveRdrName' subst (findOrError m) old subs name where subst :: FunBind -> Name -> M FunBind- subst (GHC.FunRhs n b s) new = do- let fakeExpr :: Pat- fakeExpr = GHC.L (GHC.getLoc new) (GHC.VarPat noExt new)+ subst (GHC.FunRhs _ b s) new = do -- Low level version as we need to combine the annotation information -- from the template RdrName and the original VarPat.- modify . first $- replaceAnnKey (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr)+ -- modify . first $+ -- replaceAnnKey (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr) pure $ GHC.FunRhs new b s subst o _ = pure o identSub _ _ e = pure e@@ -415,8 +424,8 @@ -- 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- (AnnSpan -> M b) -> -- How to find the new value, when given the location it is in+ (a -> GHC.LocatedAn an b -> M a) -> -- How to combine the value to insert and the replaced value+ (AnnSpan -> M (GHC.LocatedAn an 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@@ -430,124 +439,57 @@ _ -> pure old resolveRdrName ::- (Data old, Data a) =>+ (Data old, Data a, Data an, Typeable an, Monoid an) => a ->- (AnnSpan -> M (GHC.Located old)) ->- GHC.Located old ->+ (AnnSpan -> M (GHC.LocatedAn an old)) ->+ GHC.LocatedAn an old -> [(String, GHC.SrcSpan)] -> GHC.RdrName ->- M (GHC.Located old)+ M (GHC.LocatedAn an 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 badAnnSpan 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.-doGenReplacement :: forall ast a. DoGenReplacement ast a+doGenReplacement :: forall ast a. DoGenReplacement GHC.AnnListItem ast a doGenReplacement m p new old | p old = do- (anns, keyMap) <- gets fst let n = decomposeSrcSpan new o = decomposeSrcSpan old- (newAnns, newKeyMap) <- liftIO $ execStateT (modifyAnnKey m o n) (anns, keyMap)- put ((newAnns, newKeyMap), True)- pure new+ let (new', _, _) = runTransform $ transferEntryDP old new+ put 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) @(GHC.HsDecl GHC.GhcPs),- GHC.L _ (GHC.ValD xvald newBind@GHC.FunBind {}) <- decomposeSrcSpan new,- Just (oldNoLocal, oldLocal) <- stripLocalBind (decomposeSrcSpan old),- newLoc@(RealSrcSpan' newLocReal) <- GHC.getLoc new,+ | Just Refl <- eqT @(GHC.LocatedA ast) @(GHC.LHsDecl GHC.GhcPs),+ GHC.L _ (GHC.ValD xvald newBind@GHC.FunBind {}) <- new,+ Just (oldNoLocal, oldLocal) <- stripLocalBind old,+ (RealSrcSpan' newLocReal) <- GHC.getLocA new, p (composeSrcSpan oldNoLocal) = do- (anns, keyMap) <- gets fst let n = decomposeSrcSpan new o = decomposeSrcSpan old- (intAnns, newKeyMap) <- liftIO $ execStateT (modifyAnnKey m o n) (anns, keyMap) let newFile = GHC.srcSpanFile newLocReal+ newLocal :: GHC.HsLocalBinds GHC.GhcPs newLocal = transformBi (setSrcSpanFile newFile) oldLocal- newLocalLoc = GHC.getLoc newLocal- ensureLoc = combineSrcSpans newLocalLoc+ -- newLocalLoc = GHC.getLocA newLocal+ newLocalLoc = GHC.spanHsLocaLBinds newLocal newMG = GHC.fun_matches newBind GHC.L locMG [GHC.L locMatch newMatch] = GHC.mg_alts newMG newGRHSs = GHC.m_grhss newMatch- finalLoc = ensureLoc newLoc- newWithLocalBinds =+ finalLoc = combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) (GHC.getLoc new)+ newWithLocalBinds0 = setLocalBind newLocal xvald newBind finalLoc newMG- (ensureLoc locMG)+ (combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) locMG) newMatch- (ensureLoc locMatch)+ (combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) 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 = foldAnnKey (const False) $ \r con ->- srcSpanToAnnSpan (RealSrcSpan' r) == srcSpanToAnnSpan (GHC.getLoc old)- && con == CN "Match"- && GHC.srcSpanFile r /= newFile- pn = foldAnnKey (const False) $ \r con ->- srcSpanToAnnSpan (RealSrcSpan' r) == srcSpanToAnnSpan finalLoc- && con == CN "Match"- && GHC.srcSpanFile r == newFile- in fromMaybe oldAnns $ do- oldAnn <- snd <$> find (po . fst) oldAnns'- annWhere <- find ((== G GHC.AnnWhere) . fst) (annsDP oldAnn)- let newSortKey = fmap (setAnnSpanFile newFile) <$> annSortKey oldAnn- newKey <- fst <$> find (pn . fst) oldAnns'- pure $- Map.adjust- (\ann -> ann {annsDP = annsDP ann ++ [annWhere], annSortKey = newSortKey})- newKey- oldAnns-- -- Expand the SrcSpan of the "GRHS" entry in the new file to include the local binds- expandGRHSLoc = foldAnnKey id $ \r con ->- if con == CN "GRHS" && GHC.srcSpanFile r == newFile- then AnnKey (srcSpanToAnnSpan $ ensureLoc $ RealSrcSpan' r) con- else AnnKey (srcSpanToAnnSpan $ RealSrcSpan' r) con-- -- If an Anns entry corresponds to the local binds, update its file to point to the new file.- updateFile = \case- AnnKey loc con- | annSpanToSrcSpan loc `GHC.isSubspanOf` GHC.getLoc oldLocal ->- AnnKey (setAnnSpanFile 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 == srcSpanToAnnSpan newLoc -> AnnKey (srcSpanToAnnSpan finalLoc) con- other -> other+ (newWithLocalBinds, _, _) = runTransform $ transferEntryDP' old newWithLocalBinds0 - newAnns = addLocalBindsToAnns intAnns- put ((newAnns, newKeyMap), True)+ put True pure $ composeSrcSpan newWithLocalBinds | otherwise = pure old @@ -555,7 +497,7 @@ -- return "Just (foo a = body, x = y)". Otherwise return Nothing. stripLocalBind :: Decl ->- Maybe (Decl, GHC.LHsLocalBinds GHC.GhcPs)+ Maybe (Decl, GHC.HsLocalBinds GHC.GhcPs) stripLocalBind = \case GHC.L _ (GHC.ValD xvald origBind@GHC.FunBind {}) | let origMG = GHC.fun_matches origBind,@@ -563,10 +505,10 @@ let origGRHSs = GHC.m_grhss origMatch, [GHC.L _ (GHC.GRHS _ _ (GHC.L loc2 _))] <- GHC.grhssGRHSs origGRHSs -> let loc1 = GHC.getLoc (GHC.fun_id origBind)- newLoc = combineSrcSpans loc1 loc2+ newLoc = combineSrcSpansA (GHC.l2l loc1) loc2 withoutLocalBinds = setLocalBind- (GHC.noLoc (GHC.EmptyLocalBinds noExt))+ (GHC.EmptyLocalBinds GHC.noExtField) xvald origBind newLoc@@ -580,14 +522,14 @@ -- | Set the local binds in a HsBind. setLocalBind ::- GHC.LHsLocalBinds GHC.GhcPs ->+ GHC.HsLocalBinds GHC.GhcPs -> GHC.XValD GHC.GhcPs -> GHC.HsBind GHC.GhcPs ->- GHC.SrcSpan ->+ GHC.SrcSpanAnnA -> GHC.MatchGroup GHC.GhcPs Expr ->- GHC.SrcSpan ->+ GHC.SrcSpanAnnL -> GHC.Match GHC.GhcPs Expr ->- GHC.SrcSpan ->+ GHC.SrcSpanAnnA -> GHC.GRHSs GHC.GhcPs Expr -> Decl setLocalBind newLocalBinds xvald origBind newLoc origMG locMG origMatch locMatch origGRHSs =@@ -598,87 +540,68 @@ newMG = origMG {GHC.mg_alts = GHC.L locMG [GHC.L locMatch newMatch]} newBind = origBind {GHC.fun_matches = newMG} -replaceWorker :: forall a mod. ReplaceWorker a mod-replaceWorker as m keyMap parser seed Replace {..} = do+replaceWorker :: forall a mod. (ExactPrint a) => ReplaceWorker a mod+replaceWorker m parser seed Replace {..} = do let replExprLocation = srcSpanToAnnSpan pos uniqueName = "template" ++ show seed+ let libdir = undefined - (relat, template) <- do- flags <- maybe (withDynFlags id) pure =<< readIORef dynFlagsRef+ template <- do+ flags <- maybe (withDynFlags libdir id) pure =<< readIORef dynFlagsRef either (onError "replaceWorker") pure $ parser flags uniqueName orig - (newExpr, (newAnns, newKeyMap)) <-+ (newExpr, ()) <- runStateT- (substTransform m subts template)- (mergeAnns as relat, keyMap)+ -- (substTransform m subts template)+ (substTransform m subts (makeDeltaAst template))+ -- (mergeAnns as relat, keyMap)+ () let lst = listToMaybe . reverse . occNameString . rdrNameOcc adjacent (GHC.srcSpanEnd -> RealSrcLoc' loc1) (GHC.srcSpanStart -> RealSrcLoc' loc2) = loc1 == loc2 adjacent _ _ = False - -- Return @True@ if the start position of the two spans are on the same line, and differ- -- by the given number of columns.- diffStartCols :: Int -> GHC.SrcSpan -> GHC.SrcSpan -> Bool- diffStartCols x (GHC.srcSpanStart -> RealSrcLoc' loc1) (GHC.srcSpanStart -> RealSrcLoc' loc2) =- GHC.srcLocLine loc1 == GHC.srcLocLine loc2 && GHC.srcLocCol loc1 - GHC.srcLocCol loc2 == x- diffStartCols _ _ _ = False+ -- Add a space if needed, so that we avoid refactoring `y = do(foo bar)` into `y = dofoo bar`.+ -- ensureDoSpace :: Anns -> Anns+ ensureSpace :: forall t. (Data t) => t -> t+ ensureSpace = everywhere (mkT ensureExprSpace) - -- Add a space if needed, so that we avoid refactoring `y = f(x)` into `y = fx`.- ensureAppSpace :: Anns -> Anns- ensureAppSpace = fromMaybe id $ do- (GHC.L _ (GHC.HsVar _ (GHC.L _ newName))) :: Expr <- cast newExpr- hd <- listToMaybe $ case newName of- Unqual n -> occNameString n- Qual moduleName _ -> GHC.moduleNameString moduleName- Orig modu _ -> GHC.moduleNameString (GHC.moduleName modu)- Exact name -> occNameString (nameOccName name)- guard $ isAlphaNum hd- let prev :: [Expr] =- listify- ( \case- (GHC.L loc (GHC.HsVar _ (GHC.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+ ensureExprSpace :: Expr -> Expr+ ensureExprSpace e@(GHC.L l (GHC.HsDo an v (GHC.L ls stmts))) = e' -- ensureDoSpace+ where+ isDo = case v of+ GHC.ListComp -> False+ _ -> True+ e' =+ if isDo+ && manchorOp an == Just (GHC.MovedAnchor (GHC.SameLine 0))+ && manchorOp (GHC.ann ls) == Just (GHC.MovedAnchor (GHC.SameLine 0))+ then GHC.L l (GHC.HsDo an v (setEntryDP (GHC.L ls stmts) (GHC.SameLine 1)))+ else e+ ensureExprSpace e@(GHC.L l (GHC.HsApp x (GHC.L la a) (GHC.L lb b))) = e' -- ensureAppSpace+ where+ e' =+ if manchorOp (GHC.ann lb) == Just (GHC.MovedAnchor (GHC.SameLine 0))+ then GHC.L l (GHC.HsApp x (GHC.L la a) (setEntryDP (GHC.L lb b) (GHC.SameLine 1)))+ else e+ ensureExprSpace e = e - -- Add a space if needed, so that we avoid refactoring `y = do(foo bar)` into `y = dofoo bar`.- ensureDoSpace :: Anns -> Anns- ensureDoSpace = fromMaybe id $ do- let doBlocks :: [Expr] =- listify- ( \case- (GHC.L _ GHC.HsDo {}) -> True- _ -> False- )- m- doBlocks' :: [(GHC.SrcSpan, Int)]- doBlocks' =- map- ( \case- GHC.L loc (GHC.HsDo _ GHC.MDoExpr {} _) -> (loc, 3)- GHC.L loc _ -> (loc, 2)- )- doBlocks- _ <- find (\(ss, len) -> diffStartCols len pos ss) doBlocks'- pure . flip Map.adjust (mkAnnKey newExpr) $ \ann ->- if annEntryDelta ann == DP (0, 0)- then ann {annEntryDelta = DP (0, 1)}- else ann+ replacementPred = (== replExprLocation) . getAnnSpanA - replacementPred = (== replExprLocation) . getAnnSpan- transformation = transformBiM (doGenReplacement m (replacementPred . decomposeSrcSpan) newExpr)- runStateT (transformation m) ((newAnns, newKeyMap), False) >>= \case- (finalM, ((ensureDoSpace . ensureAppSpace -> finalAs, finalKeyMap), True)) ->- pure (finalAs, finalM, finalKeyMap)+ tt :: GHC.LocatedA a -> StateT Bool IO (GHC.LocatedA a)+ tt = doGenReplacement m replacementPred newExpr+ transformation :: mod -> StateT Bool IO mod+ transformation = transformBiM tt+ runStateT (transformation m) False >>= \case+ (finalM, True) ->+ pure (ensureSpace finalM) -- Failed to find a replacment so don't make any changes- _ -> pure (as, m, keyMap)-replaceWorker as m keyMap _ _ _ = pure (as, m, keyMap)+ _ -> pure m+replaceWorker m _ _ _ = pure m +manchorOp :: GHC.EpAnn ann -> Maybe GHC.AnchorOperation+manchorOp GHC.EpAnnNotUsed = Nothing+manchorOp (GHC.EpAnn a _ _) = Just (GHC.anchor_op a)+ data NotFound = NotFound { nfExpected :: String, nfActual :: Maybe String,@@ -696,7 +619,12 @@ ++ showSDocUnsafe (ppr nfLoc) -- Find a given type with a given SrcSpan-findInModule :: forall a modu. (Data a, Data modu) => modu -> AnnSpan -> Either NotFound (GHC.Located a)+findInModule ::+ forall an a modu.+ (Typeable an, Data a, Data modu) =>+ modu ->+ AnnSpan ->+ Either NotFound (GHC.LocatedAn an a) findInModule m ss = case doTrans m of Just a -> Right a Nothing ->@@ -712,21 +640,21 @@ ] in Left $ NotFound expected actual ss where- doTrans :: forall b. Data b => modu -> Maybe (GHC.Located b)+ doTrans :: forall an b. (Typeable an, Data b) => modu -> Maybe (GHC.LocatedAn an b) doTrans = something (mkQ Nothing (findLargestExpression ss)) - showType :: forall b. Typeable b => Maybe (GHC.Located b) -> Maybe String+ showType :: forall an b. Typeable b => Maybe (GHC.LocatedAn an b) -> Maybe String showType = fmap $ \_ -> show (typeRep (Proxy @b)) -findLargestExpression :: forall a. Data a => AnnSpan -> GHC.Located a -> Maybe (GHC.Located a)-findLargestExpression as e@(getAnnSpan -> l) = if l == as then Just e else Nothing+findLargestExpression :: forall an a. Data a => AnnSpan -> GHC.LocatedAn an a -> Maybe (GHC.LocatedAn an a)+findLargestExpression as e@(getAnnSpanA -> l) = if l == as then Just e else Nothing findOrError ::- forall a modu m.- (Data a, Data modu, MonadIO m) =>+ forall a an modu m.+ (Typeable an, Data a, Data modu, MonadIO m) => modu -> AnnSpan ->- m (GHC.Located a)+ m (GHC.LocatedAn an a) findOrError m = either f pure . findInModule m where f nf = liftIO . throwIO $ mkIOError InappropriateType (renderNotFound nf) Nothing Nothing@@ -739,19 +667,6 @@ doDeleteImport :: Data a => (Import -> Bool) -> a -> a doDeleteImport = transformBi . filter -{---- 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)--}- addExtensionsToFlags :: [Extension] -> [Extension] ->@@ -775,8 +690,8 @@ parseModuleWithArgs :: ([Extension], [Extension]) -> FilePath ->- IO (Either Errors (Anns, GHC.ParsedSource))-parseModuleWithArgs (es, ds) fp = ghcWrapper $ do+ IO (Either Errors GHC.ParsedSource)+parseModuleWithArgs (es, ds) fp = ghcWrapper GHC.Paths.libdir $ do initFlags <- initDynFlags fp eflags <- liftIO $ addExtensionsToFlags es ds fp initFlags case eflags of@@ -784,8 +699,12 @@ Left err -> pure . Left $ mkErr initFlags GHC.noSrcSpan err Right flags -> do liftIO $ writeIORef' dynFlagsRef (Just flags)- res <- parseModuleApiAnnsWithCppInternal defaultCppOptions flags fp- pure $ postParseTransform res rigidLayout+ res <- parseModuleEpAnnsWithCppInternal defaultCppOptions flags fp++ -- pure $ postParseTransform res rigidLayout+ case postParseTransform res of+ Left e -> pure (Left e)+ Right ast -> pure $ Right (makeDeltaAst ast) -- | Parse the input into (enabled extensions, disabled extensions, invalid input). -- Implied extensions are automatically added. For example, @FunctionalDependencies@
src/Refact/Run.hs view
@@ -7,7 +7,7 @@ import Data.Maybe import Data.Version import Debug.Trace-import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.ExactPrint (showAst) import Options.Applicative import Paths_apply_refact import Refact.Apply (parseExtensions)@@ -85,11 +85,11 @@ let (enabledExts, disabledExts, invalidExts) = parseExtensions optionsLanguage unless (null invalidExts) . when (verb >= Normal) . putStrLn $ "Invalid extensions: " ++ intercalate ", " invalidExts- (as, m) <-- either (onError "runPipe") (uncurry applyFixities)+ m <-+ either (onError "runPipe") applyFixities =<< parseModuleWithArgs (enabledExts, disabledExts) file- when optionsDebug (putStrLn (showAnnData as 0 m))- apply optionsPos optionsStep inp (Just file) verb as m+ when optionsDebug (putStrLn (showAst m))+ apply optionsPos optionsStep inp (Just file) verb m if optionsInplace && isJust optionsTarget then writeFileUTF8 file output
src/Refact/Utils.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-} module Refact.Utils ( -- * Synonyms@@ -13,7 +12,6 @@ Type, Import, FunBind,- AnnKeyMap, pattern RealSrcLoc', pattern RealSrcSpan', @@ -21,10 +19,9 @@ M, -- * Utility- mergeAnns, modifyAnnKey,- replaceAnnKey, getAnnSpan,+ getAnnSpanA, toGhcSrcSpan, toGhcSrcSpan', annSpanToSrcSpan,@@ -32,31 +29,19 @@ setAnnSpanFile, setSrcSpanFile, setRealSrcSpanFile,- findParent,- foldAnnKey, ) where -import Control.Monad.Trans.State (StateT, gets, modify)-import Data.Bifunctor (bimap)+import Control.Monad.Trans.State.Strict (StateT) import Data.Data- ( Data (gmapQi, toConstr),- Proxy (..),- splitTyConApp,- typeOf,- typeRep,- typeRepTyCon,+ ( Data (), )-import Data.Generics.Schemes (something)-import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe, isJust)-import Data.Typeable (Typeable, eqT, (:~:) (Refl))+import Data.Generics (everywhere, mkT)+import Data.Typeable import qualified GHC import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Types import Refact.Compat- ( AnnKeyMap,- AnnKeywordId (..),+ ( AnnSpan, FastString, FunBind, Module,@@ -70,102 +55,27 @@ pattern RealSrcSpan', ) import qualified Refact.Types as R-import Unsafe.Coerce (unsafeCoerce) -- Types-type M a = StateT (Anns, AnnKeyMap) IO a+-- type M a = StateT (Anns, AnnKeyMap) IO a+type M a = StateT () IO a -type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs)+type Expr = GHC.LHsExpr GHC.GhcPs -type Type = GHC.Located (GHC.HsType GHC.GhcPs)+type Type = GHC.LHsType GHC.GhcPs -type Decl = GHC.Located (GHC.HsDecl GHC.GhcPs)+type Decl = GHC.LHsDecl GHC.GhcPs -type Pat = GHC.Located (GHC.Pat GHC.GhcPs)+type Pat = GHC.LPat GHC.GhcPs -type Name = GHC.Located GHC.RdrName+type Name = GHC.LocatedN GHC.RdrName type Stmt = GHC.ExprLStmt GHC.GhcPs type Import = GHC.LImportDecl GHC.GhcPs --- | Replaces an old expression with a new expression------ Note that usually, new, inp and parent are all the same.-replace ::- AnnKey -> -- The thing we are replacing- AnnKey -> -- The thing which has the annotations we need for the new thing- AnnKey -> -- The thing which is going to be inserted- AnnKey -> -- The "parent", the largest thing which has he same SrcSpan- -- Usually the same as inp and new- Anns ->- Maybe Anns-replace old new inp parent anns = do- oldan <- Map.lookup old anns- newan <- Map.lookup new anns- oldDelta <- annEntryDelta <$> Map.lookup parent anns- return $ Map.insert inp (combine oldDelta new oldan newan) anns--combine :: DeltaPos -> AnnKey -> Annotation -> Annotation -> Annotation-combine oldDelta newkey oldann newann =- Ann- { annEntryDelta = newEntryDelta,- annPriorComments = annPriorComments oldann ++ annPriorComments newann,- annFollowingComments = annFollowingComments oldann ++ annFollowingComments newann,- annsDP = removeComma (annsDP newann) ++ extraComma (annsDP oldann),- annSortKey = annSortKey newann,- annCapturedSpan = annCapturedSpan newann- }- where- -- Get rid of structural information when replacing, we assume that the- -- structural information is already there in the new expression.- removeComma =- filter- ( \(kw, _) -> case kw of- G AnnComma- | AnnKey _ (CN "ArithSeq") <- newkey -> True- | otherwise -> False- AnnSemiSep -> False- _ -> True- )-- -- Make sure to keep structural information in the template.- extraComma [] = []- extraComma (last -> x) = case fst x of- G AnnComma -> [x]- AnnSemiSep -> [x]- G AnnSemi -> [x]- _ -> []-- -- Keep the same delta if moving onto a new row- newEntryDelta- | deltaRow oldDelta > 0 = oldDelta- | otherwise = annEntryDelta oldann---- | A parent in this case is an element which has the same SrcSpan-findParent :: Data a => AnnSpan -> Anns -> a -> Maybe AnnKey-findParent ss as = something (findParentWorker ss as)---- Note that a parent must also have an annotation.-findParentWorker ::- forall a.- (Data a) =>- AnnSpan ->- Anns ->- a ->- Maybe AnnKey-findParentWorker oldSS as a- | con == typeRepTyCon (typeRep (Proxy :: Proxy (GHC.Located GHC.RdrName))) && x == typeRep (Proxy :: Proxy AnnSpan) =- if ss == oldSS- && isJust (Map.lookup (AnnKey ss cn) as)- then Just $ AnnKey ss cn- else Nothing- | otherwise = Nothing- where- (con, ~[x, _]) = splitTyConApp (typeOf a)- ss :: AnnSpan- ss = gmapQi 0 unsafeCoerce a- cn = gmapQi 1 (CN . show . toConstr) a+getAnnSpanA :: forall an a. GHC.LocatedAn an a -> AnnSpan+getAnnSpanA = srcSpanToAnnSpan . GHC.getLocA getAnnSpan :: forall a. GHC.Located a -> AnnSpan getAnnSpan = srcSpanToAnnSpan . GHC.getLoc@@ -175,78 +85,67 @@ -- -- For example, this function will ensure the correct relative position and -- make sure that any trailing semi colons or commas are transferred.+-- modifyAnnKey ::+-- (Data old, Data new, Data mod) =>+-- mod ->+-- GHC.Located old ->+-- GHC.Located new ->+-- M (GHC.Located new) modifyAnnKey ::- (Data old, Data new, Data mod) =>+ (Data mod, Data t, Data old, Data new, Monoid t, Typeable t) => mod ->- GHC.Located old ->- GHC.Located new ->- M (GHC.Located new)-modifyAnnKey m e1 e2 = do- as <- gets fst- let parentKey = fromMaybe (mkAnnKey e2) (findParent (getAnnSpan e2) as m)- e2- <$ modify- ( bimap- ( dropContextParens e1 e2- . recoverBackquotes e1 e2- . replaceAnnKey (mkAnnKey e1) (mkAnnKey e2) (mkAnnKey e2) parentKey- )- (Map.insertWith (++) (mkAnnKey e1) [mkAnnKey e2])- )+ GHC.LocatedAn t old ->+ GHC.LocatedAn t new ->+ M (GHC.LocatedAn t new)+modifyAnnKey _m e1 e2 = do+ -- liftIO $ putStrLn $ "modifyAnnKey:e1" ++ showAst e1+ -- liftIO $ putStrLn $ "modifyAnnKey:e2" ++ showAst e2+ let e2_0 = handleBackquotes e1 e2+ -- liftIO $ putStrLn $ "modifyAnnKey:e2_0" ++ showAst e2_0+ let (e2', _, _) = runTransform $ transferEntryDP e1 e2_0+ -- liftIO $ putStrLn $ "modifyAnnKey:e2'" ++ showAst e2'+ return e2' --- | When parens are removed for the entire context, e.g.,------ @--- - f :: (HasCallStack) => ...--- + f :: HasCallStack => ...--- @+-- | This function handles backquotes in two scenarios: ----- We need to remove the `AnnOpenP` and `AnnCloseP` from the corresponding `Annotation`.-dropContextParens ::- forall old new.- (Typeable old, Typeable new) =>- GHC.Located old ->- GHC.Located new ->- Anns ->- Anns-dropContextParens old new anns- | Just Refl <- eqT @old @(GHC.HsType GHC.GhcPs),- Just Refl <- eqT @new @(GHC.HsType GHC.GhcPs),- isParTy old,- not (isParTy new),- Just annOld <- Map.lookup key anns,- (G AnnOpenP, _) : (G AnnCloseP, _) : rest <- annsDP annOld =- Map.adjust (\x -> x {annsDP = rest}) key anns- | otherwise = anns+-- 1. When the template contains a backquoted substitution variable, but the substitute+-- is not backquoted, we must add the corresponding 'GHC.NameBackquotes'. See+-- tests/examples/Backquotes.hs for an example.+-- 2. When the template contains a substitution variable without backquote, and the+-- substitute is backquoted, we remove the 'GHC.NameBackquotes' annotation. See+-- tests/examples/Uncurry.hs for an example.+-- N.B.: this is not always correct, since it is possible that the refactoring output+-- should keep the backquotes, but currently no test case fails because of it.+handleBackquotes ::+ forall t old new.+ (Data t, Data old, Data new, Monoid t, Typeable t) =>+ GHC.LocatedAn t old ->+ GHC.LocatedAn t new ->+ GHC.LocatedAn t new+handleBackquotes old new@(GHC.L loc _) =+ everywhere (mkT update) new where- key = AnnKey (getAnnSpan old) (CN "(:)")- isParTy = \case (GHC.L _ GHC.HsParTy {}) -> True; _ -> False---- | When the template contains a backquoted substitution variable, but the substitute--- is not backquoted, we must add the corresponding 'GHC.AnnBackQuote's.------ See tests/examples/Backquotes.hs for an example.-recoverBackquotes :: GHC.Located old -> GHC.Located new -> Anns -> Anns-recoverBackquotes (getAnnSpan -> old) (getAnnSpan -> new) anns- | Just annOld <- Map.lookup (AnnKey old (CN "Unqual")) anns,- ( (G AnnBackquote, DP (i, j))- : rest@( (G AnnVal, _)- : (G AnnBackquote, _)- : _- )- ) <-- annsDP annOld =- let f annNew = case annsDP annNew of- [(G AnnVal, DP (i', j'))] ->- annNew {annsDP = (G AnnBackquote, DP (i + i', j + j')) : rest}- _ -> annNew- in Map.adjust f (AnnKey new (CN "Unqual")) anns- | otherwise = anns---- | Lower level version of @modifyAnnKey@-replaceAnnKey :: AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Anns-replaceAnnKey old new inp deltainfo a =- fromMaybe a (replace old new inp deltainfo a)+ update :: GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs+ update (GHC.L l (GHC.HsVar x (GHC.L ln n))) = GHC.L l (GHC.HsVar x (GHC.L ln' n))+ where+ ln' =+ if GHC.locA l == GHC.locA loc+ then case cast old :: Maybe (GHC.LHsExpr GHC.GhcPs) of+ Just (GHC.L _ (GHC.HsVar _ (GHC.L (GHC.SrcSpanAnn (GHC.EpAnn _ ann _) _) _)))+ -- scenario 1+ | GHC.NameAnn GHC.NameBackquotes _ _ _ _ <- ann ->+ case ln of+ (GHC.SrcSpanAnn (GHC.EpAnn a _ cs) ll) -> GHC.SrcSpanAnn (GHC.EpAnn a ann cs) ll+ (GHC.SrcSpanAnn GHC.EpAnnNotUsed ll) ->+ GHC.SrcSpanAnn (GHC.EpAnn (GHC.spanAsAnchor ll) ann GHC.emptyComments) ll+ -- scenario 2+ | GHC.SrcSpanAnn (GHC.EpAnn a ann' cs) ll <- ln,+ GHC.NameAnn GHC.NameBackquotes _ _ _ _ <- ann' ->+ GHC.SrcSpanAnn (GHC.EpAnn a ann cs) ll+ Just _ -> ln+ Nothing -> ln+ else ln+ update x = x -- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@ toGhcSrcSpan :: FilePath -> R.SrcSpan -> GHC.SrcSpan@@ -257,13 +156,3 @@ toGhcSrcSpan' file R.SrcSpan {..} = GHC.mkSrcSpan (f startLine startCol) (f endLine endCol) where f = GHC.mkSrcLoc file--foldAnnKey ::- forall a.- (AnnKey -> a) ->- (GHC.RealSrcSpan -> AnnConName -> a) ->- AnnKey ->- a-foldAnnKey f g key@(AnnKey (annSpanToSrcSpan -> ss) con) = case ss of- RealSrcSpan' r -> g r con- _ -> f key
tests/Test.hs view
@@ -48,7 +48,11 @@ , optionsPos = Nothing } action =- hSilence [stderr] $ runPipe topts fp+ -- hSilence [stderr] $ runPipe topts fp+ runPipe topts fp diffCmd = \ref new -> ["diff", "-u", ref, new] testFn = if fp `elem` expectedFailures then expectFail else id in testFn $ goldenVsFileDiff fp diffCmd (fp <.> "expected") outfile action++tt = defaultMain . mkTests =<<+ pure [ "tests/examples/Import6.hs" ]
+ tests/examples/Bracket47.hs view
@@ -0,0 +1,1 @@+yes = curry (uncurry (+))
+ tests/examples/Bracket47.hs.expected view
@@ -0,0 +1,1 @@+yes = (+)
+ tests/examples/Bracket47.hs.refact view
@@ -0,0 +1,1 @@+[("tests/examples/Bracket47.hs:1:7-25: Warning: Redundant curry\nFound:\n curry (uncurry (+))\nPerhaps:\n (+)\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 26}, subts = [("f",SrcSpan {startLine = 1, startCol = 22, endLine = 1, endCol = 25})], orig = "f"}])]
tests/examples/Pragma4.hs.expected view
tests/examples/Pragma7.hs.expected view