diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,7 @@ +v0.9.3.0 + + * #113, Fix Annotation when context parens are removed + v0.9.2.0 * #110, Support GHC 9.0.1 diff --git a/apply-refact.cabal b/apply-refact.cabal --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: apply-refact -version: 0.9.2.0 +version: 0.9.3.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.3, GHC == 8.8.4, GHC == 8.6.5 +tested-with: GHC == 9.0.1, GHC == 8.10.4, GHC == 8.8.4, GHC == 8.6.5 source-repository head @@ -30,6 +30,7 @@ , Refact.Apply , Refact.Fixity , Refact.Internal + , Refact.Compat GHC-Options: -Wall build-depends: base >=4.12 && < 5 , refact >= 0.2 @@ -67,6 +68,7 @@ other-modules: Paths_apply_refact Refact.Apply + Refact.Compat Refact.Fixity Refact.Internal Refact.Options @@ -114,6 +116,7 @@ other-modules: Paths_apply_refact Refact.Apply + Refact.Compat Refact.Fixity Refact.Internal Refact.Options diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -1,24 +1,24 @@ module Refact.Apply - ( applyRefactorings - , applyRefactorings' - , runRefactoring - , parseExtensions - ) where + ( applyRefactorings, + applyRefactorings', + runRefactoring, + parseExtensions, + ) +where 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 import Refact.Types (Refactoring, SrcSpan) -import Refact.Utils (Module) -- | Apply a set of refactorings as supplied by HLint -applyRefactorings - :: Maybe (Int, Int) - -- ^ Apply hints relevant to a specific position - -> [[Refactoring SrcSpan]] - -- ^ 'Refactoring's to apply. Each inner list corresponds to an HLint +applyRefactorings :: + -- | Apply hints relevant to a specific position + Maybe (Int, Int) -> + -- | 'Refactoring's to apply. Each inner list corresponds to an HLint -- . -- An @Idea@ may have more than one 'Refactoring'. -- @@ -26,30 +26,32 @@ -- in that order. If two @Idea@s start at the same location, the one with the larger -- source span comes first. An @Idea@ is filtered out (ignored) if there is an @Idea@ -- prior to it which has an overlapping source span and is not filtered out. - -> FilePath - -- ^ Target file - -> [String] - -- ^ GHC extensions, e.g., @LambdaCase@, @NoStarIsType@. The list is processed from left + [[Refactoring SrcSpan]] -> + -- | Target file + FilePath -> + -- | GHC extensions, e.g., @LambdaCase@, @NoStarIsType@. The list is processed from left -- to right. An extension (e.g., @StarIsType@) may be overridden later (e.g., by @NoStarIsType@). -- -- These are in addition to the @LANGUAGE@ pragmas in the target file. When they conflict -- with the @LANGUAGE@ pragmas, pragmas win. - -> IO String + [String] -> + IO String 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) - =<< parseModuleWithArgs (enabled, disabled) file + (as, m) <- + either (onError "apply") (uncurry applyFixities) + =<< parseModuleWithArgs (enabled, disabled) file apply optionsPos False ((mempty,) <$> inp) (Just file) Silent as m -- | Like 'applyRefactorings', but takes a parsed module rather than a file path to parse. -applyRefactorings' - :: Maybe (Int, Int) - -> [[Refactoring SrcSpan]] - -> Anns - -- ^ ghc-exactprint AST annotations. This can be obtained from +applyRefactorings' :: + Maybe (Int, Int) -> + [[Refactoring SrcSpan]] -> + -- | ghc-exactprint AST annotations. This can be obtained from -- 'Language.Haskell.GHC.ExactPrint.Parsers.postParseTransform'. - -> Module - -- ^ Parsed module - -> IO String + Anns -> + -- | Parsed module + Module -> + IO String applyRefactorings' optionsPos inp = apply optionsPos False ((mempty,) <$> inp) Nothing Silent diff --git a/src/Refact/Compat.hs b/src/Refact/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Refact/Compat.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PatternSynonyms #-} + +module Refact.Compat ( + -- * ApiAnnotation / GHC.Parser.ApiAnnotation + AnnKeywordId (..), + + -- * BasicTypes / GHC.Types.Basic + Fixity (..), + SourceText (..), + + -- * DynFlags / GHC.Driver.Session + FlagSpec (..), + GeneralFlag (..), + gopt_set, + gopt_unset, + parseDynamicFilePragma, + xopt_set, + xopt_unset, + xFlags, + + -- * ErrUtils + Errors, + ErrorMessages, + onError, + pprErrMsgBagWithLoc, + + -- * FastString / GHC.Data.FastString + FastString, + mkFastString, + + -- * HeaderInfo / GHC.Parser.Header + getOptions, + + -- * HsExpr / GHC.Hs.Expr + GRHS (..), + HsExpr (..), + HsMatchContext (..), + HsStmtContext (..), + Match (..), + MatchGroup (..), + StmtLR (..), + + -- * HsSyn / GHC.Hs +#if __GLASGOW_HASKELL__ >= 810 + module GHC.Hs, +#else + module HsSyn, +#endif + + -- * Name / OccName / GHC.Types.Name + nameOccName, + occName, + occNameString, + ppr, + + -- * Outputable / GHC.Utils.Outputable + showSDocUnsafe, + + -- * Panic / GHC.Utils.Panic + handleGhcException, + + -- * RdrName / GHC.Types.Name.Reader + RdrName (..), + rdrNameOcc, + + -- * SrcLoc / GHC.Types.SrcLoc + GenLocated (..), + pattern RealSrcLoc', + pattern RealSrcSpan', + RealSrcSpan (..), + SrcSpanLess, + combineSrcSpans, + composeSrcSpan, + decomposeSrcSpan, + + -- * StringBuffer + stringToStringBuffer, + + -- * Misc + impliedXFlags, + + -- * Non-GHC stuff + AnnKeyMap, + FunBind, + DoGenReplacement, + Module, + MonadFail', + ReplaceWorker, + annSpanToSrcSpan, + badAnnSpan, + mkErr, + parseModuleName, + setAnnSpanFile, + setRealSrcSpanFile, + setSrcSpanFile, + srcSpanToAnnSpan, +) where + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Data.Bag (unitBag) +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.Name (nameOccName, occName, occNameString) +import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) +import GHC.Types.SrcLoc hiding (spans) +import GHC.Utils.Error +import GHC.Utils.Outputable + ( ppr, + showSDocUnsafe, + pprPanic, + text, + vcat, + ) +import GHC.Utils.Panic (handleGhcException) +#else +import ApiAnnotation +#if __GLASGOW_HASKELL__ == 810 +import Bag (unitBag) +#endif +import BasicTypes (Fixity (..), SourceText (..)) +import ErrUtils + ( ErrorMessages, + pprErrMsgBagWithLoc, +#if __GLASGOW_HASKELL__ == 810 + mkPlainErrMsg, +#endif + ) +import DynFlags hiding (initDynFlags) +import FastString (FastString, mkFastString) +import GHC.LanguageExtensions.Type (Extension (..)) +import HeaderInfo (getOptions) +import Name (nameOccName) +import OccName (occName, occNameString) +import Outputable + ( ppr, + showSDocUnsafe, +#if __GLASGOW_HASKELL__ == 810 + pprPanic, + text, + vcat, +#endif + ) +import Panic (handleGhcException) +import RdrName (RdrName (..), rdrNameOcc) +import SrcLoc hiding (spans) +import StringBuffer (stringToStringBuffer) +#endif + +#if __GLASGOW_HASKELL__ >= 810 +import GHC.Hs hiding (Pat, Stmt) +#elif __GLASGOW_HASKELL__ <= 808 +import HsSyn hiding (Pat, Stmt) +#endif + +import Control.Monad.Trans.State ( StateT ) +import Data.Data ( Data ) +import Data.Map.Strict (Map) +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 Refact.Types (Refactoring) + +#if __GLASGOW_HASKELL__ <= 806 +type MonadFail' = Monad +#else +type MonadFail' = MonadFail +#endif + +type AnnKeyMap = Map AnnKey [AnnKey] + +#if __GLASGOW_HASKELL__ >= 900 +type Module = Located HsModule +#else +type Module = Located (HsModule GhcPs) +#endif + +#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__ >= 900 +type FunBind = HsMatchContext GhcPs +#else +type FunBind = HsMatchContext RdrName +#endif + +pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc +#if __GLASGOW_HASKELL__ >= 900 +pattern RealSrcLoc' r <- RealSrcLoc r _ where + RealSrcLoc' r = RealSrcLoc r Nothing +#else +pattern RealSrcLoc' r <- RealSrcLoc r where + RealSrcLoc' r = RealSrcLoc r +#endif +{-# COMPLETE RealSrcLoc', UnhelpfulLoc #-} + +pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan +#if __GLASGOW_HASKELL__ >= 900 +pattern RealSrcSpan' r <- RealSrcSpan r _ where + RealSrcSpan' r = RealSrcSpan r Nothing +#else +pattern RealSrcSpan' r <- RealSrcSpan r where + RealSrcSpan' r = RealSrcSpan r +#endif +{-# COMPLETE RealSrcSpan', UnhelpfulSpan #-} + +#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 +composeSrcSpan :: a -> a +composeSrcSpan = id + +decomposeSrcSpan :: a -> a +decomposeSrcSpan = id + +type SrcSpanLess a = a +#endif + +badAnnSpan :: AnnSpan +badAnnSpan = +#if __GLASGOW_HASKELL__ >= 900 + badRealSrcSpan +#else + noSrcSpan +#endif + +srcSpanToAnnSpan :: SrcSpan -> AnnSpan +srcSpanToAnnSpan = +#if __GLASGOW_HASKELL__ >= 900 + \case RealSrcSpan l _ -> l; _ -> badRealSrcSpan +#else + id +#endif + +annSpanToSrcSpan :: AnnSpan -> SrcSpan +annSpanToSrcSpan = +#if __GLASGOW_HASKELL__ >= 900 + flip RealSrcSpan Nothing +#else + id +#endif + +setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan +setSrcSpanFile file s + | RealSrcLoc' start <- srcSpanStart s, + RealSrcLoc' end <- srcSpanEnd s = + let start' = mkSrcLoc file (srcLocLine start) (srcLocCol start) + end' = mkSrcLoc file (srcLocLine end) (srcLocCol end) + in mkSrcSpan start' end' +setSrcSpanFile _ s = s + +setRealSrcSpanFile :: FastString -> RealSrcSpan -> RealSrcSpan +setRealSrcSpanFile file s = mkRealSrcSpan start' end' + where + start = realSrcSpanStart s + end = realSrcSpanEnd s + start' = mkRealSrcLoc file (srcLocLine start) (srcLocCol start) + end' = mkRealSrcLoc file (srcLocLine end) (srcLocCol end) + +setAnnSpanFile :: FastString -> AnnSpan -> AnnSpan +setAnnSpanFile = +#if __GLASGOW_HASKELL__ >= 900 + setRealSrcSpanFile +#else + setSrcSpanFile +#endif + +mkErr :: DynFlags -> SrcSpan -> String -> Errors +#if __GLASGOW_HASKELL__ >= 810 +mkErr df l s = unitBag (mkPlainErrMsg df l (text s)) +#else +mkErr = const (,) +#endif + +parseModuleName :: SrcSpan -> Parser (Located GHC.ModuleName) +parseModuleName ss _ _ s = + let newMN = GHC.L 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) + +#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 +type DoGenReplacement ast a = + (Data ast, Data a) => + a -> + (Located ast -> Bool) -> + Located ast -> + Located ast -> + StateT ((Anns, AnnKeyMap), Bool) IO (Located ast) +#else +type DoGenReplacement ast a = + (Data (SrcSpanLess ast), HasSrcSpan ast, Data a) => + a -> + (ast -> Bool) -> + ast -> + ast -> + StateT ((Anns, AnnKeyMap), Bool) IO ast +#endif + +#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 +type ReplaceWorker a mod = + (Annotate a, Data mod) => + Anns -> + mod -> + AnnKeyMap -> + Parser (Located a) -> + Int -> + Refactoring SrcSpan -> + IO (Anns, mod, AnnKeyMap) +#else +type ReplaceWorker a mod = + (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) => + Anns -> + mod -> + AnnKeyMap -> + Parser a -> + Int -> + Refactoring SrcSpan -> + IO (Anns, mod, AnnKeyMap) +#endif + +#if __GLASGOW_HASKELL__ < 900 +-- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to +-- support GHC 8.6 +impliedXFlags :: [(Extension, Bool, Extension)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (RankNTypes, True, ExplicitForAll) + , (QuantifiedConstraints, True, ExplicitForAll) + , (ScopedTypeVariables, True, ExplicitForAll) + , (LiberalTypeSynonyms, True, ExplicitForAll) + , (ExistentialQuantification, True, ExplicitForAll) + , (FlexibleInstances, True, TypeSynonymInstances) + , (FunctionalDependencies, True, MultiParamTypeClasses) + , (MultiParamTypeClasses, True, ConstrainedClassMethods) -- c.f. #7854 + , (TypeFamilyDependencies, True, TypeFamilies) + + , (RebindableSyntax, False, ImplicitPrelude) -- NB: turn off! + + , (DerivingVia, True, DerivingStrategies) + + , (GADTs, True, GADTSyntax) + , (GADTs, True, MonoLocalBinds) + , (TypeFamilies, True, MonoLocalBinds) + + , (TypeFamilies, True, KindSignatures) -- Type families use kind signatures + , (PolyKinds, True, KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. + , (TypeInType, True, DataKinds) + , (TypeInType, True, PolyKinds) + , (TypeInType, True, KindSignatures) + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (AutoDeriveTypeable, True, DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (TypeFamilies, True, ExplicitNamespaces) + , (TypeOperators, True, ExplicitNamespaces) + + , (ImpredicativeTypes, True, RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (RecordWildCards, True, DisambiguateRecordFields) + + , (ParallelArrays, True, ParallelListComp) + + , (JavaScriptFFI, True, InterruptibleFFI) + + , (DeriveTraversable, True, DeriveFunctor) + , (DeriveTraversable, True, DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (DuplicateRecordFields, True, DisambiguateRecordFields) + + , (TemplateHaskell, True, TemplateHaskellQuotes) + , (Strict, True, StrictData) +#if __GLASGOW_HASKELL__ >= 810 + , (StandaloneKindSignatures, False, CUSKs) +#endif + ] +#endif diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs --- a/src/Refact/Fixity.hs +++ b/src/Refact/Fixity.hs @@ -1,53 +1,30 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} module Refact.Fixity (applyFixities) where -import Refact.Utils - -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs -#else -import HsExpr -import HsExtension hiding (noExt) -#endif - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Parser.Annotation -import GHC.Types.Basic (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..)) -import GHC.Types.Name.Occurrence -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -#else -import ApiAnnotation -import BasicTypes (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..)) -import RdrName -import OccName -import SrcLoc -#endif - +import Control.Monad.Trans.State import Data.Generics hiding (Fixity) import Data.List -import Data.Maybe -import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn) - -import Control.Monad.Trans.State 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 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 -expFix :: LHsExpr GhcPs -> StateT Anns IO (LHsExpr GhcPs) -expFix (L loc (OpApp _ l op r)) = +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 e = return e getIdent :: Expr -> String -getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n +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: @@ -59,108 +36,109 @@ 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 AnnMinus) . fst) (annsDP oldAnn) = [dp] - | otherwise = [] - modify . Map.insert newKey $ annNone - { annEntryDelta = annEntryDelta oldAnn - , annPriorComments = annPriorComments oldAnn - , annsDP = newAnnsDP - } + 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 + modify $ Map.adjust (\a -> a {annEntryDelta = DP (0, 0), annPriorComments = []}) oldKey --------------------------- -- Modified from GHC Renamer mkOpAppRn :: - [(String, Fixity)] - -> SrcSpan - -> LHsExpr GhcPs -- Left operand; already rearrange - -> LHsExpr GhcPs -> Fixity -- Operator and fixity - -> LHsExpr GhcPs -- Right operand (not an OpApp, but might - -- be a NegApp) - -> StateT Anns IO (LHsExpr GhcPs) - + [(String, GHC.Fixity)] -> + GHC.SrcSpan -> + Expr -> -- Left operand; already rearrange + Expr -> + GHC.Fixity -> -- Operator and fixity + Expr -> -- Right operand (not an OpApp, but might + -- be a NegApp) + StateT Anns IO Expr -- (e11 `op1` e12) `op2` e2 -mkOpAppRn fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2 - | nofix_error - = return $ L loc (OpApp noExt e1 op2 e2) - +mkOpAppRn fs loc e1@(GHC.L _ (GHC.OpApp x1 e11 op1 e12)) op2 fix2 e2 + | nofix_error = + return $ GHC.L loc (GHC.OpApp noExt 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 $ L loc (OpApp x1 e11 op1 new_e) + return $ GHC.L loc (GHC.OpApp x1 e11 op1 new_e) where - loc'= combineLocs e12 e2 + loc' = GHC.combineLocs e12 e2 fix1 = findFixity fs op1 - (nofix_error, associate_right) = compareFixity fix1 fix2 + (nofix_error, associate_right) = GHC.compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn fs loc e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 - | nofix_error - = return (L loc (OpApp noExt e1 op2 e2)) - - | associate_right - = do +mkOpAppRn fs loc e1@(GHC.L _ (GHC.NegApp _ neg_arg neg_name)) op2 fix2 e2 + | nofix_error = + return (GHC.L loc (GHC.OpApp noExt 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 = L loc (NegApp noExt new_e neg_name) + let res = GHC.L loc (GHC.NegApp noExt new_e neg_name) key = mkAnnKey res - ak = AnnKey (srcSpanToAnnSpan loc) (CN "OpApp") + 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.insert key (annNone {annEntryDelta = annEntryDelta opAnn, annsDP = annsDP negAnns}) modify $ Map.delete (mkAnnKey e1) return res where - loc' = combineLocs neg_arg e2 - (nofix_error, associate_right) = compareFixity negateFixity fix2 + loc' = GHC.combineLocs neg_arg e2 + (nofix_error, associate_right) = GHC.compareFixity GHC.negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn _ loc e1 op1 fix1 e2@(L _ NegApp{}) -- NegApp can occur on the right - | not associate_right -- We *want* right association - = return $ L loc (OpApp noExt e1 op1 e2) +mkOpAppRn _ loc 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) where - (_, associate_right) = compareFixity fix1 negateFixity + (_, associate_right) = GHC.compareFixity fix1 GHC.negateFixity --------------------------- -- Default case -mkOpAppRn _ loc e1 op _fix e2 -- Default case, no rearrangment - = return $ L loc (OpApp noExt e1 op e2) +mkOpAppRn _ loc e1 op _fix e2 -- Default case, no rearrangment + = + return $ GHC.L loc (GHC.OpApp noExt e1 op e2) -findFixity :: [(String, Fixity)] -> Expr -> Fixity +findFixity :: [(String, GHC.Fixity)] -> Expr -> GHC.Fixity findFixity fs r = askFix fs (getIdent r) -askFix :: [(String, Fixity)] -> String -> Fixity -askFix xs = \k -> lookupWithDefault defaultFixity k xs - where - lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1 - - +askFix :: [(String, GHC.Fixity)] -> String -> GHC.Fixity +askFix xs = \k -> lookupWithDefault GHC.defaultFixity k xs + where + lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1 -- | All fixities defined in the Prelude. -preludeFixities :: [(String, Fixity)] -preludeFixities = concat - [infixr_ 9 ["."] - ,infixl_ 9 ["!!"] - ,infixr_ 8 ["^","^^","**"] - ,infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"] - ,infixl_ 6 ["+","-"] - ,infixr_ 5 [":","++"] - ,infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"] - ,infixr_ 3 ["&&"] - ,infixr_ 2 ["||"] - ,infixl_ 1 [">>",">>="] - ,infixr_ 1 ["=<<"] - ,infixr_ 0 ["$","$!","seq"] +preludeFixities :: [(String, GHC.Fixity)] +preludeFixities = + concat + [ infixr_ 9 ["."], + infixl_ 9 ["!!"], + infixr_ 8 ["^", "^^", "**"], + infixl_ 7 ["*", "/", "quot", "rem", "div", "mod", ":%", "%"], + infixl_ 6 ["+", "-"], + infixr_ 5 [":", "++"], + infix_ 4 ["==", "/=", "<", "<=", ">=", ">", "elem", "notElem"], + infixr_ 3 ["&&"], + infixr_ 2 ["||"], + infixl_ 1 [">>", ">>="], + infixr_ 1 ["=<<"], + infixr_ 0 ["$", "$!", "seq"] ] -- | All fixities defined in the base package. @@ -168,31 +146,33 @@ -- Note that the @+++@ operator appears in both Control.Arrows and -- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in -- this list is that of Control.Arrows. -baseFixities :: [(String, Fixity)] -baseFixities = preludeFixities ++ concat - [infixl_ 9 ["!","//","!:"] - ,infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"] - ,infixl_ 7 [".&."] - ,infixl_ 6 ["xor"] - ,infix_ 6 [":+"] - ,infixl_ 5 [".|."] - ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow - ,infix_ 5 ["\\\\"] - ,infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"] - ,infix_ 4 ["elemP","notElemP"] - ,infixl_ 3 ["<|>"] - ,infixr_ 3 ["&&&","***"] - ,infixr_ 2 ["+++","|||"] - ,infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"] - ,infixl_ 0 ["on"] - ,infixr_ 0 ["par","pseq"] - ] +baseFixities :: [(String, GHC.Fixity)] +baseFixities = + preludeFixities + ++ concat + [ infixl_ 9 ["!", "//", "!:"], + infixl_ 8 ["shift", "rotate", "shiftL", "shiftR", "rotateL", "rotateR"], + infixl_ 7 [".&."], + infixl_ 6 ["xor"], + infix_ 6 [":+"], + infixl_ 5 [".|."], + infixr_ 5 ["+:+", "<++", "<+>"], -- fixity conflict for +++ between ReadP and Arrow + infix_ 5 ["\\\\"], + infixl_ 4 ["<$>", "<$", "<*>", "<*", "*>", "<**>"], + infix_ 4 ["elemP", "notElemP"], + infixl_ 3 ["<|>"], + infixr_ 3 ["&&&", "***"], + infixr_ 2 ["+++", "|||"], + infixr_ 1 ["<=<", ">=>", ">>>", "<<<", "^<<", "<<^", "^>>", ">>^"], + infixl_ 0 ["on"], + infixr_ 0 ["par", "pseq"] + ] -infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)] -infixr_ = fixity InfixR -infixl_ = fixity InfixL -infix_ = fixity InfixN +infixr_, infixl_, infix_ :: Int -> [String] -> [(String, GHC.Fixity)] +infixr_ = fixity GHC.InfixR +infixl_ = fixity GHC.InfixL +infix_ = fixity GHC.InfixN -- Internal: help function for the above definitions. -fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)] +fixity :: GHC.FixityDirection -> Int -> [String] -> [(String, GHC.Fixity)] fixity a p = map (,Fixity (SourceText "") p a) diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -1,935 +1,828 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Refact.Internal - ( apply - , runRefactoring - , addExtensionsToFlags - , parseModuleWithArgs - , parseExtensions - - -- * Support for runPipe in the main process - , Verbosity(..) - , rigidLayout - , refactOptions - , type Errors - , onError - , mkErr - ) where - -import Control.Exception -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.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.IORef.Extra -import qualified Data.Map as Map -import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) -import Data.List.Extra -import Data.Ord (comparing) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Tuple.Extra -import Debug.Trace - -import qualified GHC hiding (parseModule) - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Data.Bag -import GHC.Data.StringBuffer (stringToStringBuffer) -import GHC.Driver.Session hiding (initDynFlags) -import GHC.Driver.Types (handleSourceError) -import GHC.Parser.Header (getOptions) -import qualified GHC.Types.Name as GHC -import qualified GHC.Types.Name.Reader as GHC -import GHC.Types.SrcLoc hiding (spans) -import GHC.Utils.Error -import GHC.Utils.Outputable hiding ((<>)) -import GHC.Utils.Panic (handleGhcException) -#else -import DynFlags hiding (initDynFlags) -import HeaderInfo (getOptions) -import HscTypes (handleSourceError) -import qualified Name as GHC -import Outputable hiding ((<>)) -import Panic (handleGhcException) -import qualified RdrName as GHC -import SrcLoc hiding (spans) -import StringBuffer (stringToStringBuffer) -#endif - -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs.Expr as GHC hiding (Stmt) -import GHC.Hs.ImpExp -import GHC.Hs hiding (Pat, Stmt) -#elif __GLASGOW_HASKELL__ <= 808 -import HsExpr as GHC hiding (Stmt) -import HsImpExp -import HsSyn hiding (Pat, Stmt, noExt) -#endif - -#if __GLASGOW_HASKELL__ == 810 -import Bag -import ErrUtils -#endif - -import GHC.IO.Exception (IOErrorType(..)) -import GHC.LanguageExtensions.Type (Extension(..)) -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 hiding (rs) -import System.IO.Error (mkIOError) -import System.IO.Extra -import System.IO.Unsafe (unsafePerformIO) - -import Refact.Types hiding (SrcSpan) -import qualified Refact.Types as R -import Refact.Utils (Stmt, Pat, Name, Decl, M, Module, Expr, Type, FunBind, AnnKeyMap - , pattern RealSrcSpan' - , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, toGhcSrcSpan' - , annSpanToSrcSpan, srcSpanToAnnSpan, setSrcSpanFile, setAnnSpanFile, getAnnSpan) - -#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 || __GLASGOW_HASKELL__ >= 900 -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])] - -> Maybe FilePath - -> Verbosity - -> Anns - -> Module - -> IO String -apply mpos step inp mbfile verb as0 m0 = do - toGhcSS <- - maybe - ( case getLoc m0 of - UnhelpfulSpan s -> fail $ "Module has UnhelpfulSpan: " ++ show s - RealSrcSpan' s -> - pure $ toGhcSrcSpan' (srcSpanFile s) - ) - (pure . toGhcSrcSpan) - mbfile - let allRefacts :: [((String, [Refactoring SrcSpan]), R.SrcSpan)] - allRefacts = - sortBy cmpSrcSpan - . map (first . second . map . fmap $ toGhcSS) - . mapMaybe (sequenceA . (id &&& aggregateSrcSpans . map pos . snd)) - . filter (maybe (const True) (\p -> any ((`spans` p) . pos) . snd) mpos) - $ inp - - cmpSrcSpan (_, 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 - - when (verb >= Normal) . traceM $ - "Applying " ++ (show . sum . map (length . snd . fst) $ allRefacts) ++ " hints" - when (verb == Loud) . traceM $ show (map fst allRefacts) - - (as, 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 - -spans :: R.SrcSpan -> (Int, Int) -> Bool -spans R.SrcSpan{..} loc = (startLine, startCol) <= loc && loc <= (endLine, endCol) - -aggregateSrcSpans :: [R.SrcSpan] -> Maybe R.SrcSpan -aggregateSrcSpans = \case - [] -> Nothing - rs -> Just (foldr1 alg rs) - where - alg (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 - -runRefactorings - :: Verbosity - -> Anns - -> Module - -> [([Refactoring 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 - 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' - :: Verbosity - -> Anns - -> Module - -> [Refactoring SrcSpan] - -> StateT Int IO (Maybe (Anns, Module)) -runRefactorings' verb as0 m0 rs = do - seed <- get - (as, m, keyMap) <- foldlM (uncurry3 runRefactoring) (as0, m0, Map.empty) rs - if droppedComments as m keyMap - 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) - -overlap :: R.SrcSpan -> R.SrcSpan -> Bool -overlap s1 s2 = - -- We know s1 always starts <= s2, due to our sort - case compare (startLine s2) (endLine s1) of - LT -> True - EQ -> startCol s2 <= endCol s1 - GT -> False - -data LoopOption = LoopOption - { desc :: String - , perform :: MaybeT IO (Anns, Module) - } - -refactoringLoop - :: Anns - -> Module - -> [((String, [Refactoring 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 - Nothing -> do - liftIO $ putStrLn "Hint skipped since applying it would cause comments to be dropped" - refactoringLoop as0 m0 rss - 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))) - , ("d", LoopOption "Discard previous changes" mzero ) - , ("v", LoopOption "View current file" (liftIO (putStrLn (exactPrint m0 as0)) - >> refactoringLoop as0 m0 hints)) - , ("?", LoopOption "Show this help menu" loopHelp)] - loopHelp = do - liftIO . putStrLn . unlines . map mkLine $ opts - refactoringLoop as0 m0 hints - mkLine (c, opt) = c ++ " - " ++ desc opt - 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) - -data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord) - --- --------------------------------------------------------------------- - --- Perform the substitutions - --- | Peform a @Refactoring@. -runRefactoring - :: Data a - => Anns - -> a - -> AnnKeyMap - -> Refactoring SrcSpan - -> StateT Int IO (Anns, a, AnnKeyMap) -runRefactoring as m keyMap = \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) - where - annSpan = srcSpanToAnnSpan pos - f = case rtype of - Stmt -> doDeleteStmt ((/= annSpan) . getAnnSpan) - Import -> doDeleteImport ((/= annSpan) . getAnnSpan) - _ -> id - - InsertComment{..} -> do - exprkey <- mkAnnKey <$> findOrError @(HsDecl GhcPs) m (srcSpanToAnnSpan pos) - pure (insertComment exprkey newComment as, m, keyMap) - - RemoveAsKeyword{..} -> pure (as, removeAsKeyword m, keyMap) - where - removeAsKeyword = transformBi go - go :: LImportDecl GHC.GhcPs -> LImportDecl GHC.GhcPs - go imp@(GHC.L l i) - | srcSpanToAnnSpan l == srcSpanToAnnSpan pos = GHC.L l (i { ideclAs = Nothing }) - | otherwise = imp - -droppedComments :: Anns -> Module -> AnnKeyMap -> Bool -droppedComments as m keyMap = any (all (`Set.notMember` allSpans)) spanssWithComments - where - spanssWithComments = - map (\(key, _) -> map keySpan $ key : Map.findWithDefault [] key keyMap) - . filter (\(_, v) -> notNull (annPriorComments v) || notNull (annFollowingComments v)) - $ Map.toList as - - keySpan (AnnKey ss _) = ss - - allSpans :: Set AnnSpan - allSpans = Set.fromList . fmap srcSpanToAnnSpan $ universeBi m - --- 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 :: SrcSpan -> Parser (GHC.Located GHC.ModuleName) -parseModuleName ss _ _ s = - let newMN = GHC.L 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) -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, 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, SrcSpan)] -> Stmt -> M Stmt -stmtSub m subs old@(GHC.L _ (BodyStmt _ (GHC.L _ (HsVar _ (L _ name))) _ _) ) = - resolveRdrName m (findOrError m) old subs name -stmtSub _ _ e = pure e - -patSub :: Data a => a -> [(String, SrcSpan)] -> Pat -> M Pat -patSub m subs old@(GHC.L _ (VarPat _ (L _ name))) = - resolveRdrName m (findOrError m) old subs name -patSub _ _ e = pure e - -typeSub :: Data a => a -> [(String, SrcSpan)] -> Type -> M Type -typeSub m subs old@(GHC.L _ (HsTyVar _ _ (L _ name))) = - resolveRdrName m (findOrError m) old subs name -typeSub _ _ e = pure e - -exprSub :: Data a => a -> [(String, SrcSpan)] -> Expr -> M Expr -exprSub m subs old@(GHC.L _ (HsVar _ (L _ name))) = - resolveRdrName m (findOrError m) old subs name -exprSub _ _ e = pure 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, SrcSpan)] -> FunBind -> M FunBind -identSub m subs old@(GHC.FunRhs (GHC.L _ name) _ _) = - resolveRdrName' subst (findOrError 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 . first $ - replaceAnnKey (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr) - pure $ GHC.FunRhs new b s - subst o _ = pure o -identSub _ _ e = pure 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 - -> (AnnSpan -> M 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, 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) - | Just ss <- lookup oname subs -> f (srcSpanToAnnSpan ss) >>= g old - _ -> pure old - -resolveRdrName :: (Data old, Data a) - => a - -> (AnnSpan -> M (Located old)) - -> Located old - -> [(String, SrcSpan)] - -> GHC.RdrName - -> M (Located old) -resolveRdrName m = resolveRdrName' (modifyAnnKey m) - -badAnnSpan :: AnnSpan -badAnnSpan = -#if __GLASGOW_HASKELL__ >= 900 - badRealSrcSpan -#else - GHC.noSrcSpan -#endif - -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. -#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 -doGenReplacement - :: forall ast a. (Data ast, Data a) - => a - -> (GHC.Located ast -> Bool) - -> GHC.Located ast - -> GHC.Located ast - -> StateT ((Anns, AnnKeyMap), Bool) IO (GHC.Located ast) -#else -doGenReplacement - :: forall ast a. (Data (SrcSpanLess ast), HasSrcSpan ast, Data a) - => a - -> (ast -> Bool) - -> ast - -> ast - -> StateT ((Anns, AnnKeyMap), Bool) IO ast -#endif -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 - -- 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, keyMap) <- gets fst - let n = decomposeSrcSpan new - o = decomposeSrcSpan old - (intAnns, newKeyMap) <- liftIO $ execStateT (modifyAnnKey m o n) (anns, keyMap) - let newFile = srcSpanFile newLocReal - newLocal = transformBi (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 -#if __GLASGOW_HASKELL__ >= 900 - (AnnKey loc con, _) -> - loc == getAnnSpan old && con == CN "Match" && srcSpanFile loc /= newFile -#else - (AnnKey loc@(RealSrcSpan r) con, _) -> - loc == getLoc old && con == CN "Match" && srcSpanFile r /= newFile - _ -> False -#endif - pn = \case -#if __GLASGOW_HASKELL__ >= 900 - (AnnKey loc con, _) -> - loc == srcSpanToAnnSpan finalLoc && con == CN "Match" && srcSpanFile loc == newFile -#else - (AnnKey loc@(RealSrcSpan r) con, _) -> - loc == finalLoc && con == CN "Match" && srcSpanFile r == newFile - _ -> False -#endif - in fromMaybe oldAnns $ do - oldAnn <- snd <$> find po oldAnns' - annWhere <- find ((== G GHC.AnnWhere) . fst) (annsDP oldAnn) - let newSortKey = fmap (setAnnSpanFile newFile) <$> annSortKey oldAnn - newKey <- fst <$> find pn 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 = \case -#if __GLASGOW_HASKELL__ >= 900 - AnnKey r@(annSpanToSrcSpan -> loc) con -#else - AnnKey loc@(RealSrcSpan r) con -#endif - | con == CN "GRHS", srcSpanFile r == newFile -> - AnnKey (srcSpanToAnnSpan $ 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 - | annSpanToSrcSpan loc `isSubspanOf` 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 - - newAnns = addLocalBindsToAnns intAnns - put ((newAnns, newKeyMap), 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 || __GLASGOW_HASKELL__ >= 900 -replaceWorker :: (Annotate a, Data mod) - => Anns - -> mod - -> AnnKeyMap - -> Parser (GHC.Located a) - -> Int - -> Refactoring SrcSpan - -> IO (Anns, mod, AnnKeyMap) -#else -replaceWorker :: (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) - => Anns - -> mod - -> AnnKeyMap - -> Parser a - -> Int - -> Refactoring SrcSpan - -> IO (Anns, mod, AnnKeyMap) -#endif -replaceWorker as m keyMap parser seed Replace{..} = do - let replExprLocation = srcSpanToAnnSpan pos - uniqueName = "template" ++ show seed - - (relat, template) <- do - flags <- maybe (withDynFlags id) pure =<< readIORef dynFlagsRef - either (onError "replaceWorker") pure $ parser flags uniqueName orig - - (newExpr, (newAnns, newKeyMap)) <- - runStateT - (substTransform m subts template) - (mergeAnns as relat, keyMap) - let lst = listToMaybe . reverse . GHC.occNameString . GHC.rdrNameOcc -#if __GLASGOW_HASKELL__ >= 900 - adjacent (srcSpanEnd -> RealSrcLoc loc1 _) (srcSpanStart -> RealSrcLoc loc2 _) = loc1 == loc2 -#else - adjacent (srcSpanEnd -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) = loc1 == loc2 -#endif - 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 -> SrcSpan -> SrcSpan -> Bool -#if __GLASGOW_HASKELL__ >= 900 - diffStartCols x (srcSpanStart -> RealSrcLoc loc1 _) (srcSpanStart -> RealSrcLoc loc2 _) = -#else - diffStartCols x (srcSpanStart -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) = -#endif - srcLocLine loc1 == srcLocLine loc2 && srcLocCol loc1 - srcLocCol loc2 == x - diffStartCols _ _ _ = False - - -- Add a space if needed, so that we avoid refactoring `y = f(x)` into `y = fx`. - ensureAppSpace :: Anns -> Anns - ensureAppSpace = 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 - - -- 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 :: [LHsExpr GhcPs] = - listify - (\case - (L _ HsDo{}) -> True - _ -> False - ) - m - doBlocks' :: [(SrcSpan, Int)] - doBlocks' = - map - ( \case - L loc (HsDo _ MDoExpr{} _) -> (loc, 3) - 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) . 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) - -- Failed to find a replacment so don't make any changes - _ -> pure (as, m, keyMap) -replaceWorker as m keyMap _ _ _ = pure (as, m, keyMap) - -data NotFound = NotFound - { nfExpected :: String - , nfActual :: Maybe String - , nfLoc :: AnnSpan - } - -renderNotFound :: NotFound -> String -renderNotFound NotFound{..} = - "Expected type not found at the location specified in the refact file.\n" - ++ " Expected type: " ++ nfExpected ++ "\n" - ++ maybe "" (\actual -> " Actual type: " ++ actual ++ "\n") nfActual - ++ " Location: " ++ 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 m ss = case doTrans m of - Just a -> Right a - Nothing -> - let expected = show (typeRep (Proxy @a)) - actual = listToMaybe $ catMaybes - [ showType (doTrans m :: Maybe Expr) - , showType (doTrans m :: Maybe Type) - , showType (doTrans m :: Maybe Decl) - , showType (doTrans m :: Maybe Pat) - , showType (doTrans m :: Maybe Name) - ] - in Left $ NotFound expected actual ss - where - doTrans :: forall b. Data b => modu -> Maybe (GHC.Located b) - doTrans = something (mkQ Nothing (findLargestExpression ss)) - - showType :: forall b. Typeable b => Maybe (GHC.Located 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 - -findOrError - :: forall a modu m. (Data a, Data modu, MonadIO m) - => modu -> AnnSpan -> m (GHC.Located a) -findOrError m = either f pure . findInModule m - where - f nf = liftIO . throwIO $ mkIOError InappropriateType (renderNotFound nf) Nothing Nothing - --- Deletion from a list - -doDeleteStmt :: Data a => (Stmt -> Bool) -> a -> a -doDeleteStmt = transformBi . filter - -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] -> FilePath -> DynFlags - -> IO (Either String DynFlags) -addExtensionsToFlags es ds fp flags = catchErrors $ do - (stringToStringBuffer -> buf) <- readFileUTF8' fp - let opts = getOptions flags buf fp - withExts = flip (foldl' xopt_unset) ds - . flip (foldl' xopt_set) es - $ flags - (withPragmas, _, _) <- parseDynamicFilePragma withExts opts - pure . Right $ withPragmas `gopt_set` Opt_KeepRawTokenStream - where - catchErrors = handleGhcException (pure . Left . show) - . handleSourceError (pure . Left . show) - -parseModuleWithArgs - :: ([Extension], [Extension]) - -> FilePath - -> IO (Either Errors (Anns, GHC.ParsedSource)) -parseModuleWithArgs (es, ds) fp = ghcWrapper $ do - initFlags <- initDynFlags fp - eflags <- liftIO $ addExtensionsToFlags es ds fp initFlags - case eflags of - -- TODO: report error properly. - 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 - --- | Parse the input into (enabled extensions, disabled extensions, invalid input). --- Implied extensions are automatically added. For example, @FunctionalDependencies@ --- implies @MultiParamTypeClasses@, and @RebindableSyntax@ implies @NoImplicitPrelude@. --- --- The input is processed from left to right. An extension (e.g., @StarIsType@) --- may be overridden later (e.g., by @NoStarIsType@). --- --- Extensions that appear earlier in the input will appear later in the output. --- Implied extensions appear in the end. If an extension occurs multiple times in the input, --- the last one is used. --- --- >>> parseExtensions ["GADTs", "RebindableSyntax", "StarIsType", "GADTs", "InvalidExtension", "NoStarIsType"] --- ([GADTs, RebindableSyntax, GADTSyntax, MonoLocalBinds], [StarIsType, ImplicitPrelude], ["InvalidExtension"]) -parseExtensions :: [String] -> ([Extension], [Extension], [String]) -parseExtensions = addImplied . foldl' f mempty - where - f :: ([Extension], [Extension], [String]) -> String -> ([Extension], [Extension], [String]) - f (ys, ns, is) ('N' : 'o' : s) | Just ext <- readExtension s = - (delete ext ys, ext : delete ext ns, is) - f (ys, ns, is) s | Just ext <- readExtension s = - (ext : delete ext ys, delete ext ns, is) - f (ys, ns, is) s = (ys, ns, s : is) - - addImplied :: ([Extension], [Extension], [String]) -> ([Extension], [Extension], [String]) - addImplied (ys, ns, is) = (ys ++ impliedOn, ns ++ impliedOff, is) - where - impliedOn = [b | ext <- ys, (a, True, b) <- impliedXFlags, a == ext] - impliedOff = [b | ext <- ys, (a, False, b) <- impliedXFlags, a == ext] - -readExtension :: String -> Maybe Extension -readExtension s = flagSpecFlag <$> find ((== s) . flagSpecName) xFlags - -#if __GLASGOW_HASKELL__ < 900 --- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to --- support GHC 8.6 -impliedXFlags :: [(Extension, Bool, Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (RankNTypes, True, ExplicitForAll) - , (QuantifiedConstraints, True, ExplicitForAll) - , (ScopedTypeVariables, True, ExplicitForAll) - , (LiberalTypeSynonyms, True, ExplicitForAll) - , (ExistentialQuantification, True, ExplicitForAll) - , (FlexibleInstances, True, TypeSynonymInstances) - , (FunctionalDependencies, True, MultiParamTypeClasses) - , (MultiParamTypeClasses, True, ConstrainedClassMethods) -- c.f. #7854 - , (TypeFamilyDependencies, True, TypeFamilies) - - , (RebindableSyntax, False, ImplicitPrelude) -- NB: turn off! - - , (DerivingVia, True, DerivingStrategies) - - , (GADTs, True, GADTSyntax) - , (GADTs, True, MonoLocalBinds) - , (TypeFamilies, True, MonoLocalBinds) - - , (TypeFamilies, True, KindSignatures) -- Type families use kind signatures - , (PolyKinds, True, KindSignatures) -- Ditto polymorphic kinds - - -- TypeInType is now just a synonym for a couple of other extensions. - , (TypeInType, True, DataKinds) - , (TypeInType, True, PolyKinds) - , (TypeInType, True, KindSignatures) - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (AutoDeriveTypeable, True, DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (TypeFamilies, True, ExplicitNamespaces) - , (TypeOperators, True, ExplicitNamespaces) - - , (ImpredicativeTypes, True, RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (RecordWildCards, True, DisambiguateRecordFields) - - , (ParallelArrays, True, ParallelListComp) - - , (JavaScriptFFI, True, InterruptibleFFI) - - , (DeriveTraversable, True, DeriveFunctor) - , (DeriveTraversable, True, DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (DuplicateRecordFields, True, DisambiguateRecordFields) - - , (TemplateHaskell, True, TemplateHaskellQuotes) - , (Strict, True, StrictData) -#if __GLASGOW_HASKELL__ >= 810 - , (StandaloneKindSignatures, False, CUSKs) -#endif - ] -#endif - --- TODO: This is added to avoid a breaking change. We should remove it and --- directly pass the `DynFlags` as arguments, before the 0.10 release. -dynFlagsRef :: IORef (Maybe DynFlags) +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Refact.Internal + ( apply, + runRefactoring, + addExtensionsToFlags, + parseModuleWithArgs, + parseExtensions, + + -- * Support for runPipe in the main process + Verbosity (..), + rigidLayout, + refactOptions, + type Errors, + onError, + mkErr, + ) +where + +import Control.Exception +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.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.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 Language.Haskell.GHC.ExactPrint +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, GhcRn, GhcTc) +import Language.Haskell.GHC.ExactPrint.Utils hiding (rs) +import Refact.Compat + ( DoGenReplacement, + Errors, + FlagSpec (..), + FunBind, + Module, + RdrName (..), + ReplaceWorker, + SrcSpanLess, + annSpanToSrcSpan, + badAnnSpan, + combineSrcSpans, + composeSrcSpan, + decomposeSrcSpan, + getOptions, + gopt_set, + handleGhcException, + impliedXFlags, + mkErr, + nameOccName, + occName, + occNameString, + onError, + parseDynamicFilePragma, + parseModuleName, + ppr, + rdrNameOcc, + setAnnSpanFile, + setSrcSpanFile, + showSDocUnsafe, + srcSpanToAnnSpan, + stringToStringBuffer, + xFlags, + xopt_set, + xopt_unset, + pattern RealSrcLoc', + pattern RealSrcSpan', + ) +import Refact.Types hiding (SrcSpan) +import qualified Refact.Types as R +import Refact.Utils + ( AnnKeyMap, + Decl, + Expr, + Import, + M, + Name, + Pat, + Stmt, + Type, + foldAnnKey, + getAnnSpan, + modifyAnnKey, + replaceAnnKey, + toGhcSrcSpan, + toGhcSrcSpan', + ) +import System.IO.Error (mkIOError) +import System.IO.Extra +import System.IO.Unsafe (unsafePerformIO) + +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])] -> + Maybe FilePath -> + Verbosity -> + Anns -> + Module -> + IO String +apply mpos step inp mbfile verb as0 m0 = do + toGhcSS <- + maybe + ( case GHC.getLoc m0 of + GHC.UnhelpfulSpan s -> fail $ "Module has UnhelpfulSpan: " ++ show s + RealSrcSpan' s -> + pure $ toGhcSrcSpan' (GHC.srcSpanFile s) + ) + (pure . toGhcSrcSpan) + mbfile + let allRefacts :: [((String, [Refactoring GHC.SrcSpan]), R.SrcSpan)] + allRefacts = + sortBy cmpSrcSpan + . map (first . second . map . fmap $ toGhcSS) + . mapMaybe (sequenceA . (id &&& aggregateSrcSpans . map pos . snd)) + . filter (maybe (const True) (\p -> any ((`spans` p) . pos) . snd) mpos) + $ inp + + cmpSrcSpan (_, s1) (_, s2) = + comparing startLine s1 s2 + <> comparing startCol s1 s2 -- s1 first if it starts on earlier line + <> comparing endLine s2 s1 -- or on earlier column + <> comparing endCol s2 s1 -- they start in same place, s2 comes + -- first if it ends later + -- else, completely same span, so s1 will be first + when (verb >= Normal) . traceM $ + "Applying " ++ (show . sum . map (length . snd . fst) $ allRefacts) ++ " hints" + when (verb == Loud) . traceM $ show (map fst allRefacts) + + (as, 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 + +spans :: R.SrcSpan -> (Int, Int) -> Bool +spans R.SrcSpan {..} loc = (startLine, startCol) <= loc && loc <= (endLine, endCol) + +aggregateSrcSpans :: [R.SrcSpan] -> Maybe R.SrcSpan +aggregateSrcSpans = \case + [] -> Nothing + rs -> Just (foldr1 alg rs) + where + alg (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 + +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 + 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' :: + Verbosity -> + Anns -> + Module -> + [Refactoring GHC.SrcSpan] -> + StateT Int IO (Maybe (Anns, Module)) +runRefactorings' verb as0 m0 rs = do + seed <- get + (as, m, keyMap) <- foldlM (uncurry3 runRefactoring) (as0, m0, Map.empty) rs + if droppedComments as m keyMap + 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) + +overlap :: R.SrcSpan -> R.SrcSpan -> Bool +overlap s1 s2 = + -- We know s1 always starts <= s2, due to our sort + case compare (startLine s2) (endLine s1) of + LT -> True + EQ -> startCol s2 <= endCol s1 + GT -> False + +data LoopOption = LoopOption + { desc :: String, + perform :: MaybeT IO (Anns, 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 + Nothing -> do + liftIO $ putStrLn "Hint skipped since applying it would cause comments to be dropped" + refactoringLoop as0 m0 rss + 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))), + ("d", LoopOption "Discard previous changes" mzero), + ( "v", + LoopOption + "View current file" + ( liftIO (putStrLn (exactPrint m0 as0)) + >> refactoringLoop as0 m0 hints + ) + ), + ("?", LoopOption "Show this help menu" loopHelp) + ] + loopHelp = do + liftIO . putStrLn . unlines . map mkLine $ opts + refactoringLoop as0 m0 hints + mkLine (c, opt) = c ++ " - " ++ desc opt + 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) + +data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord) + +-- --------------------------------------------------------------------- + +-- Perform the substitutions + +-- | Peform a @Refactoring@. +runRefactoring :: + Data a => + Anns -> + a -> + AnnKeyMap -> + Refactoring GHC.SrcSpan -> + StateT Int IO (Anns, a, AnnKeyMap) +runRefactoring as m keyMap = \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) + where + annSpan = srcSpanToAnnSpan pos + f = case rtype of + Stmt -> doDeleteStmt ((/= annSpan) . getAnnSpan) + Import -> doDeleteImport ((/= annSpan) . getAnnSpan) + _ -> 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) + 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}) + | otherwise = imp + +droppedComments :: Anns -> Module -> AnnKeyMap -> Bool +droppedComments as m keyMap = any (all (`Set.notMember` allSpans)) spanssWithComments + where + spanssWithComments = + map (\(key, _) -> map keySpan $ key : Map.findWithDefault [] key keyMap) + . filter (\(_, v) -> notNull (annPriorComments v) || notNull (annFollowingComments v)) + $ Map.toList as + + keySpan (AnnKey ss _) = ss + + allSpans :: Set AnnSpan + allSpans = Set.fromList . fmap srcSpanToAnnSpan $ universeBi 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") + 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 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") + 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 _ (GHC.BodyStmt _ (GHC.L _ (GHC.HsVar _ (GHC.L _ name))) _ _)) = + resolveRdrName m (findOrError m) old subs name +stmtSub _ _ e = pure e + +patSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Pat -> M Pat +patSub m subs old@(GHC.L _ (GHC.VarPat _ (GHC.L _ name))) = + resolveRdrName m (findOrError m) old subs name +patSub _ _ e = pure e + +typeSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Type -> M Type +typeSub m subs old@(GHC.L _ (GHC.HsTyVar _ _ (GHC.L _ name))) = + resolveRdrName m (findOrError m) old subs name +typeSub _ _ e = pure e + +exprSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Expr -> M Expr +exprSub m subs old@(GHC.L _ (GHC.HsVar _ (GHC.L _ name))) = + resolveRdrName m (findOrError m) old subs name +exprSub _ _ e = pure 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 (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) + -- 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) + pure $ GHC.FunRhs new b s + subst o _ = pure o +identSub _ _ e = pure 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 + (AnnSpan -> M 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 (occNameString . occName -> oname) + | Just ss <- lookup oname subs -> f (srcSpanToAnnSpan ss) >>= g old + _ -> pure old + +resolveRdrName :: + (Data old, Data a) => + a -> + (AnnSpan -> M (GHC.Located old)) -> + GHC.Located old -> + [(String, GHC.SrcSpan)] -> + GHC.RdrName -> + M (GHC.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 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 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 + -- 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, + 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 = transformBi (setSrcSpanFile newFile) oldLocal + newLocalLoc = GHC.getLoc newLocal + ensureLoc = combineSrcSpans newLocalLoc + 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 = + 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 = 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 + + newAnns = addLocalBindsToAnns intAnns + put ((newAnns, newKeyMap), 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 :: + Decl -> + Maybe (Decl, GHC.LHsLocalBinds GHC.GhcPs) +stripLocalBind = \case + GHC.L _ (GHC.ValD xvald origBind@GHC.FunBind {}) + | let origMG = GHC.fun_matches origBind, + GHC.L locMG [GHC.L locMatch origMatch] <- GHC.mg_alts origMG, + 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 + withoutLocalBinds = + setLocalBind + (GHC.noLoc (GHC.EmptyLocalBinds noExt)) + xvald + origBind + newLoc + origMG + locMG + origMatch + locMatch + origGRHSs + in Just (withoutLocalBinds, GHC.grhssLocalBinds origGRHSs) + _ -> Nothing + +-- | Set the local binds in a HsBind. +setLocalBind :: + GHC.LHsLocalBinds GHC.GhcPs -> + GHC.XValD GHC.GhcPs -> + GHC.HsBind GHC.GhcPs -> + GHC.SrcSpan -> + GHC.MatchGroup GHC.GhcPs Expr -> + GHC.SrcSpan -> + GHC.Match GHC.GhcPs Expr -> + GHC.SrcSpan -> + GHC.GRHSs GHC.GhcPs Expr -> + Decl +setLocalBind newLocalBinds xvald origBind newLoc origMG locMG origMatch locMatch origGRHSs = + GHC.L newLoc (GHC.ValD xvald newBind) + where + newGRHSs = origGRHSs {GHC.grhssLocalBinds = newLocalBinds} + newMatch = origMatch {GHC.m_grhss = newGRHSs} + 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 + let replExprLocation = srcSpanToAnnSpan pos + uniqueName = "template" ++ show seed + + (relat, template) <- do + flags <- maybe (withDynFlags id) pure =<< readIORef dynFlagsRef + either (onError "replaceWorker") pure $ parser flags uniqueName orig + + (newExpr, (newAnns, newKeyMap)) <- + runStateT + (substTransform m subts 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 = 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 + + -- 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) . 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) + -- Failed to find a replacment so don't make any changes + _ -> pure (as, m, keyMap) +replaceWorker as m keyMap _ _ _ = pure (as, m, keyMap) + +data NotFound = NotFound + { nfExpected :: String, + nfActual :: Maybe String, + nfLoc :: AnnSpan + } + +renderNotFound :: NotFound -> String +renderNotFound NotFound {..} = + "Expected type not found at the location specified in the refact file.\n" + ++ " Expected type: " + ++ nfExpected + ++ "\n" + ++ maybe "" (\actual -> " Actual type: " ++ actual ++ "\n") nfActual + ++ " Location: " + ++ 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 m ss = case doTrans m of + Just a -> Right a + Nothing -> + let expected = show (typeRep (Proxy @a)) + actual = + listToMaybe $ + catMaybes + [ showType (doTrans m :: Maybe Expr), + showType (doTrans m :: Maybe Type), + showType (doTrans m :: Maybe Decl), + showType (doTrans m :: Maybe Pat), + showType (doTrans m :: Maybe Name) + ] + in Left $ NotFound expected actual ss + where + doTrans :: forall b. Data b => modu -> Maybe (GHC.Located b) + doTrans = something (mkQ Nothing (findLargestExpression ss)) + + showType :: forall b. Typeable b => Maybe (GHC.Located 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 + +findOrError :: + forall a modu m. + (Data a, Data modu, MonadIO m) => + modu -> + AnnSpan -> + m (GHC.Located a) +findOrError m = either f pure . findInModule m + where + f nf = liftIO . throwIO $ mkIOError InappropriateType (renderNotFound nf) Nothing Nothing + +-- Deletion from a list + +doDeleteStmt :: Data a => (Stmt -> Bool) -> a -> a +doDeleteStmt = transformBi . filter + +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] -> + FilePath -> + GHC.DynFlags -> + IO (Either String GHC.DynFlags) +addExtensionsToFlags es ds fp flags = catchErrors $ do + (stringToStringBuffer -> buf) <- readFileUTF8' fp + let opts = getOptions flags buf fp + withExts = + flip (foldl' xopt_unset) ds + . flip (foldl' xopt_set) es + $ flags + (withPragmas, _, _) <- parseDynamicFilePragma withExts opts + pure . Right $ withPragmas `gopt_set` GHC.Opt_KeepRawTokenStream + where + catchErrors = + handleGhcException (pure . Left . show) + . GHC.handleSourceError (pure . Left . show) + +parseModuleWithArgs :: + ([Extension], [Extension]) -> + FilePath -> + IO (Either Errors (Anns, GHC.ParsedSource)) +parseModuleWithArgs (es, ds) fp = ghcWrapper $ do + initFlags <- initDynFlags fp + eflags <- liftIO $ addExtensionsToFlags es ds fp initFlags + case eflags of + -- TODO: report error properly. + 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 + +-- | Parse the input into (enabled extensions, disabled extensions, invalid input). +-- Implied extensions are automatically added. For example, @FunctionalDependencies@ +-- implies @MultiParamTypeClasses@, and @RebindableSyntax@ implies @NoImplicitPrelude@. +-- +-- The input is processed from left to right. An extension (e.g., @StarIsType@) +-- may be overridden later (e.g., by @NoStarIsType@). +-- +-- Extensions that appear earlier in the input will appear later in the output. +-- Implied extensions appear in the end. If an extension occurs multiple times in the input, +-- the last one is used. +-- +-- >>> parseExtensions ["GADTs", "RebindableSyntax", "StarIsType", "GADTs", "InvalidExtension", "NoStarIsType"] +-- ([GADTs, RebindableSyntax, GADTSyntax, MonoLocalBinds], [StarIsType, ImplicitPrelude], ["InvalidExtension"]) +parseExtensions :: [String] -> ([Extension], [Extension], [String]) +parseExtensions = addImplied . foldl' f mempty + where + f :: ([Extension], [Extension], [String]) -> String -> ([Extension], [Extension], [String]) + f (ys, ns, is) ('N' : 'o' : s) + | Just ext <- readExtension s = + (delete ext ys, ext : delete ext ns, is) + f (ys, ns, is) s + | Just ext <- readExtension s = + (ext : delete ext ys, delete ext ns, is) + f (ys, ns, is) s = (ys, ns, s : is) + + addImplied :: ([Extension], [Extension], [String]) -> ([Extension], [Extension], [String]) + addImplied (ys, ns, is) = (ys ++ impliedOn, ns ++ impliedOff, is) + where + impliedOn = [b | ext <- ys, (a, True, b) <- impliedXFlags, a == ext] + impliedOff = [b | ext <- ys, (a, False, b) <- impliedXFlags, a == ext] + +readExtension :: String -> Maybe Extension +readExtension s = flagSpecFlag <$> find ((== s) . flagSpecName) xFlags + +-- TODO: This is added to avoid a breaking change. We should remove it and +-- directly pass the `DynFlags` as arguments, before the 0.10 release. +dynFlagsRef :: IORef (Maybe GHC.DynFlags) dynFlagsRef = unsafePerformIO $ newIORef Nothing {-# NOINLINE dynFlagsRef #-} diff --git a/src/Refact/Options.hs b/src/Refact/Options.hs --- a/src/Refact/Options.hs +++ b/src/Refact/Options.hs @@ -1,113 +1,134 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} -module Refact.Options (Options(..), optionsWithHelp) where +module Refact.Options (Options (..), optionsWithHelp) where import Data.Char (isDigit) import Options.Applicative +import Refact.Compat (MonadFail') +import Refact.Internal (Verbosity (..)) import Text.Read (readMaybe) -import Refact.Internal (Verbosity(..)) - -#if __GLASGOW_HASKELL__ <= 806 -type MonadFail = Monad -#endif - data Options = Options - { optionsTarget :: Maybe FilePath -- ^ Where to process hints - , optionsRefactFile :: Maybe FilePath -- ^ The refactorings to process - , optionsInplace :: Bool - , optionsOutput :: Maybe FilePath -- ^ Whether to overwrite the file inplace - , optionsVerbosity :: Verbosity - , optionsStep :: Bool -- ^ Ask before applying each hint - , optionsDebug :: Bool - , optionsRoundtrip :: Bool - , optionsVersion :: Bool - , optionsLanguage :: [String] - , optionsPos :: Maybe (Int, Int) + { -- | Where to process hints + optionsTarget :: Maybe FilePath, + -- | The refactorings to process + optionsRefactFile :: Maybe FilePath, + optionsInplace :: Bool, + -- | Whether to overwrite the file inplace + optionsOutput :: Maybe FilePath, + optionsVerbosity :: Verbosity, + -- | Ask before applying each hint + optionsStep :: Bool, + optionsDebug :: Bool, + optionsRoundtrip :: Bool, + optionsVersion :: Bool, + optionsLanguage :: [String], + optionsPos :: Maybe (Int, Int) } - options :: Parser Options options = do optionsTarget <- optional (argument str (metavar "TARGET")) - optionsRefactFile <- option (Just <$> str) $ mconcat - [ long "refact-file" - , value Nothing - , help $ "A file which specifies which refactorings to perform. " - ++ "If not specified, it will be read from stdin, in which case TARGET must be specified." - ] - optionsInplace <- switch $ mconcat - [ long "inplace" - , short 'i' - , help "Whether to overwrite the target inplace" - ] - optionsOutput <- optional . strOption $ mconcat - [ long "output" - , short 'o' - , help "Name of the file to output to" - , metavar "FILE" - ] - optionsVerbosity <- option (str >>= parseVerbosity) $ mconcat - [ long "verbosity" - , short 'v' - , value Normal - , help "Specify verbosity, 0, 1 or 2. The default is 1 and 0 is silent." - ] - optionsStep <- switch $ mconcat - [ short 's' - , long "step" - , help "Ask before applying each refactoring" - ] - optionsDebug <- switch $ mconcat - [ long "debug" - , help "Output the GHC AST for debugging" - , internal - ] - optionsRoundtrip <- switch $ mconcat - [ long "roundtrip" - , help "Run ghc-exactprint on the file" - , internal - ] - optionsVersion <- switch $ mconcat - [ long "version" - , help "Display version number" - ] - optionsLanguage <- many . strOption $ mconcat - [ long "language" - , short 'X' - , help "Language extensions (e.g. LambdaCase, RankNTypes)" - , metavar "Extensions" - ] - optionsPos <- option (Just <$> (str >>= parsePos)) $ mconcat - [ long "pos" - , value Nothing - , metavar "," - , help "Apply hints relevant to a specific position" - ] - pure Options{..} + optionsRefactFile <- + option (Just <$> str) $ + mconcat + [ long "refact-file", + value Nothing, + help $ + "A file which specifies which refactorings to perform. " + ++ "If not specified, it will be read from stdin, in which case TARGET must be specified." + ] + optionsInplace <- + switch $ + mconcat + [ long "inplace", + short 'i', + help "Whether to overwrite the target inplace" + ] + optionsOutput <- + optional . strOption $ + mconcat + [ long "output", + short 'o', + help "Name of the file to output to", + metavar "FILE" + ] + optionsVerbosity <- + option (str >>= parseVerbosity) $ + mconcat + [ long "verbosity", + short 'v', + value Normal, + help "Specify verbosity, 0, 1 or 2. The default is 1 and 0 is silent." + ] + optionsStep <- + switch $ + mconcat + [ short 's', + long "step", + help "Ask before applying each refactoring" + ] + optionsDebug <- + switch $ + mconcat + [ long "debug", + help "Output the GHC AST for debugging", + internal + ] + optionsRoundtrip <- + switch $ + mconcat + [ long "roundtrip", + help "Run ghc-exactprint on the file", + internal + ] + optionsVersion <- + switch $ + mconcat + [ long "version", + help "Display version number" + ] + optionsLanguage <- + many . strOption $ + mconcat + [ long "language", + short 'X', + help "Language extensions (e.g. LambdaCase, RankNTypes)", + metavar "Extensions" + ] + optionsPos <- + option (Just <$> (str >>= parsePos)) $ + mconcat + [ long "pos", + value Nothing, + metavar ",", + help "Apply hints relevant to a specific position" + ] + pure Options {..} optionsWithHelp :: ParserInfo Options -optionsWithHelp = info (helper <*> options) $ mconcat - [ fullDesc - , progDesc "Automatically perform refactorings on haskell source files" - , header "refactor" - ] +optionsWithHelp = + info (helper <*> options) $ + mconcat + [ fullDesc, + progDesc "Automatically perform refactorings on haskell source files", + header "refactor" + ] parseVerbosity :: Monad m => String -> m Verbosity -parseVerbosity = pure . \case - "0" -> Silent - "1" -> Normal - "2" -> Loud - _ -> Normal +parseVerbosity = + pure . \case + "0" -> Silent + "1" -> Normal + "2" -> Loud + _ -> Normal -parsePos :: MonadFail m => String -> m (Int, Int) +parsePos :: MonadFail' m => String -> m (Int, Int) parsePos s = case span isDigit s of - (line, ',':col) -> + (line, ',' : col) -> case (,) <$> readMaybe line <*> readMaybe col of Just l -> pure l Nothing -> fail "Invalid input" diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -2,43 +2,39 @@ module Refact.Run (refactMain, runPipe) where -import Language.Haskell.GHC.ExactPrint.Utils - -import Refact.Apply (parseExtensions) -import qualified Refact.Types as R -import Refact.Types hiding (SrcSpan) -import Refact.Fixity -import Refact.Internal - ( Verbosity(..) - , apply - , onError - , parseModuleWithArgs - ) -import Refact.Options (Options(..), optionsWithHelp) - import Control.Monad import Data.List hiding (find) import Data.Maybe import Data.Version +import Debug.Trace +import Language.Haskell.GHC.ExactPrint.Utils import Options.Applicative -import System.IO.Extra -import System.FilePath.Find +import Paths_apply_refact +import Refact.Apply (parseExtensions) +import Refact.Fixity +import Refact.Internal + ( Verbosity (..), + apply, + onError, + parseModuleWithArgs, + ) +import Refact.Options (Options (..), optionsWithHelp) +import Refact.Types hiding (SrcSpan) +import qualified Refact.Types as R import System.Exit +import System.FilePath.Find +import System.IO.Extra import qualified System.PosixCompat.Files as F -import Paths_apply_refact - -import Debug.Trace - refactMain :: IO () refactMain = do - o@Options{..} <- execParser optionsWithHelp + o@Options {..} <- execParser optionsWithHelp when optionsVersion (putStr ("v" ++ showVersion version) >> exitSuccess) unless (isJust optionsTarget || isJust optionsRefactFile) . die $ "Must specify either the target file, or the refact file, or both.\n" - ++ "If either the target file or the refact file is not specified, " - ++ "it will be read from stdin.\n" - ++ "To show usage, run 'refactor -h'." + ++ "If either the target file or the refact file is not specified, " + ++ "it will be read from stdin.\n" + ++ "To show usage, run 'refactor -h'." case optionsTarget of Nothing -> withTempFile $ \fp -> do @@ -70,10 +66,10 @@ where p x | "Setup.hs" `isInfixOf` x = False - | otherwise = True + | otherwise = True -runPipe :: Options -> FilePath -> IO () -runPipe Options{..} file = do +runPipe :: Options -> FilePath -> IO () +runPipe Options {..} file = do let verb = optionsVerbosity rawhints <- getHints optionsRefactFile when (verb == Loud) (traceM "Got raw hints") @@ -81,23 +77,27 @@ n = length inp when (verb == Loud) (traceM $ "Read " ++ show n ++ " hints") - output <- if null inp then readFileUTF8' file else do - when (verb == Loud) (traceM "Parsing module") - let (enabledExts, disabledExts, invalidExts) = parseExtensions optionsLanguage - unless (null invalidExts) . when (verb >= Normal) . putStrLn $ - "Invalid extensions: " ++ intercalate ", " invalidExts - (as, m) <- either (onError "runPipe") (uncurry applyFixities) - =<< parseModuleWithArgs (enabledExts, disabledExts) file - when optionsDebug (putStrLn (showAnnData as 0 m)) - apply optionsPos optionsStep inp (Just file) verb as m + output <- + if null inp + then readFileUTF8' file + else do + when (verb == Loud) (traceM "Parsing module") + let (enabledExts, disabledExts, invalidExts) = parseExtensions optionsLanguage + unless (null invalidExts) . when (verb >= Normal) . putStrLn $ + "Invalid extensions: " ++ intercalate ", " invalidExts + (as, m) <- + either (onError "runPipe") (uncurry applyFixities) + =<< parseModuleWithArgs (enabledExts, disabledExts) file + when optionsDebug (putStrLn (showAnnData as 0 m)) + apply optionsPos optionsStep inp (Just file) verb as m if optionsInplace && isJust optionsTarget then writeFileUTF8 file output else case optionsOutput of - Nothing -> putStr output - Just f -> do - when (verb == Loud) (traceM $ "Writing result to " ++ f) - writeFileUTF8 f output + Nothing -> putStr output + Just f -> do + when (verb == Loud) (traceM $ "Writing result to " ++ f) + writeFileUTF8 f output 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 @@ -1,195 +1,165 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Refact.Utils ( -- * Synonyms - Module - , Stmt - , Expr - , Decl - , Name - , Pat - , Type - , Import - , FunBind - , AnnKeyMap - , pattern RealSrcLoc' - , pattern RealSrcSpan' - -- * Monad - , M - -- * Utility +module Refact.Utils + ( -- * Synonyms + Module, + Stmt, + Expr, + Decl, + Name, + Pat, + Type, + Import, + FunBind, + AnnKeyMap, + pattern RealSrcLoc', + pattern RealSrcSpan', - , mergeAnns - , modifyAnnKey - , replaceAnnKey - , getAnnSpan - , toGhcSrcSpan - , toGhcSrcSpan' - , annSpanToSrcSpan - , srcSpanToAnnSpan - , setAnnSpanFile - , setSrcSpanFile - , setRealSrcSpanFile - , findParent - ) where + -- * Monad + M, -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types + -- * Utility + mergeAnns, + modifyAnnKey, + replaceAnnKey, + getAnnSpan, + toGhcSrcSpan, + toGhcSrcSpan', + annSpanToSrcSpan, + srcSpanToAnnSpan, + setAnnSpanFile, + setSrcSpanFile, + setRealSrcSpanFile, + findParent, + foldAnnKey, + ) +where +import Control.Monad.Trans.State (StateT, gets, modify) import Data.Bifunctor (bimap) import Data.Data -import Data.Map.Strict (Map) - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Data.FastString (FastString) -import qualified GHC.Data.FastString as GHC -import qualified GHC.Parser.Annotation as GHC -import qualified GHC.Types.Name.Reader as GHC -import GHC.Types.SrcLoc -import qualified GHC.Types.SrcLoc as GHC -#else -import FastString (FastString) -import qualified FastString as GHC -import SrcLoc -import qualified SrcLoc as GHC -import qualified RdrName as GHC -import qualified ApiAnnotation as GHC -#endif - -import qualified GHC hiding (parseModule) - -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs.Expr as GHC hiding (Stmt) -import GHC.Hs.ImpExp -#else -import HsExpr as GHC hiding (Stmt) -import HsImpExp -#endif - -import Control.Monad.Trans.State - -import qualified Data.Map as Map -import Data.Maybe - - + ( Data (gmapQi, toConstr), + Proxy (..), + splitTyConApp, + typeOf, + typeRep, + typeRepTyCon, + ) +import Data.Generics.Schemes (something) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Typeable (Typeable, eqT, (:~:) (Refl)) +import qualified GHC +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types +import Refact.Compat + ( AnnKeyMap, + AnnKeywordId (..), + FastString, + FunBind, + Module, + annSpanToSrcSpan, + mkFastString, + setAnnSpanFile, + setRealSrcSpanFile, + setSrcSpanFile, + srcSpanToAnnSpan, + pattern RealSrcLoc', + pattern RealSrcSpan', + ) import qualified Refact.Types as R - -import Data.Generics.Schemes -import Unsafe.Coerce - +import Unsafe.Coerce (unsafeCoerce) -- Types --- type M a = StateT (Anns, AnnKeyMap) IO a -type AnnKeyMap = Map AnnKey [AnnKey] - -#if __GLASGOW_HASKELL__ >= 900 -type Module = (GHC.Located GHC.HsModule) -#else -type Module = (GHC.Located (GHC.HsModule GHC.GhcPs)) -#endif - type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs) type Type = GHC.Located (GHC.HsType GHC.GhcPs) type Decl = GHC.Located (GHC.HsDecl GHC.GhcPs) -type Pat = GHC.Located (GHC.Pat GHC.GhcPs) +type Pat = GHC.Located (GHC.Pat GHC.GhcPs) type Name = GHC.Located GHC.RdrName -type Stmt = ExprLStmt GHC.GhcPs - -type Import = LImportDecl GHC.GhcPs - -#if __GLASGOW_HASKELL__ >= 900 -type FunBind = HsMatchContext GHC.GhcPs -#else -type FunBind = HsMatchContext GHC.RdrName -#endif - -pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc -#if __GLASGOW_HASKELL__ >= 900 -pattern RealSrcLoc' r <- RealSrcLoc r _ where - RealSrcLoc' r = RealSrcLoc r Nothing -#else -pattern RealSrcLoc' r <- RealSrcLoc r where - RealSrcLoc' r = RealSrcLoc r -#endif -{-# COMPLETE RealSrcLoc', UnhelpfulLoc #-} +type Stmt = GHC.ExprLStmt GHC.GhcPs -pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan -#if __GLASGOW_HASKELL__ >= 900 -pattern RealSrcSpan' r <- RealSrcSpan r _ where - RealSrcSpan' r = RealSrcSpan r Nothing -#else -pattern RealSrcSpan' r <- RealSrcSpan r where - RealSrcSpan' r = RealSrcSpan r -#endif -{-# COMPLETE RealSrcSpan', UnhelpfulSpan #-} +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 :: + 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 + 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} + 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 GHC.AnnComma - | AnnKey _ (CN "ArithSeq") <- newkey -> True - | otherwise -> False - AnnSemiSep -> False - _ -> True) + 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 GHC.AnnComma -> [x] - AnnSemiSep -> [x] - G GHC.AnnSemi -> [x] - _ -> [] + 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 - + 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 :: + 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 + | 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) @@ -197,59 +167,78 @@ ss = gmapQi 0 unsafeCoerce a cn = gmapQi 1 (CN . show . toConstr) a -getAnnSpan :: forall a. Located a -> AnnSpan -getAnnSpan = srcSpanToAnnSpan . getLoc - -srcSpanToAnnSpan :: SrcSpan -> AnnSpan -srcSpanToAnnSpan = -#if __GLASGOW_HASKELL__ >= 900 - \case GHC.RealSrcSpan l _ -> l; _ -> badRealSrcSpan -#else - id -#endif - -annSpanToSrcSpan :: AnnSpan -> SrcSpan -annSpanToSrcSpan = -#if __GLASGOW_HASKELL__ >= 900 - flip GHC.RealSrcSpan Nothing -#else - id -#endif +getAnnSpan :: forall a. GHC.Located a -> AnnSpan +getAnnSpan = srcSpanToAnnSpan . GHC.getLoc -- | Perform the necessary adjustments to annotations when replacing -- one Located thing with another Located thing. -- -- 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 -> Located old -> Located new -> M (Located new) +modifyAnnKey :: + (Data old, Data new, Data mod) => + 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 - ( recoverBackquotes e1 e2 + e2 + <$ modify + ( bimap + ( dropContextParens e1 e2 + . recoverBackquotes e1 e2 . replaceAnnKey (mkAnnKey e1) (mkAnnKey e2) (mkAnnKey e2) parentKey - ) - (Map.insertWith (++) (mkAnnKey e1) [mkAnnKey e2]) ) + (Map.insertWith (++) (mkAnnKey e1) [mkAnnKey e2]) + ) +-- | When parens are removed for the entire context, e.g., +-- +-- @ +-- - f :: (HasCallStack) => ... +-- + f :: HasCallStack => ... +-- @ +-- +-- 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 + 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 :: Located old -> Located new -> Anns -> Anns +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 GHC.AnnBackquote, DP (i, j)) - : rest@( (G GHC.AnnVal, _) - : (G GHC.AnnBackquote, _) - : _) - ) <- annsDP annOld - = let f annNew = case annsDP annNew of - [(G GHC.AnnVal, DP (i', j'))] -> - annNew {annsDP = (G GHC.AnnBackquote, DP (i + i', j + j')) : rest} + | 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 @@ -260,36 +249,21 @@ fromMaybe a (replace old new inp deltainfo a) -- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@ -toGhcSrcSpan :: FilePath -> R.SrcSpan -> SrcSpan -toGhcSrcSpan = toGhcSrcSpan' . GHC.mkFastString +toGhcSrcSpan :: FilePath -> R.SrcSpan -> GHC.SrcSpan +toGhcSrcSpan = toGhcSrcSpan' . mkFastString -- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@ -toGhcSrcSpan' :: FastString -> R.SrcSpan -> SrcSpan -toGhcSrcSpan' file R.SrcSpan{..} = mkSrcSpan (f startLine startCol) (f endLine endCol) - where - f = mkSrcLoc file - -setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan -setSrcSpanFile file s - | RealSrcLoc' start <- srcSpanStart s - , RealSrcLoc' end <- srcSpanEnd s - = let start' = mkSrcLoc file (srcLocLine start) (srcLocCol start) - end' = mkSrcLoc file (srcLocLine end) (srcLocCol end) - in mkSrcSpan start' end' -setSrcSpanFile _ s = s - -setRealSrcSpanFile :: FastString -> RealSrcSpan -> RealSrcSpan -setRealSrcSpanFile file s = mkRealSrcSpan start' end' +toGhcSrcSpan' :: FastString -> R.SrcSpan -> GHC.SrcSpan +toGhcSrcSpan' file R.SrcSpan {..} = GHC.mkSrcSpan (f startLine startCol) (f endLine endCol) where - start = realSrcSpanStart s - end = realSrcSpanEnd s - start' = mkRealSrcLoc file (srcLocLine start) (srcLocCol start) - end' = mkRealSrcLoc file (srcLocLine end) (srcLocCol end) + f = GHC.mkSrcLoc file -setAnnSpanFile :: FastString -> AnnSpan -> AnnSpan -setAnnSpanFile = -#if __GLASGOW_HASKELL__ >= 900 - setRealSrcSpanFile -#else - setSrcSpanFile -#endif +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 diff --git a/tests/examples/Bracket42.hs b/tests/examples/Bracket42.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket42.hs @@ -0,0 +1,2 @@ +foo :: (HasCallStack) => Int +foo = undefined diff --git a/tests/examples/Bracket42.hs.expected b/tests/examples/Bracket42.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket42.hs.expected @@ -0,0 +1,2 @@ +foo :: HasCallStack => Int +foo = undefined diff --git a/tests/examples/Bracket42.hs.refact b/tests/examples/Bracket42.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket42.hs.refact @@ -0,0 +1,1 @@ +[("tests/examples/Bracket42.hs:1:8-21: Warning: Redundant bracket\nFound:\n (HasCallStack)\nPerhaps:\n HasCallStack\n",[Replace {rtype = Type, pos = SrcSpan {startLine = 1, startCol = 8, endLine = 1, endCol = 22}, subts = [("x",SrcSpan {startLine = 1, startCol = 9, endLine = 1, endCol = 21})], orig = "x"}])] diff --git a/tests/examples/Bracket43.hs b/tests/examples/Bracket43.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket43.hs @@ -0,0 +1,2 @@ +foo :: ((Eq Int)) => Int +foo = undefined diff --git a/tests/examples/Bracket43.hs.expected b/tests/examples/Bracket43.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket43.hs.expected @@ -0,0 +1,2 @@ +foo :: (Eq Int) => Int +foo = undefined diff --git a/tests/examples/Bracket43.hs.refact b/tests/examples/Bracket43.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket43.hs.refact @@ -0,0 +1,1 @@ +[("tests/examples/Bracket43.hs:1:9-16: Suggestion: Redundant bracket\nFound:\n ((Eq Int))\nPerhaps:\n (Eq Int)\n",[Replace {rtype = Type, pos = SrcSpan {startLine = 1, startCol = 9, endLine = 1, endCol = 17}, subts = [("x",SrcSpan {startLine = 1, startCol = 10, endLine = 1, endCol = 16})], orig = "x"}])] diff --git a/tests/examples/Bracket44.hs b/tests/examples/Bracket44.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket44.hs @@ -0,0 +1,2 @@ +foo :: ((Eq) Int) => Int +foo = undefined diff --git a/tests/examples/Bracket44.hs.expected b/tests/examples/Bracket44.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket44.hs.expected @@ -0,0 +1,2 @@ +foo :: (Eq Int) => Int +foo = undefined diff --git a/tests/examples/Bracket44.hs.refact b/tests/examples/Bracket44.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket44.hs.refact @@ -0,0 +1,1 @@ +[("tests/examples/Bracket44.hs:1:9-12: Warning: Redundant bracket\nFound:\n (Eq)\nPerhaps:\n Eq\n",[Replace {rtype = Type, pos = SrcSpan {startLine = 1, startCol = 9, endLine = 1, endCol = 13}, subts = [("x",SrcSpan {startLine = 1, startCol = 10, endLine = 1, endCol = 12})], orig = "x"}])] diff --git a/tests/examples/Bracket45.hs b/tests/examples/Bracket45.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket45.hs @@ -0,0 +1,2 @@ +foo :: (Eq) (Int) => Int +foo = undefined diff --git a/tests/examples/Bracket45.hs.expected b/tests/examples/Bracket45.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket45.hs.expected @@ -0,0 +1,2 @@ +foo :: Eq Int => Int +foo = undefined diff --git a/tests/examples/Bracket45.hs.refact b/tests/examples/Bracket45.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket45.hs.refact @@ -0,0 +1,1 @@ +[("tests/examples/Bracket45.hs:1:8-11: Warning: Redundant bracket\nFound:\n (Eq)\nPerhaps:\n Eq\n",[Replace {rtype = Type, pos = SrcSpan {startLine = 1, startCol = 8, endLine = 1, endCol = 12}, subts = [("x",SrcSpan {startLine = 1, startCol = 9, endLine = 1, endCol = 11})], orig = "x"}]),("tests/examples/Bracket45.hs:1:13-17: Warning: Redundant bracket\nFound:\n (Int)\nPerhaps:\n Int\n",[Replace {rtype = Type, pos = SrcSpan {startLine = 1, startCol = 13, endLine = 1, endCol = 18}, subts = [("x",SrcSpan {startLine = 1, startCol = 14, endLine = 1, endCol = 17})], orig = "x"}])] diff --git a/tests/examples/Bracket46.hs b/tests/examples/Bracket46.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket46.hs @@ -0,0 +1,2 @@ +foo :: ((HasCallStack)) => Int +foo = undefined diff --git a/tests/examples/Bracket46.hs.expected b/tests/examples/Bracket46.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket46.hs.expected @@ -0,0 +1,2 @@ +foo :: HasCallStack => Int +foo = undefined diff --git a/tests/examples/Bracket46.hs.refact b/tests/examples/Bracket46.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket46.hs.refact @@ -0,0 +1,1 @@ +[("tests/examples/Bracket46.hs:1:8-23: Warning: Redundant bracket\nFound:\n ((HasCallStack))\nPerhaps:\n HasCallStack\n",[Replace {rtype = Type, pos = SrcSpan {startLine = 1, startCol = 8, endLine = 1, endCol = 24}, subts = [("x",SrcSpan {startLine = 1, startCol = 10, endLine = 1, endCol = 22})], orig = "x"}])]