apply-refact 0.8.2.1 → 0.9.0.0

raw patch · 40 files changed

+856/−509 lines, 40 filesdep +uniplatedep ~basedep ~containersdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: uniplate

Dependency ranges changed: base, containers, directory, extra, filemanip, ghc, ghc-boot-th, ghc-exactprint, process, refact, syb, transformers, unix-compat

API changes (from Hackage documentation)

Files

• CHANGELOG +16/−0
• apply-refact.cabal +40/−33
• src/Main.hs +2/−3
• src/Refact/Apply.hs +52/−12
• src/Refact/Fixity.hs +7/−8
• src/Refact/Internal.hs +470/−249
• src/Refact/Options.hs +115/−0
• src/Refact/Run.hs +19/−179
• src/Refact/Utils.hs +45/−12
• tests/Test.hs +14/−13
• tests/examples/Backquotes.hs +1/−0
• tests/examples/Backquotes.hs.expected +1/−0
• tests/examples/Backquotes.hs.refact +1/−0
• tests/examples/Bracket39.hs +1/−0
• tests/examples/Bracket39.hs.expected +1/−0
• tests/examples/Bracket39.hs.refact +1/−0
• tests/examples/Bracket40.hs +1/−0
• tests/examples/Bracket40.hs.expected +1/−0
• tests/examples/Bracket40.hs.refact +1/−0
• tests/examples/Bracket41.hs +1/−0
• tests/examples/Bracket41.hs.expected +1/−0
• tests/examples/Bracket41.hs.refact +1/−0
• tests/examples/Comment10.hs +11/−0
• tests/examples/Comment10.hs.expected +11/−0
• tests/examples/Comment10.hs.refact +1/−0
• tests/examples/Comment7.hs +6/−0
• tests/examples/Comment7.hs.expected +6/−0
• tests/examples/Comment7.hs.refact +1/−0
• tests/examples/Comment8.hs +2/−0
• tests/examples/Comment8.hs.expected +2/−0
• tests/examples/Comment8.hs.refact +1/−0
• tests/examples/Comment9.hs +2/−0
• tests/examples/Comment9.hs.expected +2/−0
• tests/examples/Comment9.hs.refact +1/−0
• tests/examples/EtaReduceLocalTypeSig.hs +4/−0
• tests/examples/EtaReduceLocalTypeSig.hs.expected +4/−0
• tests/examples/EtaReduceLocalTypeSig.hs.refact +1/−0
• tests/examples/lambda42.hs +4/−0
• tests/examples/lambda42.hs.expected +4/−0
• tests/examples/lambda42.hs.refact +1/−0

@@ -1,3 +1,19 @@++v0.9.0.0++  * #106, expose Refact.Internal+  * #104, ensure space between "do" and the next identifier+  * support GHC 8.10.3+  * #101, do not apply a refactoring if it drops comments+  * #100, add applyRefactorings', which is like applyRefactoring, but takes a parsed module and annotations, rather than a FilePath to parse+  * #98, make applyRefactoring take a list of GHC extensions+  * #97, fix a bug where backquotes surrounding substitution variables are dropped after substitution+  * #85, show actual type (if any) if expected type is not found+  * #84, improve error message of findGen+  * #81, remove hint description from the input of applyRefactorings+  * #79, improve error message when neither target nor refact file is specified+  * #78, remove some exported functions in Refact.Apply that are only relevant to runPipe+ v0.8.2.1    * support GHC 8.8.4

@@ -1,24 +1,24 @@--- Initial hlint-refactor.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/+cabal-version:       2.4  name:                apply-refact-version:             0.8.2.1+version:             0.9.0.0 synopsis:            Perform refactorings specified by the refact library. description:         Perform refactorings specified by the refact library. It is primarily used with HLint's --refactor flag.-license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Matthew Pickering maintainer:          matthewtpickering@gmail.com -- copyright: category:            Development+homepage:            https://github.com/mpickering/apply-refact+bug-reports:         https://github.com/mpickering/apply-refact/issues build-type:          Simple extra-source-files:  CHANGELOG                    , README.md                    , tests/examples/*.hs                    , tests/examples/*.hs.refact                    , tests/examples/*.hs.expected-cabal-version:       >=1.10-tested-with:         GHC == 8.10.1, GHC == 8.8.4, GHC == 8.6.5+tested-with:         GHC == 8.10.3, GHC == 8.8.4, GHC == 8.6.5   source-repository head@@ -29,20 +29,23 @@   exposed-modules:   Refact.Utils                    , Refact.Apply                    , Refact.Fixity-  other-modules: Refact.Internal+                   , Refact.Internal   GHC-Options: -Wall   build-depends: base >=4.12 && < 5                , refact >= 0.2-               , ghc-exactprint >= 0.6.3.2+               , ghc-exactprint >= 0.6.3.3                , ghc >= 8.6-               , containers >= 0.6.0.1+               , ghc-boot-th+               , containers >= 0.6.0.1 && < 0.7                , extra >= 1.7.3-               , syb-               , process-               , transformers-               , filemanip-               , unix-compat-               , directory+               , syb >= 0.7.1+               , process >= 1.6+               , transformers >= 0.5.6.2 && < 0.6+               , filemanip >= 0.3.6.3 && < 0.4+               , uniplate >= 1.6.13+               , unix-compat >= 0.5.2+               , directory >= 1.3+               , uniplate >= 1.6.13   hs-source-dirs:      src   default-language:    Haskell2010 @@ -53,18 +56,21 @@                  Refact.Apply                  Refact.Fixity                  Refact.Internal-                 Refact.Utils+                 Refact.Options                  Refact.Run+                 Refact.Utils+  autogen-modules:+                 Paths_apply_refact   hs-source-dirs:      src   default-language: Haskell2010   ghc-options: -Wall -fno-warn-unused-do-bind-  build-depends: base >= 4.12 && < 5-               , refact >= 0.2-               , ghc-exactprint >= 0.6.3.2-               , ghc >= 8.6-               , ghc-boot-th >= 8.6-               , containers >= 0.6.0.1-               , extra >= 1.7.3+  build-depends: base+               , refact+               , ghc-exactprint+               , ghc+               , ghc-boot-th+               , containers+               , extra                , syb                , process                , directory@@ -73,6 +79,7 @@                , unix-compat                , filepath                , transformers+               , uniplate  Test-Suite test   type:                exitcode-stdio-1.0@@ -80,25 +87,24 @@   main-is:             Test.hs   other-modules:                  Paths_apply_refact-                 Refact.Run                  Refact.Apply                  Refact.Fixity                  Refact.Internal+                 Refact.Options+                 Refact.Run                  Refact.Utils   GHC-Options:         -threaded   Default-language:    Haskell2010-  if impl (ghc < 7.10)-      buildable: False   Build-depends:       tasty                      , tasty-golden                      , tasty-expected-failure-                     , base < 5-               , refact >= 0.2-               , ghc-exactprint >= 0.6.3.2-               , ghc >= 8.6-               , ghc-boot-th >= 8.6-               , containers >= 0.6.0.1-               , extra >= 1.7.3+                     , base+               , refact+               , ghc-exactprint+               , ghc+               , ghc-boot-th+               , containers+               , extra                , syb                , process                , directory@@ -108,3 +114,4 @@                , filepath                , silently                , transformers+               , uniplate

@@ -1,7 +1,6 @@-module Main where+module Main (main) where -import Refact.Run+import Refact.Run (refactMain)  main :: IO () main = refactMain-

@@ -1,17 +1,57 @@-{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE TupleSections #-}  module Refact.Apply-  ( runRefactoring-  , applyRefactorings--  -- * Support for runPipe in the main process-  , Verbosity(..)-  , rigidLayout-  , removeOverlap-  , refactOptions-  , type Errors-  , onError-  , mkErr+  ( applyRefactorings+  , applyRefactorings'+  , runRefactoring+  , parseExtensions   ) where +import Control.Monad (unless)+import Data.List (intercalate)+import Language.Haskell.GHC.ExactPrint.Types (Anns)+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+  -- <https://hackage.haskell.org/package/hlint/docs/Language-Haskell-HLint.html#t:Idea Idea>.+  -- An @Idea@ may have more than one 'Refactoring'.+  --+  -- The @Idea@s are sorted in ascending order of starting location, and are applied+  -- 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+  -- 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+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+  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+  -- 'Language.Haskell.GHC.ExactPrint.Parsers.postParseTransform'.+  -> Module+  -- ^ Parsed module+  -> IO String+applyRefactorings' optionsPos inp = apply optionsPos False ((mempty,) <$> inp) Nothing Silent

@@ -29,11 +29,10 @@  -- | Rearrange infix expressions to account for fixity. -- The set of fixities is wired in and includes all fixities in base.-applyFixities :: Anns -> Module -> (Anns, Module)-applyFixities as m = let (as', m') = swap $ runState (everywhereM (mkM expFix) m) as-                     in (as', m') --error (showAnnData as 0 m ++ showAnnData as' 0 m')+applyFixities :: Anns -> Module -> IO (Anns, Module)+applyFixities as m = swap <$> runStateT (everywhereM (mkM expFix) m) as -expFix :: LHsExpr GhcPs -> M (LHsExpr GhcPs)+expFix :: LHsExpr GhcPs -> StateT Anns IO (LHsExpr GhcPs) expFix (L loc (OpApp _ l op r)) =   mkOpAppRn baseFixities loc l op (findFixity baseFixities op) r @@ -49,7 +48,7 @@ --    from 'e12' to '(e12 `op2` e2)'. --  * When rewriting '(- neg_arg) `op` e2' into '- (neg_arg `op` e2)', move the delta position --    from 'neg_arg' to '(neg_arg `op` e2)'.-moveDelta :: Annotation -> AnnKey -> AnnKey -> M ()+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]@@ -72,7 +71,7 @@           -> LHsExpr GhcPs -> Fixity    -- Operator and fixity           -> LHsExpr GhcPs              -- Right operand (not an OpApp, but might                                         -- be a NegApp)-          -> M (LHsExpr GhcPs)+          -> StateT Anns IO (LHsExpr GhcPs)  -- (e11 `op1` e12) `op2` e2 mkOpAppRn fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2@@ -109,8 +108,8 @@           ak  = AnnKey loc (CN "OpApp")       opAnn <- gets (fromMaybe annNone . Map.lookup ak)       negAnns <- gets (fromMaybe annNone . Map.lookup (mkAnnKey e1))-      modify (Map.insert key (annNone { annEntryDelta = annEntryDelta opAnn, annsDP = annsDP negAnns }))-      modify (Map.delete (mkAnnKey e1))+      modify $ Map.insert key (annNone { annEntryDelta = annEntryDelta opAnn, annsDP = annsDP negAnns })+      modify $ Map.delete (mkAnnKey e1)       return res    where

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-}@@ -12,41 +11,54 @@ module Refact.Internal   ( apply   , runRefactoring-  , applyRefactorings+  , addExtensionsToFlags+  , parseModuleWithArgs+  , parseExtensions    -- * Support for runPipe in the main process   , Verbosity(..)   , rigidLayout-  , removeOverlap   , refactOptions   , type Errors   , onError   , mkErr   )  where -import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Annotate-import Language.Haskell.GHC.ExactPrint.Delta-import Language.Haskell.GHC.ExactPrint.Parsers-import Language.Haskell.GHC.ExactPrint.Print-import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn)-import Language.Haskell.GHC.ExactPrint.Utils--import Control.Arrow+import Control.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 hiding (GT)+import Data.Generics (everywhereM, extM, listify, mkM, mkQ, something)+import Data.Generics.Uniplate.Data (transformBi, transformBiM, universeBi) import qualified Data.Map as Map-import Data.Maybe-import Data.List-import Data.Ord-import System.IO-import System.IO.Unsafe+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 DynFlags hiding (initDynFlags)+import FastString (unpackFS)+import HeaderInfo (getOptions)+import HscTypes (handleSourceError)+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+import Panic (handleGhcException)+import StringBuffer (stringToStringBuffer)+import System.IO.Error (mkIOError)+import System.IO.Extra  import Debug.Trace @@ -54,7 +66,6 @@ import GHC.Hs.Expr as GHC hiding (Stmt) import GHC.Hs.ImpExp import GHC.Hs hiding (Pat, Stmt)-import Outputable hiding ((<>)) import ErrUtils import Bag #else@@ -63,16 +74,16 @@ import HsSyn hiding (Pat, Stmt, noExt) #endif -import SrcLoc+import Outputable hiding ((<>))+import SrcLoc hiding (spans) import qualified GHC hiding (parseModule) import qualified Name as GHC import qualified RdrName as GHC -import Refact.Fixity import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R-import Refact.Utils (Stmt, Pat, Name, Decl, M, Module, Expr, Type, FunBind-                    , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, setSrcSpanFile)+import Refact.Utils (Stmt, Pat, Name, Decl, M, Module, Expr, Type, FunBind, AnnKeyMap+                    , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, toGhcSrcSpan', setSrcSpanFile)  #if __GLASGOW_HASKELL__ >= 810 type Errors = ErrorMessages@@ -107,95 +118,53 @@   :: Maybe (Int, Int)   -> Bool   -> [(String, [Refactoring R.SrcSpan])]-  -> FilePath+  -> Maybe FilePath   -> Verbosity   -> Anns   -> Module   -> IO String-apply mpos step inp file verb as0 m0 = do-  let noOverlapInp = removeOverlap verb inp-      allRefacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp+apply mpos step inp mbfile verb as0 m0 = do+  toGhcSS <-+    maybe+      ( case getLoc m0 of+          UnhelpfulSpan s -> fail $ "Module has UnhelpfulSpan: " ++ unpackFS 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 -      posFilter (_, rs) =-        case mpos of-          Nothing -> True-          Just p  -> any (flip spans p . pos) rs-      filtRefacts = filter posFilter allRefacts-      refacts = concatMap snd filtRefacts+      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 (length refacts) ++ " hints")-  when (verb == Loud) (traceM $ show filtRefacts)+  when (verb >= Normal) . traceM $+    "Applying " ++ (show . sum . map (length . snd . fst) $ allRefacts) ++ " hints"+  when (verb == Loud) . traceM $ show (map fst allRefacts) -  -- need a check here to avoid overlap   (as, m) <- if step-               then fromMaybe (as0, m0) <$> runMaybeT (refactoringLoop as0 m0 filtRefacts)-               else pure . flip evalState 0 $-                      foldM (uncurry runRefactoring) (as0, m0) refacts+               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 -data LoopOption = LoopOption-                    { desc :: String-                    , perform :: MaybeT IO (Anns, Module) }--refactoringLoop :: Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])]-                -> MaybeT IO (Anns, Module)-refactoringLoop as m [] = pure (as, m)-refactoringLoop as m ((_, []): rs) = refactoringLoop as m rs-refactoringLoop as m hints@((hintDesc, rs): rss) =-  do inp <- liftIO $ do-        putStrLn hintDesc-        putStrLn $ "Apply hint [" ++ intercalate ", " (map fst opts) ++ "]"-        -- In case that the input also comes from stdin-        withFile "/dev/tty" ReadMode hGetLine-     maybe loopHelp perform (lookup inp opts)-  where-    opts =-      [ ("y", LoopOption "Apply current hint" yAction)-      , ("n", LoopOption "Don't apply the current hint" (refactoringLoop as m rss))-      , ("q", LoopOption "Apply no further hints" (return (as, m)))-      , ("d", LoopOption "Discard previous changes" mzero )-      , ("v", LoopOption "View current file" (liftIO (putStrLn (exactPrint m as))-                                              >> refactoringLoop as m hints))-      , ("?", LoopOption "Show this help menu" loopHelp)]-    loopHelp = do-            liftIO . putStrLn . unlines . map mkLine $ opts-            refactoringLoop as m hints-    mkLine (c, opt) = c ++ " - " ++ desc opt-    -- Force to force bottoms-    yAction =-      let (!r1, !r2) = flip evalState 0 $ foldM (uncurry runRefactoring) (as, m) rs-        in do-          exactPrint r2 r1 `seq` return ()-          refactoringLoop r1 r2 rss---- | Apply a set of refactorings as supplied by hlint-applyRefactorings-  :: Maybe (Int, Int)-  -- ^ Apply hints relevant to a specific position-  -> [(String, [Refactoring R.SrcSpan])]-  -- ^ A list of (hint description, refactorings) pairs.-  -> FilePath-  -- ^ Target file-  -> IO String-applyRefactorings optionsPos inp file = do-  (as, m) <- either (onError "apply") (uncurry applyFixities)-              <$> parseModuleWithOptions rigidLayout file-  apply optionsPos False inp file Silent as m--data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord)+spans :: R.SrcSpan -> (Int, Int) -> Bool+spans R.SrcSpan{..} loc = (startLine, startCol) <= loc && loc <= (endLine, endCol) --- Filters out overlapping ideas, picking the first idea in a set of overlapping ideas.--- If two ideas start in the exact same place, pick the largest edit.-removeOverlap :: Verbosity -> [(String, [Refactoring R.SrcSpan])] -> [(String, [Refactoring R.SrcSpan])]-removeOverlap verb = dropOverlapping . sortBy f . summarize+aggregateSrcSpans :: [R.SrcSpan] -> Maybe R.SrcSpan+aggregateSrcSpans = \case+  [] -> Nothing+  rs -> Just (foldr1 alg rs)   where-    -- We want to consider all Refactorings of a single idea as a unit, so compute a summary-    -- SrcSpan that encompasses all the Refactorings within each idea.-    summarize :: [(String, [Refactoring R.SrcSpan])] -> [(String, (R.SrcSpan, [Refactoring R.SrcSpan]))]-    summarize ideas = [ (s, (foldr1 summary (map pos rs), rs)) | (s, rs) <- ideas, not (null rs) ]--    summary (R.SrcSpan sl1 sc1 el1 ec1)-            (R.SrcSpan sl2 sc2 el2 ec2) =+    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)@@ -204,55 +173,119 @@                       LT -> (el2, ec2)                       EQ -> (el2, max ec1 ec2)                       GT -> (el1, ec1)-      in R.SrcSpan sl sc el ec+       in R.SrcSpan sl sc el ec -    -- Order by span start. If starting in same place, order by size.-    f (_,(s1,_)) (_,(s2,_)) =-      comparing startLine s1 s2 <> -- s1 first if it starts on earlier line-      comparing startCol s1 s2 <>  --             or on earlier column-      comparing endLine s2 s1 <>   -- they start in same place, s2 comes-      comparing endCol s2 s1       -- first if it ends later-      -- else, completely same span, so s1 will be first+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) -    dropOverlapping [] = []-    dropOverlapping (p:ps) = go p ps-    go (s,(_,rs)) [] = [(s,rs)]-    go p@(s,(_,rs)) (x:xs)-      | p `overlaps` x = (if verb > Silent-                          then trace ("Ignoring " ++ show (snd (snd x)) ++ " due to overlap.")-                          else id) go p xs-      | otherwise = (s,rs) : go x xs-    -- for overlaps, we know s1 always starts <= s2, due to our sort-    overlaps (_,(s1,_)) (_,(s2,_)) =-      case compare (startLine s2) (endLine s1) of-        LT -> True-        EQ -> startCol s2 <= endCol s1-        GT -> False+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 -getSeed :: State Int Int-getSeed = get <* modify (+1)- -- | Peform a @Refactoring@.-runRefactoring :: Data a => Anns -> a -> Refactoring GHC.SrcSpan -> State Int (Anns, a)-runRefactoring as m r@Replace{}  = do-  seed <- getSeed-  return $ case rtype r of-    Expr -> replaceWorker as m parseExpr seed r-    Decl -> replaceWorker as m parseDecl seed r-    Type -> replaceWorker as m parseType seed r-    Pattern -> replaceWorker as m parsePattern seed r-    Stmt -> replaceWorker as m parseStmt seed r-    Bind -> replaceWorker as m parseBind seed r-    R.Match ->  replaceWorker as m parseMatch seed r-    ModuleName -> replaceWorker as m (parseModuleName (pos r)) seed r-    Import -> replaceWorker as m parseImport seed r+runRefactoring+  :: 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 -runRefactoring as m ModifyComment{..} =-    return (Map.map go as, m)+  ModifyComment{..} -> pure (Map.map go as, m, keyMap)     where       go a@Ann{ annPriorComments, annsDP } =         a { annsDP = map changeComment annsDP@@ -262,27 +295,38 @@       change old@Comment{..}= if ss2pos commentIdentifier == ss2pos pos                                           then old { commentContents = newComment}                                           else old-runRefactoring as m Delete{rtype, pos} = do-  let f = case rtype of-            Stmt -> doDeleteStmt ((/= pos) . getLoc)-            Import -> doDeleteImport ((/= pos) . getLoc)-            _ -> id-  return (as, f m)-  {--runRefactoring as m Rename{nameSubts} = (as, m)-  --(as, doRename nameSubts m)- -}-runRefactoring as m InsertComment{..} =-  let exprkey = mkAnnKey (findDecl m pos) in-  return (insertComment exprkey newComment as, m)-runRefactoring as m RemoveAsKeyword{..} =-  return (as, removeAsKeyword m)+  Delete{rtype, pos} -> pure (as, f m, keyMap)+    where+      f = case rtype of+        Stmt -> doDeleteStmt ((/= pos) . getLoc)+        Import -> doDeleteImport ((/= pos) . getLoc)+        _ -> id++  InsertComment{..} -> do+    exprkey <- mkAnnKey <$> findOrError @(HsDecl GhcPs) m 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)+        | l == 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-    removeAsKeyword = everywhere (mkT go)-    go :: LImportDecl GHC.GhcPs -> LImportDecl GHC.GhcPs-    go imp@(GHC.L l i)  | l == pos = GHC.L l (i { ideclAs = Nothing })-                    | otherwise =  imp+    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 SrcSpan+    allSpans = Set.fromList (universeBi m)+ -- Specialised parsers mkErr :: GHC.DynFlags -> SrcSpan -> String -> Errors #if __GLASGOW_HASKELL__ >= 810@@ -291,11 +335,11 @@ mkErr = const (,) #endif -parseModuleName :: GHC.SrcSpan -> Parser (GHC.Located GHC.ModuleName)+parseModuleName :: SrcSpan -> Parser (GHC.Located GHC.ModuleName) parseModuleName ss _ _ s =   let newMN =  GHC.L ss (GHC.mkModuleName s)       newAnns = relativiseApiAnns newMN (Map.empty, Map.empty)-  in return (newAnns, newMN)+  in pure (newAnns, newMN) parseBind :: Parser (GHC.LHsBind GHC.GhcPs) parseBind dyn fname s =   case parseDecl dyn fname s of@@ -316,7 +360,7 @@ -- 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 :: (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@@ -324,26 +368,25 @@                                     `extM` exprSub m ss                                     ) -stmtSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Stmt -> M Stmt+stmtSub :: Data a => a -> [(String, SrcSpan)] -> Stmt -> M Stmt stmtSub m subs old@(GHC.L _ (BodyStmt _ (GHC.L _ (HsVar _ (L _ name))) _ _) ) =-  resolveRdrName m (findStmt m) old subs name-stmtSub _ _ e = return e+  resolveRdrName m (findOrError m) old subs name+stmtSub _ _ e = pure e -patSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Pat -> M Pat+patSub :: Data a => a -> [(String, SrcSpan)] -> Pat -> M Pat patSub m subs old@(GHC.L _ (VarPat _ (L _ name))) =-  resolveRdrName m (findPat m) old subs name-patSub _ _ e = return e+  resolveRdrName m (findOrError m) old subs name+patSub _ _ e = pure e -typeSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Type -> M Type+typeSub :: Data a => a -> [(String, SrcSpan)] -> Type -> M Type typeSub m subs old@(GHC.L _ (HsTyVar _ _ (L _ name))) =-  resolveRdrName m (findType m) old subs name-typeSub _ _ e = return e+  resolveRdrName m (findOrError m) old subs name+typeSub _ _ e = pure e -exprSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Expr -> M Expr+exprSub :: Data a => a -> [(String, SrcSpan)] -> Expr -> M Expr exprSub m subs old@(GHC.L _ (HsVar _ (L _ name))) =-  resolveRdrName m (findExpr m) old subs name-exprSub _ _ e = return e-+  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@@ -352,9 +395,9 @@ -- 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 :: Data a => a -> [(String, SrcSpan)] -> FunBind -> M FunBind identSub m subs old@(GHC.FunRhs (GHC.L _ name) _ _) =-  resolveRdrName' subst (findName m) old subs name+  resolveRdrName' subst (findOrError m) old subs name   where     subst :: FunBind -> Name -> M FunBind     subst (GHC.FunRhs n b s) new = do@@ -362,19 +405,19 @@           fakeExpr = GHC.L (getLoc new) (GHC.VarPat noExt new)       -- Low level version as we need to combine the annotation information       -- from the template RdrName and the original VarPat.-      modify (\r -> replaceAnnKey r (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr))-      return $ GHC.FunRhs new b s-    subst o _ = return o-identSub _ _ e = return e-+      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-               -> (SrcSpan -> b)    -- How to find the new value, when given the location it is in+               -> (SrcSpan -> 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+               -> [(String, SrcSpan)] -- Substs                -> GHC.RdrName       -- The name of the position in the template                                     --we are replacing into                -> M a@@ -382,14 +425,12 @@   case name of     -- Todo: this should replace anns as well?     GHC.Unqual (GHC.occNameString . GHC.occName -> oname)-      -> case lookup oname subs of-              Just (f -> new) -> g old new-              Nothing -> return old-    _ -> return old+      | Just ss <- lookup oname subs -> f ss >>= g old+    _ -> pure old  resolveRdrName :: (Data old, Data a)                => a-               -> (SrcSpan -> Located old)+               -> (SrcSpan -> M (Located old))                -> Located old                -> [(String, SrcSpan)]                -> GHC.RdrName@@ -413,7 +454,7 @@   -> (GHC.Located ast -> Bool)   -> GHC.Located ast   -> GHC.Located ast-  -> State (Anns, Bool) (GHC.Located ast)+  -> StateT ((Anns, AnnKeyMap), Bool) IO (GHC.Located ast) #else doGenReplacement   :: forall ast a. (Data (SrcSpanLess ast), HasSrcSpan ast, Data a)@@ -421,15 +462,15 @@   -> (ast -> Bool)   -> ast   -> ast-  -> State (Anns, Bool) ast+  -> StateT ((Anns, AnnKeyMap), Bool) IO ast #endif doGenReplacement m p new old   | p old = do-      anns <- gets fst+      (anns, keyMap) <- gets fst       let n = decomposeSrcSpan new           o = decomposeSrcSpan old-          newAnns = execState (modifyAnnKey m o n) anns-      put (newAnns, True)+      (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.@@ -439,12 +480,12 @@   , Just (oldNoLocal, oldLocal) <- stripLocalBind (decomposeSrcSpan old)   , newLoc@(RealSrcSpan newLocReal) <- getLoc new   , p (composeSrcSpan oldNoLocal) = do-      anns <- gets fst+      (anns, keyMap) <- gets fst       let n = decomposeSrcSpan new           o = decomposeSrcSpan old-          intAnns = execState (modifyAnnKey m o n) anns-          newFile = srcSpanFile newLocReal-          newLocal = everywhere (mkT $ setSrcSpanFile newFile) oldLocal+      (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@@ -474,8 +515,12 @@                 in fromMaybe oldAnns $ do                       oldAnn <- snd <$> find po oldAnns'                       annWhere <- find ((== G GHC.AnnWhere) . fst) (annsDP oldAnn)+                      let newSortKey = fmap (setSrcSpanFile newFile) <$> annSortKey oldAnn                       newKey <- fst <$> find pn oldAnns'-                      pure $ Map.adjust (\ann -> ann {annsDP = annsDP ann ++ [annWhere]}) newKey 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@@ -496,7 +541,7 @@                 other -> other            newAnns = addLocalBindsToAnns intAnns-      put (newAnns, True)+      put ((newAnns, newKeyMap), True)       pure $ composeSrcSpan newWithLocalBinds   | otherwise = pure old @@ -542,36 +587,46 @@ replaceWorker :: (Annotate a, Data mod)               => Anns               -> mod+              -> AnnKeyMap               -> Parser (GHC.Located a)               -> Int-              -> Refactoring GHC.SrcSpan-              -> (Anns, mod)+              -> Refactoring SrcSpan+              -> IO (Anns, mod, AnnKeyMap) #else replaceWorker :: (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a))               => Anns               -> mod+              -> AnnKeyMap               -> Parser a               -> Int-              -> Refactoring GHC.SrcSpan-              -> (Anns, mod)+              -> Refactoring SrcSpan+              -> IO (Anns, mod, AnnKeyMap) #endif-replaceWorker as m parser seed Replace{..} =+replaceWorker as m keyMap parser seed Replace{..} = do   let replExprLocation = pos       uniqueName = "template" ++ show seed-      p s = unsafePerformIO (withDynFlags (\d -> parser d uniqueName s))-      (relat, template) = case p orig of-                              Right xs -> xs-                              Left err -> onError "replaceWorked" err -      (newExpr, newAnns) = runState (substTransform m subts template) (mergeAnns as relat)-      lst = listToMaybe . reverse . GHC.occNameString . GHC.rdrNameOcc+  (relat, template) <- withDynFlags (\d -> parser d uniqueName orig) >>=+    either (onError "replaceWorked") pure++  (newExpr, (newAnns, newKeyMap)) <-+    runStateT+      (substTransform m subts template)+      (mergeAnns as relat, keyMap)+  let lst = listToMaybe . reverse . GHC.occNameString . GHC.rdrNameOcc       adjacent (srcSpanEnd -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) = loc1 == loc2       adjacent _ _ = False -      -- Ensure that there is a space between two alphanumeric names, otherwise-      -- 'y = f(x)' would be refactored into 'y = fx'.-      ensureSpace :: Anns -> Anns-      ensureSpace = fromMaybe id $ do+      -- 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+      diffStartCols x (srcSpanStart -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) =+        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@@ -592,53 +647,92 @@             then ann { annEntryDelta = DP (0, 1) }             else ann -      replacementPred (GHC.L l _) = l == replExprLocation-      transformation = everywhereM (mkM (doGenReplacement m (replacementPred . decomposeSrcSpan) newExpr))-   in case runState (transformation m) (newAnns, False) of-        (finalM, (finalAs, True)) -> (ensureSpace finalAs, finalM)-        -- Failed to find a replacment so don't make any changes-        _ -> (as, m)-replaceWorker as m _ _ _  = (as, m)---- Find the largest expression with a given SrcSpan-findGen :: forall ast a . (Data ast, Data a) => String -> a -> SrcSpan -> GHC.Located ast-findGen s m ss = fromMaybe (error (s ++ " " ++ showGhc ss)) (doTrans m)-  where-    doTrans :: a -> Maybe (GHC.Located ast)-    doTrans = something (mkQ Nothing (findLargestExpression ss))+      -- 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 -findExpr :: Data a => a -> SrcSpan -> Expr-findExpr = findGen "expr"+      replacementPred (GHC.L l _) = l == replExprLocation+      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) -findPat :: Data a => a -> SrcSpan -> Pat-findPat = findGen "pat"+data NotFound = NotFound+  { nfExpected :: String+  , nfActual :: Maybe String+  , nfLoc :: SrcSpan+  } -findType :: Data a => a -> SrcSpan -> Type-findType = findGen "type"+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) -findDecl :: Data a => a -> SrcSpan -> Decl-findDecl = findGen "decl"+-- Find a given type with a given SrcSpan+findInModule :: forall a modu. (Data a, Data modu) => modu -> SrcSpan -> 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)) -findStmt :: Data a => a -> SrcSpan -> Stmt-findStmt = findGen "stmt"+    showType :: forall b. Typeable b => Maybe (GHC.Located b) -> Maybe String+    showType = fmap $ \_ -> show (typeRep (Proxy @b)) -findName :: Data a => a -> SrcSpan -> Name-findName = findGen "name"+findLargestExpression :: SrcSpan -> GHC.Located a -> Maybe (GHC.Located a)+findLargestExpression ss e@(GHC.L l _)+  | l == ss = Just e+  | otherwise = Nothing -findLargestExpression :: SrcSpan -> GHC.Located ast-                      -> Maybe (GHC.Located ast)-findLargestExpression ss e@(GHC.L l _) =-  if l == ss-    then Just e-    else Nothing+findOrError+  :: forall a modu m. (Data a, Data modu, MonadIO m)+  => modu -> SrcSpan -> 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 p = everywhere (mkT (filter p))+doDeleteStmt = transformBi . filter  doDeleteImport :: Data a => (Import -> Bool) -> a -> a-doDeleteImport p = everywhere (mkT (filter p))+doDeleteImport = transformBi . filter  {- -- Renaming@@ -652,3 +746,130 @@           (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 (UnhelpfulSpan mempty) err+    Right flags -> do+      _ <- GHC.setSessionDynFlags 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++-- | 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+  ]

@@ -0,0 +1,115 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++module Refact.Options (Options(..), optionsWithHelp) where++import Data.Char (isDigit)+import Options.Applicative+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)+  }+++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{..}++optionsWithHelp :: ParserInfo Options+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++parsePos :: MonadFail m => String -> m (Int, Int)+parsePos s =+  case span isDigit s of+    (line, ',':col) ->+      case (,) <$> readMaybe line <*> readMaybe col of+        Just l -> pure l+        Nothing -> fail "Invalid input"+    _ -> fail "Invalid input"

@@ -1,44 +1,24 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE ViewPatterns #-} -module Refact.Run where+module Refact.Run (refactMain, runPipe) where -import Language.Haskell.GHC.ExactPrint-import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP-  ( defaultCppOptions-  , ghcWrapper-  , initDynFlags-  , parseModuleApiAnnsWithCppInternal-  , postParseTransform-  ) import Language.Haskell.GHC.ExactPrint.Utils +import Refact.Apply (parseExtensions) import qualified Refact.Types as R import Refact.Types hiding (SrcSpan)-import Refact.Apply import Refact.Fixity-import Refact.Internal (apply)--import DynFlags-import HeaderInfo (getOptions)-import HscTypes (handleSourceError)-import qualified GHC (setSessionDynFlags, ParsedSource)-import Panic (handleGhcException)-import SrcLoc-import StringBuffer (stringToStringBuffer)-import GHC.LanguageExtensions.Type (Extension(..))+import Refact.Internal+  ( Verbosity(..)+  , apply+  , onError+  , parseModuleWithArgs+  )+import Refact.Options (Options(..), optionsWithHelp)  import Control.Monad-import Control.Monad.IO.Class (MonadIO(..))-import Data.Char import Data.List hiding (find)-import qualified Data.List as List import Data.Maybe import Data.Version import Options.Applicative@@ -46,22 +26,20 @@ import System.FilePath.Find import System.Exit import qualified System.PosixCompat.Files as F-import Text.Read  import Paths_apply_refact  import Debug.Trace -#if __GLASGOW_HASKELL__ <= 806-type MonadFail = Monad-#endif- refactMain :: IO () refactMain = do   o@Options{..} <- execParser optionsWithHelp   when optionsVersion (putStr ("v" ++ showVersion version) >> exitSuccess)-  unless (isJust optionsTarget || isJust optionsRefactFile)-    (error "Must specify either the target file or the refact file")+  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'."   case optionsTarget of     Nothing ->       withTempFile $ \fp -> do@@ -73,104 +51,6 @@         then findHsFiles target >>= mapM_ (runPipe o)         else runPipe o target --parseVerbosity :: Monad m => String -> m Verbosity-parseVerbosity = pure . \case-  "0" -> Silent-  "1" -> Normal-  "2" -> Loud-  _   -> Normal--parsePos :: MonadFail m => String -> m (Int, Int)-parsePos s =-  case span isDigit s of-    (line, ',':col) ->-      case (,) <$> readMaybe line <*> readMaybe col of-        Just l -> pure l-        Nothing -> fail "Invalid input"-    _ -> fail "Invalid input"--data Target = StdIn | File FilePath--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)-  }--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"-    ]-  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"-  ]- -- Given base directory finds all haskell source files findHsFiles :: FilePath -> IO [FilePath] findHsFiles = find filterDirectory filterFilename@@ -193,49 +73,6 @@       | "Setup.hs" `isInfixOf` x = False       | otherwise                 = True --- | Parse the input into a list of enabled extensions and a list of disabled extensions.-parseExtensions :: [String] -> ([Extension], [Extension])-parseExtensions = foldl' f ([], [])-  where-    f :: ([Extension], [Extension]) -> String -> ([Extension], [Extension])-    f (ys, ns) ('N' : 'o' : s) | Just ext <- readExtension s =-      (delete ext ys, ext : delete ext ns)-    f (ys, ns) s | Just ext <- readExtension s =-      (ext : delete ext ys, delete ext ns)-    -- ignore unknown extensions-    f (ys, ns) _ = (ys, ns)--    readExtension :: String -> Maybe Extension-    readExtension s = flagSpecFlag <$> List.find ((== s) . flagSpecName) xFlags--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 :: [String] -> FilePath -> IO (Either Errors (Anns, GHC.ParsedSource))-parseModuleWithArgs exts fp = EP.ghcWrapper $ do-  let (es, ds) = parseExtensions exts-  initFlags <- EP.initDynFlags fp-  eflags <- liftIO $ addExtensionsToFlags es ds fp initFlags-  case eflags of-    -- TODO: report error properly.-    Left err -> pure . Left $ mkErr initFlags (UnhelpfulSpan mempty) err-    Right flags -> do-      _ <- GHC.setSessionDynFlags flags-      res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions flags fp-      return $ EP.postParseTransform res rigidLayout- runPipe :: Options -> FilePath  -> IO () runPipe Options{..} file = do   let verb = optionsVerbosity@@ -247,10 +84,13 @@    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 optionsLanguage file+                =<< parseModuleWithArgs (enabledExts, disabledExts) file     when optionsDebug (putStrLn (showAnnData as 0 m))-    apply optionsPos optionsStep inp file verb as m+    apply optionsPos optionsStep inp (Just file) verb as m    if optionsInplace && isJust optionsTarget     then writeFileUTF8 file output

@@ -15,6 +15,7 @@                     , Type                     , Import                     , FunBind+                    , AnnKeyMap                     -- * Monad                     , M                     -- * Utility@@ -23,15 +24,17 @@                     , modifyAnnKey                     , replaceAnnKey                     , toGhcSrcSpan+                    , toGhcSrcSpan'                     , setSrcSpanFile                     , findParent-                     ) where  import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types +import Data.Bifunctor (bimap) import Data.Data+import Data.Map.Strict (Map)  import FastString (FastString) import SrcLoc@@ -63,8 +66,10 @@  -- Types ---type M a = State Anns a+type M a = StateT (Anns, AnnKeyMap) IO a +type AnnKeyMap = Map AnnKey [AnnKey]+ type Module = (GHC.Located (GHC.HsModule GHC.GhcPs))  type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs)@@ -155,25 +160,53 @@ -- -- 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 -> Located old -> Located new -> M (Located new) modifyAnnKey m e1 e2 = do-    as <- get-    let parentKey = fromMaybe (mkAnnKey e2) (findParent (getLoc e2) as m)-    e2 <$ modify (\m' -> replaceAnnKey m' (mkAnnKey e1) (mkAnnKey e2) (mkAnnKey e2) parentKey)+  as <- gets fst+  let parentKey = fromMaybe (mkAnnKey e2) (findParent (getLoc e2) as m)+  e2 <$ modify+          ( bimap+              ( recoverBackquotes e1 e2+              . replaceAnnKey (mkAnnKey e1) (mkAnnKey e2) (mkAnnKey e2) parentKey+              )+              (Map.insertWith (++) (mkAnnKey e1) [mkAnnKey e2])+          ) +-- | 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 (L old _) (L 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}+          _ -> annNew+     in Map.adjust f (AnnKey new (CN "Unqual")) anns+  | otherwise = anns  -- | Lower level version of @modifyAnnKey@-replaceAnnKey ::-  Anns -> AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns-replaceAnnKey a old new inp deltainfo =+replaceAnnKey :: AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Anns+replaceAnnKey old new inp deltainfo a =   fromMaybe a (replace old new inp deltainfo a) - -- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@ toGhcSrcSpan :: FilePath -> R.SrcSpan -> SrcSpan-toGhcSrcSpan file R.SrcSpan{..} = mkSrcSpan (f startLine startCol) (f endLine endCol)+toGhcSrcSpan = toGhcSrcSpan' . GHC.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 (GHC.mkFastString file)+    f = mkSrcLoc file  setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan setSrcSpanFile file s

@@ -1,32 +1,32 @@ module Main where -import Test.Tasty-import Test.Tasty.Golden+import Options.Applicative import System.Directory import System.FilePath--import Options.Applicative--import Refact.Run-import Refact.Apply--import System.IO.Silently import System.IO+import System.IO.Silently+import System.Process +import Refact.Internal (Verbosity(..))+import Refact.Options (Options(..))+import Refact.Run (runPipe)+ import Debug.Trace-import System.Process+import Test.Tasty import Test.Tasty.ExpectedFailure-+import Test.Tasty.Golden  main =   defaultMain . mkTests =<< findTests  testDir = "tests/examples" +expectedFailures :: [FilePath]+expectedFailures = map (testDir </>) ["lambda42.hs"]+ findTests :: IO [FilePath] findTests = findByExtension [".hs"] testDir - mkTests :: [FilePath] -> TestTree mkTests files = testGroup "Unit tests" (map mkTest files)   where@@ -50,4 +50,5 @@           action =             hSilence [stderr] $ runPipe topts fp           diffCmd = \ref new -> ["diff", "-u", ref, new]-      in goldenVsFileDiff fp diffCmd (fp <.> "expected") outfile action+          testFn  = if fp `elem` expectedFailures then expectFail else id+      in testFn $ goldenVsFileDiff fp diffCmd (fp <.> "expected") outfile action

@@ -0,0 +1,1 @@+foo = zipWith SymInfo [0 ..] (repeat ty)

@@ -0,0 +1,1 @@+foo = map (`SymInfo` ty) [0 ..]

@@ -0,0 +1,1 @@+[("tests/examples/Backquotes.hs:1:7-40: Warning: Use map\nFound:\n  zipWith SymInfo [0 .. ] (repeat ty)\nPerhaps:\n  map (`SymInfo` ty) [0 .. ]\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 41}, subts = [("f",SrcSpan {startLine = 1, startCol = 15, endLine = 1, endCol = 22}),("y",SrcSpan {startLine = 1, startCol = 23, endLine = 1, endCol = 29}),("z",SrcSpan {startLine = 1, startCol = 38, endLine = 1, endCol = 40})], orig = "map (`f` z) y"}])]

@@ -0,0 +1,1 @@+x = do(y)

@@ -0,0 +1,1 @@+x = do y

@@ -0,0 +1,1 @@+[("tests/examples/Bracket39.hs:1:7-9: Warning: Redundant bracket\nFound:\n  (y)\nPerhaps:\n  y\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 10}, subts = [("x",SrcSpan {startLine = 1, startCol = 8, endLine = 1, endCol = 9})], orig = "x"}])]

@@ -0,0 +1,1 @@+x = do(Foo.y)

@@ -0,0 +1,1 @@+x = do Foo.y

@@ -0,0 +1,1 @@+[("tests/examples/Bracket40.hs:1:7-13: Warning: Redundant bracket\nFound:\n  (Foo.y)\nPerhaps:\n  Foo.y\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 14}, subts = [("x",SrcSpan {startLine = 1, startCol = 8, endLine = 1, endCol = 13})], orig = "x"}])]

@@ -0,0 +1,1 @@+x = do(Foo.foo bar)

@@ -0,0 +1,1 @@+x = do Foo.foo bar

@@ -0,0 +1,1 @@+[("tests/examples/Bracket41.hs:1:7-19: Suggestion: Redundant bracket\nFound:\n  do (Foo.foo bar)\nPerhaps:\n  do Foo.foo bar\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 20}, subts = [("x",SrcSpan {startLine = 1, startCol = 8, endLine = 1, endCol = 19})], orig = "x"}])]

@@ -0,0 +1,11 @@+-- comment before header+module ApplyRefact6 where++{-# standalone annotation #-}++-- standalone comment++-- | haddock comment+f = {- inline comment -} {- inline comment inside refactored code -} (1) -- ending comment++-- final comment

@@ -0,0 +1,11 @@+-- comment before header+module ApplyRefact6 where++{-# standalone annotation #-}++-- standalone comment++-- | haddock comment+f = {- inline comment -} {- inline comment inside refactored code -} 1 -- ending comment++-- final comment

@@ -0,0 +1,1 @@+[("tests/examples/Comment10.hs:9:70-72: Warning: Redundant bracket\nFound:\n  (1)\nPerhaps:\n  1\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 9, startCol = 70, endLine = 9, endCol = 73}, subts = [("x",SrcSpan {startLine = 9, startCol = 71, endLine = 9, endCol = 72})], orig = "x"}])]

@@ -0,0 +1,6 @@+bar x y =+  -- a comment+  if isJust x then "1"+  else if (Prelude.null (y)) then "2"+  -- another comment+  else "3"

@@ -0,0 +1,6 @@+bar x y =+  -- a comment+  if isJust x then "1"+  else if Prelude.null (y) then "2"+  -- another comment+  else "3"

@@ -0,0 +1,1 @@+[("tests/examples/Comment7.hs:(1,1)-(6,10): Suggestion: Use guards\nFound:\n  bar x y\n    = if isJust x then \"1\" else if (Prelude.null (y)) then \"2\" else \"3\"\nPerhaps:\n  bar x y\n    | isJust x = \"1\"\n    | (Prelude.null (y)) = \"2\"\n    | otherwise = \"3\"\n",[Replace {rtype = Match, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 6, endCol = 11}, subts = [("p1001",SrcSpan {startLine = 1, startCol = 5, endLine = 1, endCol = 6}),("p1002",SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 8}),("g1001",SrcSpan {startLine = 3, startCol = 6, endLine = 3, endCol = 14}),("g1002",SrcSpan {startLine = 4, startCol = 11, endLine = 4, endCol = 29}),("e1001",SrcSpan {startLine = 3, startCol = 20, endLine = 3, endCol = 23}),("e1002",SrcSpan {startLine = 4, startCol = 35, endLine = 4, endCol = 38}),("e1003",SrcSpan {startLine = 6, startCol = 8, endLine = 6, endCol = 11})], orig = "bar p1001 p1002\n  | g1001 = e1001\n  | g1002 = e1002\n  | otherwise = e1003"}]),("tests/examples/Comment7.hs:4:11-28: Suggestion: Redundant bracket\nFound:\n  if (Prelude.null (y)) then \"2\" else \"3\"\nPerhaps:\n  if Prelude.null (y) then \"2\" else \"3\"\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 4, startCol = 11, endLine = 4, endCol = 29}, subts = [("x",SrcSpan {startLine = 4, startCol = 12, endLine = 4, endCol = 28})], orig = "x"}]),("tests/examples/Comment7.hs:4:25-27: Warning: Redundant bracket\nFound:\n  (y)\nPerhaps:\n  y\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 4, startCol = 25, endLine = 4, endCol = 28}, subts = [("x",SrcSpan {startLine = 4, startCol = 26, endLine = 4, endCol = 27})], orig = "x"}])]

@@ -0,0 +1,2 @@+-- input+foo = f {- comment attached to <$> -} <$> {- comment attached to x -} x >>= g

@@ -0,0 +1,2 @@+-- input+foo = f {- comment attached to <$> -} <$> {- comment attached to x -} x >>= g

@@ -0,0 +1,1 @@+[("tests/examples/Comment8.hs:2:7-77: Warning: Redundant <$>\nFound:\n  f <$> x >>= g\nPerhaps:\n  x >>= g . f\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 2, startCol = 7, endLine = 2, endCol = 78}, subts = [("f",SrcSpan {startLine = 2, startCol = 7, endLine = 2, endCol = 8}),("g",SrcSpan {startLine = 2, startCol = 77, endLine = 2, endCol = 78}),("x",SrcSpan {startLine = 2, startCol = 71, endLine = 2, endCol = 72})], orig = "x >>= g . f"}])]

@@ -0,0 +1,2 @@+-- input+foo = f <$> {- comment attached to x -} x >>= g

@@ -0,0 +1,2 @@+-- input+foo =  {- comment attached to x -}x >>= g . f

@@ -0,0 +1,1 @@+[("tests/examples/Comment9.hs:2:7-47: Warning: Redundant <$>\nFound:\n  f <$> x >>= g\nPerhaps:\n  x >>= g . f\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 2, startCol = 7, endLine = 2, endCol = 48}, subts = [("f",SrcSpan {startLine = 2, startCol = 7, endLine = 2, endCol = 8}),("g",SrcSpan {startLine = 2, startCol = 47, endLine = 2, endCol = 48}),("x",SrcSpan {startLine = 2, startCol = 41, endLine = 2, endCol = 42})], orig = "x >>= g . f"}])]

@@ -0,0 +1,4 @@+f :: String -> String+f x = show x+  where y :: String+        y = "foo"

@@ -0,0 +1,4 @@+f :: String -> String+f = show+  where y :: String+        y = "foo"

@@ -0,0 +1,1 @@+[("test/examples/EtaReduceLocalTypeSig.hs:2:1-12: Warning: Eta reduce\nFound:\n  f x = show x\nPerhaps:\n  f = show\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 13}, subts = [("body",SrcSpan {startLine = 2, startCol = 7, endLine = 2, endCol = 11})], orig = "f = body"}])]

@@ -0,0 +1,4 @@+f :: Bool -> Integer+f = (\ b ->  (case b of+      False -> 1+      True -> 0))

@@ -0,0 +1,4 @@+f :: Bool -> Integer+f b = case b of+       False -> 1+       True -> 0

@@ -0,0 +1,1 @@+[("test.hs:(2,1)-(4,17): Warning: Redundant lambda\nFound:\n  f = (\\ b\n         -> (case b of\n               False -> 1\n               True -> 0))\nPerhaps:\n  f b\n    = case b of\n        False -> 1\n        True -> 0\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 4, endCol = 18}, subts = [("body",SrcSpan {startLine = 2, startCol = 15, endLine = 4, endCol = 16}),("a",SrcSpan {startLine = 2, startCol = 8, endLine = 2, endCol = 9})], orig = "f a = body"}])]