diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/apply-refact.cabal b/apply-refact.cabal --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,6 @@ -module Main where +module Main (main) where -import Refact.Run +import Refact.Run (refactMain) main :: IO () main = refactMain - diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -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 + -- . + -- 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 diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs --- a/src/Refact/Fixity.hs +++ b/src/Refact/Fixity.hs @@ -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 diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -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 + ] diff --git a/src/Refact/Options.hs b/src/Refact/Options.hs new file mode 100644 --- /dev/null +++ b/src/Refact/Options.hs @@ -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 "," + , 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" diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -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 "," - , 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 diff --git a/src/Refact/Utils.hs b/src/Refact/Utils.hs --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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 diff --git a/tests/examples/Backquotes.hs b/tests/examples/Backquotes.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Backquotes.hs @@ -0,0 +1,1 @@ +foo = zipWith SymInfo [0 ..] (repeat ty) diff --git a/tests/examples/Backquotes.hs.expected b/tests/examples/Backquotes.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Backquotes.hs.expected @@ -0,0 +1,1 @@ +foo = map (`SymInfo` ty) [0 ..] diff --git a/tests/examples/Backquotes.hs.refact b/tests/examples/Backquotes.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Backquotes.hs.refact @@ -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"}])] diff --git a/tests/examples/Bracket39.hs b/tests/examples/Bracket39.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket39.hs @@ -0,0 +1,1 @@ +x = do(y) diff --git a/tests/examples/Bracket39.hs.expected b/tests/examples/Bracket39.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket39.hs.expected @@ -0,0 +1,1 @@ +x = do y diff --git a/tests/examples/Bracket39.hs.refact b/tests/examples/Bracket39.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket39.hs.refact @@ -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"}])] diff --git a/tests/examples/Bracket40.hs b/tests/examples/Bracket40.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket40.hs @@ -0,0 +1,1 @@ +x = do(Foo.y) diff --git a/tests/examples/Bracket40.hs.expected b/tests/examples/Bracket40.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket40.hs.expected @@ -0,0 +1,1 @@ +x = do Foo.y diff --git a/tests/examples/Bracket40.hs.refact b/tests/examples/Bracket40.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket40.hs.refact @@ -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"}])] diff --git a/tests/examples/Bracket41.hs b/tests/examples/Bracket41.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket41.hs @@ -0,0 +1,1 @@ +x = do(Foo.foo bar) diff --git a/tests/examples/Bracket41.hs.expected b/tests/examples/Bracket41.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket41.hs.expected @@ -0,0 +1,1 @@ +x = do Foo.foo bar diff --git a/tests/examples/Bracket41.hs.refact b/tests/examples/Bracket41.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Bracket41.hs.refact @@ -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"}])] diff --git a/tests/examples/Comment10.hs b/tests/examples/Comment10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Comment10.hs @@ -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 diff --git a/tests/examples/Comment10.hs.expected b/tests/examples/Comment10.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Comment10.hs.expected @@ -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 diff --git a/tests/examples/Comment10.hs.refact b/tests/examples/Comment10.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Comment10.hs.refact @@ -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"}])] diff --git a/tests/examples/Comment7.hs b/tests/examples/Comment7.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Comment7.hs @@ -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" diff --git a/tests/examples/Comment7.hs.expected b/tests/examples/Comment7.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Comment7.hs.expected @@ -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" diff --git a/tests/examples/Comment7.hs.refact b/tests/examples/Comment7.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Comment7.hs.refact @@ -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"}])] diff --git a/tests/examples/Comment8.hs b/tests/examples/Comment8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Comment8.hs @@ -0,0 +1,2 @@ +-- input +foo = f {- comment attached to <$> -} <$> {- comment attached to x -} x >>= g diff --git a/tests/examples/Comment8.hs.expected b/tests/examples/Comment8.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Comment8.hs.expected @@ -0,0 +1,2 @@ +-- input +foo = f {- comment attached to <$> -} <$> {- comment attached to x -} x >>= g diff --git a/tests/examples/Comment8.hs.refact b/tests/examples/Comment8.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Comment8.hs.refact @@ -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"}])] diff --git a/tests/examples/Comment9.hs b/tests/examples/Comment9.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Comment9.hs @@ -0,0 +1,2 @@ +-- input +foo = f <$> {- comment attached to x -} x >>= g diff --git a/tests/examples/Comment9.hs.expected b/tests/examples/Comment9.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Comment9.hs.expected @@ -0,0 +1,2 @@ +-- input +foo = {- comment attached to x -}x >>= g . f diff --git a/tests/examples/Comment9.hs.refact b/tests/examples/Comment9.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/Comment9.hs.refact @@ -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"}])] diff --git a/tests/examples/EtaReduceLocalTypeSig.hs b/tests/examples/EtaReduceLocalTypeSig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/EtaReduceLocalTypeSig.hs @@ -0,0 +1,4 @@ +f :: String -> String +f x = show x + where y :: String + y = "foo" diff --git a/tests/examples/EtaReduceLocalTypeSig.hs.expected b/tests/examples/EtaReduceLocalTypeSig.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/EtaReduceLocalTypeSig.hs.expected @@ -0,0 +1,4 @@ +f :: String -> String +f = show + where y :: String + y = "foo" diff --git a/tests/examples/EtaReduceLocalTypeSig.hs.refact b/tests/examples/EtaReduceLocalTypeSig.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/EtaReduceLocalTypeSig.hs.refact @@ -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"}])] diff --git a/tests/examples/lambda42.hs b/tests/examples/lambda42.hs new file mode 100644 --- /dev/null +++ b/tests/examples/lambda42.hs @@ -0,0 +1,4 @@ +f :: Bool -> Integer +f = (\ b -> (case b of + False -> 1 + True -> 0)) diff --git a/tests/examples/lambda42.hs.expected b/tests/examples/lambda42.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/lambda42.hs.expected @@ -0,0 +1,4 @@ +f :: Bool -> Integer +f b = case b of + False -> 1 + True -> 0 diff --git a/tests/examples/lambda42.hs.refact b/tests/examples/lambda42.hs.refact new file mode 100644 --- /dev/null +++ b/tests/examples/lambda42.hs.refact @@ -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"}])]