apply-refact 0.9.2.0 → 0.9.3.0

raw patch · 24 files changed

+1722/−1412 lines, 24 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG +4/−0
• apply-refact.cabal +5/−2
• src/Refact/Apply.hs +28/−26
• src/Refact/Compat.hs +408/−0
• src/Refact/Fixity.hs +97/−117
• src/Refact/Internal.hs +826/−933
• src/Refact/Options.hs +109/−88
• src/Refact/Run.hs +40/−40
• src/Refact/Utils.hs +180/−206
• tests/examples/Bracket42.hs +2/−0
• tests/examples/Bracket42.hs.expected +2/−0
• tests/examples/Bracket42.hs.refact +1/−0
• tests/examples/Bracket43.hs +2/−0
• tests/examples/Bracket43.hs.expected +2/−0
• tests/examples/Bracket43.hs.refact +1/−0
• tests/examples/Bracket44.hs +2/−0
• tests/examples/Bracket44.hs.expected +2/−0
• tests/examples/Bracket44.hs.refact +1/−0
• tests/examples/Bracket45.hs +2/−0
• tests/examples/Bracket45.hs.expected +2/−0
• tests/examples/Bracket45.hs.refact +1/−0
• tests/examples/Bracket46.hs +2/−0
• tests/examples/Bracket46.hs.expected +2/−0
• tests/examples/Bracket46.hs.refact +1/−0

@@ -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

@@ -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

@@ -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   -- <https://hackage.haskell.org/package/hlint/docs/Language-Haskell-HLint.html#t:Idea Idea>.   -- 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

@@ -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

@@ -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)

@@ -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 #-}

@@ -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 "<line>,<col>"-    , 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 "<line>,<col>",+          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"

@@ -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

@@ -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

@@ -0,0 +1,2 @@+foo :: (HasCallStack) => Int+foo = undefined

@@ -0,0 +1,2 @@+foo :: HasCallStack => Int+foo = undefined

@@ -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"}])]

@@ -0,0 +1,2 @@+foo :: ((Eq Int)) => Int+foo = undefined

@@ -0,0 +1,2 @@+foo :: (Eq Int) => Int+foo = undefined

@@ -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"}])]

@@ -0,0 +1,2 @@+foo :: ((Eq) Int) => Int+foo = undefined

@@ -0,0 +1,2 @@+foo :: (Eq Int) => Int+foo = undefined

@@ -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"}])]

@@ -0,0 +1,2 @@+foo :: (Eq) (Int) => Int+foo = undefined

@@ -0,0 +1,2 @@+foo :: Eq Int => Int+foo = undefined

@@ -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"}])]

@@ -0,0 +1,2 @@+foo :: ((HasCallStack)) => Int+foo = undefined

@@ -0,0 +1,2 @@+foo :: HasCallStack => Int+foo = undefined

@@ -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"}])]