From 2dd1c95dced65dde0b1f1b1be5b18958e3664adf Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 16:54:07 -0400 Subject: [PATCH 1/8] Fail with error on unrecognized language pragmas --- src/Refact/Run.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index 2ce37d0..ff7ed90 100644 --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -192,7 +192,9 @@ filterFilename = do parseModuleWithArgs :: [String] -> FilePath -> IO (Either (SrcSpan, String) (Anns, GHC.ParsedSource)) parseModuleWithArgs ghcArgs fp = EP.ghcWrapper $ do dflags1 <- EP.initDynFlags fp - (dflags2, _, _) <- GHC.parseDynamicFlagsCmdLine dflags1 (map GHC.noLoc ghcArgs) + (dflags2, unusedArgs, _) <- GHC.parseDynamicFlagsCmdLine dflags1 (map GHC.noLoc ghcArgs) + liftIO $ unless (null unusedArgs) + (fail ("Unrecognized GHC args: " ++ intercalate ", " (map GHC.unLoc unusedArgs))) _ <- GHC.setSessionDynFlags dflags2 res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions dflags2 fp return $ EP.postParseTransform res rigidLayout From 115f43a520ab89aceee2c80a2d80465f7c284ca0 Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 18:37:03 -0400 Subject: [PATCH 2/8] [cleanup] Move Verbosity declaration higher --- src/Refact/Apply.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs index bee4ed2..d02089f 100644 --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -63,6 +63,8 @@ refactOptions = stringOptions { epRigidity = RigidLayout } rigidLayout :: DeltaOptions rigidLayout = deltaOptions RigidLayout +data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord) + -- | Apply a set of refactorings as supplied by hlint applyRefactorings :: Maybe (Int, Int) -> [(String, [Refactoring R.SrcSpan])] -> FilePath -> IO String applyRefactorings optionsPos inp file = do @@ -83,7 +85,6 @@ applyRefactorings optionsPos inp file = do let output = runIdentity $ exactPrintWithOptions refactOptions res ares return output -data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord) -- 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. From 646257fc27ce35dc8e23a7c63cc563d3504f7a86 Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 17:53:03 -0400 Subject: [PATCH 3/8] [cleanup] Factor out RawHintList type --- src/Refact/Apply.hs | 9 ++++++--- src/Refact/Run.hs | 4 +--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs index d02089f..37f43d4 100644 --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -7,6 +7,7 @@ module Refact.Apply ( runRefactoring , applyRefactorings + , RawHintList -- * Support for runPipe in the main process , Verbosity(..) @@ -65,8 +66,10 @@ rigidLayout = deltaOptions RigidLayout data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord) +type RawHintList = [(String, [Refactoring R.SrcSpan])] + -- | Apply a set of refactorings as supplied by hlint -applyRefactorings :: Maybe (Int, Int) -> [(String, [Refactoring R.SrcSpan])] -> FilePath -> IO String +applyRefactorings :: Maybe (Int, Int) -> RawHintList -> FilePath -> IO String applyRefactorings optionsPos inp file = do (as, m) <- either (error . show) (uncurry applyFixities) <$> parseModuleWithOptions rigidLayout file @@ -88,12 +91,12 @@ applyRefactorings optionsPos inp file = do -- 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 :: Verbosity -> RawHintList -> RawHintList removeOverlap verb = dropOverlapping . sortBy f . summarize 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 :: RawHintList -> [(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) diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index 2ce37d0..c136722 100644 --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -15,8 +15,6 @@ import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP ) import Language.Haskell.GHC.ExactPrint.Utils - -import qualified Refact.Types as R import Refact.Types hiding (SrcSpan) import Refact.Apply import Refact.Fixity @@ -207,7 +205,7 @@ runPipe Options{..} file = do when optionsDebug (putStrLn (showAnnData as 0 m)) rawhints <- getHints optionsRefactFile when (verb == Loud) (traceM "Got raw hints") - let inp :: [(String, [Refactoring R.SrcSpan])] = read rawhints + let inp :: RawHintList = read rawhints n = length inp when (verb == Loud) (traceM $ "Read " ++ show n ++ " hints") let noOverlapInp = removeOverlap verb inp From 92a681c18f7e61d5ae7ab76be0da78597abbfd96 Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 18:40:30 -0400 Subject: [PATCH 4/8] [cleanup] Factor out RefactoringLoop type --- src/Refact/Apply.hs | 6 +++++- src/Refact/Run.hs | 3 +-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs index 37f43d4..c29cbf1 100644 --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -10,6 +10,7 @@ module Refact.Apply , RawHintList -- * Support for runPipe in the main process + , RefactoringLoop , Verbosity(..) , rigidLayout , removeOverlap @@ -31,6 +32,7 @@ import Data.Ord import Control.Monad import Control.Monad.State import Control.Monad.Identity +import Control.Monad.Trans.Maybe import Data.Data import Data.Generics.Schemes @@ -54,7 +56,7 @@ import Refact.Fixity import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R import Refact.Utils (Stmt, Pat, Name, Decl, M, Expr, Type, FunBind - , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan) + , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, Module) -- library access to perform the substitutions @@ -68,6 +70,8 @@ data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord) type RawHintList = [(String, [Refactoring R.SrcSpan])] +type RefactoringLoop = Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])] -> MaybeT IO (Anns, Module) + -- | Apply a set of refactorings as supplied by hlint applyRefactorings :: Maybe (Int, Int) -> RawHintList -> FilePath -> IO String applyRefactorings optionsPos inp file = do diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index c136722..43d3d46 100644 --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -239,8 +239,7 @@ data LoopOption = LoopOption { desc :: String , perform :: MaybeT IO (Anns, Module) } -refactoringLoop :: Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])] - -> MaybeT IO (Anns, Module) +refactoringLoop :: RefactoringLoop refactoringLoop as m [] = return (as, m) refactoringLoop as m ((_, []): rs) = refactoringLoop as m rs refactoringLoop as m hints@((hintDesc, rs): rss) = From 2a84cdc893db20cffb1166659b500382ce2cf60b Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 18:12:48 -0400 Subject: [PATCH 5/8] Rename "Options" to "RunOptions" In prep for moving many of them over to the API apply function. --- src/Refact/Run.hs | 14 +++++++------- tests/Test.hs | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index 43d3d46..b890b3b 100644 --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -50,7 +50,7 @@ import Data.Char refactMain :: IO () refactMain = do - o@Options{..} <- execParser optionsWithHelp + o@RunOptions{..} <- 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") @@ -85,7 +85,7 @@ parsePos s = data Target = StdIn | File FilePath -data Options = Options +data RunOptions = RunOptions { optionsTarget :: Maybe FilePath -- ^ Where to process hints , optionsRefactFile :: Maybe FilePath -- ^ The refactorings to process , optionsInplace :: Bool @@ -99,9 +99,9 @@ data Options = Options , optionsPos :: Maybe (Int, Int) } -options :: Parser Options +options :: Parser RunOptions options = - Options <$> + RunOptions <$> optional (argument str (metavar "TARGET")) <*> option (Just <$> str) @@ -152,7 +152,7 @@ options = <> help "Apply hints relevant to a specific position") -optionsWithHelp :: ParserInfo Options +optionsWithHelp :: ParserInfo RunOptions optionsWithHelp = info (helper <*> options) @@ -195,8 +195,8 @@ parseModuleWithArgs ghcArgs fp = EP.ghcWrapper $ do res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions dflags2 fp return $ EP.postParseTransform res rigidLayout -runPipe :: Options -> FilePath -> IO () -runPipe Options{..} file = do +runPipe :: RunOptions -> FilePath -> IO () +runPipe RunOptions{..} file = do let verb = optionsVerbosity let ghcArgs = map ("-X" ++) optionsLanguage when (verb == Loud) (traceM "Parsing module") diff --git a/tests/Test.hs b/tests/Test.hs index 51a9091..063cf98 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -37,7 +37,7 @@ mkTests files = testGroup "Unit tests" (map mkTest files) mkTest fp = let outfile = fp <.> "out" rfile = fp <.> "refact" - topts = Options + topts = RunOptions { optionsTarget = Just fp , optionsInplace = False , optionsOutput = Just outfile From f77c1bde1487bdc3f9fffa87885959719075fa88 Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 17:10:14 -0400 Subject: [PATCH 6/8] Simplify logging output --- src/Refact/Run.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index b890b3b..14eef6b 100644 --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -197,18 +197,19 @@ parseModuleWithArgs ghcArgs fp = EP.ghcWrapper $ do runPipe :: RunOptions -> FilePath -> IO () runPipe RunOptions{..} file = do - let verb = optionsVerbosity + let logAt lvl = when (optionsVerbosity >= lvl) . traceM + let debugOut = when optionsDebug . putStrLn let ghcArgs = map ("-X" ++) optionsLanguage - when (verb == Loud) (traceM "Parsing module") + logAt Loud "Parsing module" (as, m) <- either (error . show) (uncurry applyFixities) <$> parseModuleWithArgs ghcArgs file - when optionsDebug (putStrLn (showAnnData as 0 m)) + debugOut (showAnnData as 0 m) rawhints <- getHints optionsRefactFile - when (verb == Loud) (traceM "Got raw hints") + logAt Loud "Got raw hints" let inp :: RawHintList = read rawhints n = length inp - when (verb == Loud) (traceM $ "Read " ++ show n ++ " hints") - let noOverlapInp = removeOverlap verb inp + logAt Loud $ "Read " ++ show n ++ " hints" + let noOverlapInp = removeOverlap optionsVerbosity inp refacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp posFilter (_, rs) = @@ -217,22 +218,21 @@ runPipe RunOptions{..} file = do Just p -> any (flip spans p . pos) rs filtRefacts = filter posFilter refacts - - when (verb >= Normal) (traceM $ "Applying " ++ show (length (concatMap snd filtRefacts)) ++ " hints") - when (verb == Loud) (traceM $ show filtRefacts) + logAt Normal $ "Applying " ++ show (length (concatMap snd filtRefacts)) ++ " hints" + logAt Loud $ show filtRefacts -- need a check here to avoid overlap (ares, res) <- if optionsStep then fromMaybe (as, m) <$> runMaybeT (refactoringLoop as m filtRefacts) else return . flip evalState 0 $ foldM (uncurry runRefactoring) (as, m) (concatMap snd filtRefacts) - when (optionsDebug) (putStrLn (showAnnData ares 0 res)) + debugOut (showAnnData ares 0 res) let output = runIdentity $ exactPrintWithOptions refactOptions res ares if optionsInplace && isJust optionsTarget then writeFile file output else case optionsOutput of Nothing -> putStr output Just f -> do - when (verb == Loud) (traceM $ "Writing result to " ++ f) + logAt Loud $ "Writing result to " ++ f writeFile f output data LoopOption = LoopOption From 524dd33a9b980ab26134939bfa74936db46c2664 Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 18:43:41 -0400 Subject: [PATCH 7/8] Move parseModuleWithArgs into Apply.hs --- src/Refact/Apply.hs | 20 +++++++++++++++++++- src/Refact/Run.hs | 19 ------------------- 2 files changed, 19 insertions(+), 20 deletions(-) diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs index c29cbf1..e326f67 100644 --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -10,9 +10,9 @@ module Refact.Apply , RawHintList -- * Support for runPipe in the main process + , parseModuleWithArgs , RefactoringLoop , Verbosity(..) - , rigidLayout , removeOverlap , refactOptions ) where @@ -24,6 +24,13 @@ 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 qualified Language.Haskell.GHC.ExactPrint.Parsers as EP + ( defaultCppOptions + , ghcWrapper + , initDynFlags + , parseModuleApiAnnsWithCppInternal + , postParseTransform + ) import Data.Maybe import Data.List hiding (find) @@ -41,6 +48,8 @@ import HsImpExp import HsSyn hiding (Pat, Stmt) import SrcLoc import qualified GHC hiding (parseModule) +import qualified GHC (setSessionDynFlags, ParsedSource) +import qualified DynFlags as GHC (parseDynamicFlagsCmdLine) import qualified OccName as GHC import Data.Generics hiding (GT) @@ -92,6 +101,15 @@ applyRefactorings optionsPos inp file = do let output = runIdentity $ exactPrintWithOptions refactOptions res ares return output +parseModuleWithArgs :: [String] -> FilePath -> IO (Either (SrcSpan, String) (Anns, GHC.ParsedSource)) +parseModuleWithArgs ghcArgs fp = EP.ghcWrapper $ do + dflags1 <- EP.initDynFlags fp + (dflags2, unusedArgs, _) <- GHC.parseDynamicFlagsCmdLine dflags1 (map GHC.noLoc ghcArgs) + liftIO $ unless (null unusedArgs) + (fail ("Unrecognized GHC args: " ++ intercalate ", " (map GHC.unLoc unusedArgs))) + _ <- GHC.setSessionDynFlags dflags2 + res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions dflags2 fp + return $ EP.postParseTransform res rigidLayout -- 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. diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index f2d4c94..730af91 100644 --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -6,13 +6,6 @@ module Refact.Run where import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Print -import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP - ( defaultCppOptions - , ghcWrapper - , initDynFlags - , parseModuleApiAnnsWithCppInternal - , postParseTransform - ) import Language.Haskell.GHC.ExactPrint.Utils import Refact.Types hiding (SrcSpan) @@ -20,8 +13,6 @@ import Refact.Apply import Refact.Fixity import Refact.Utils (toGhcSrcSpan, Module) import qualified SrcLoc as GHC -import qualified DynFlags as GHC (parseDynamicFlagsCmdLine) -import qualified GHC as GHC (setSessionDynFlags, ParsedSource) import Options.Applicative import Data.Maybe @@ -187,16 +178,6 @@ filterFilename = do -- Pipe -parseModuleWithArgs :: [String] -> FilePath -> IO (Either (SrcSpan, String) (Anns, GHC.ParsedSource)) -parseModuleWithArgs ghcArgs fp = EP.ghcWrapper $ do - dflags1 <- EP.initDynFlags fp - (dflags2, unusedArgs, _) <- GHC.parseDynamicFlagsCmdLine dflags1 (map GHC.noLoc ghcArgs) - liftIO $ unless (null unusedArgs) - (fail ("Unrecognized GHC args: " ++ intercalate ", " (map GHC.unLoc unusedArgs))) - _ <- GHC.setSessionDynFlags dflags2 - res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions dflags2 fp - return $ EP.postParseTransform res rigidLayout - runPipe :: RunOptions -> FilePath -> IO () runPipe RunOptions{..} file = do let logAt lvl = when (optionsVerbosity >= lvl) . traceM From ada83ea21653616c8358481614c12a28dc675cc4 Mon Sep 17 00:00:00 2001 From: Robert Estelle Date: Thu, 9 May 2019 18:45:39 -0400 Subject: [PATCH 8/8] Implement shared "applyRefactorings'" function The original limited `applyRefactorings` is still exposed, but the logic of both that and `runPipe` is now shared, allowing API users to set additional options such as language settings or implement custom hint application loops. --- src/Refact/Apply.hs | 53 ++++++++++++++++++++++++++++++++++----------- src/Refact/Run.hs | 50 +++++++++++------------------------------- tests/Test.hs | 1 + 3 files changed, 54 insertions(+), 50 deletions(-) diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs index e326f67..d6505e9 100644 --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -4,17 +4,15 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} module Refact.Apply - ( - runRefactoring + ( runRefactoring , applyRefactorings + , applyRefactorings' + , ApplyOptions(..) + , defaultApplyOptions , RawHintList - - -- * Support for runPipe in the main process - , parseModuleWithArgs , RefactoringLoop , Verbosity(..) , removeOverlap - , refactOptions ) where import Language.Haskell.GHC.ExactPrint @@ -77,16 +75,39 @@ rigidLayout = deltaOptions RigidLayout data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord) +data ApplyOptions = ApplyOptions + { optionsVerbosity :: Verbosity + , optionsDebug :: Bool + , optionsLanguage :: [String] + , optionsPos :: Maybe (Int, Int) + } + +defaultApplyOptions :: ApplyOptions +defaultApplyOptions = ApplyOptions + { optionsVerbosity = Silent + , optionsDebug = False + , optionsLanguage = [] + , optionsPos = Nothing + } + type RawHintList = [(String, [Refactoring R.SrcSpan])] type RefactoringLoop = Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])] -> MaybeT IO (Anns, Module) -- | Apply a set of refactorings as supplied by hlint applyRefactorings :: Maybe (Int, Int) -> RawHintList -> FilePath -> IO String -applyRefactorings optionsPos inp file = do +applyRefactorings optionsPos hints = applyRefactorings' (defaultApplyOptions{ optionsPos }) hints Nothing + +applyRefactorings' :: ApplyOptions -> RawHintList -> Maybe RefactoringLoop -> FilePath -> IO String +applyRefactorings' ApplyOptions{..} hints maybeRefactoringLoop file = do + let logAt lvl = when (optionsVerbosity >= lvl) . traceM + let debugOut = when optionsDebug . putStrLn + let ghcArgs = map ("-X" ++) optionsLanguage + logAt Loud "Parsing module" (as, m) <- either (error . show) (uncurry applyFixities) - <$> parseModuleWithOptions rigidLayout file - let noOverlapInp = removeOverlap Silent inp + <$> parseModuleWithArgs ghcArgs file + debugOut (showAnnData as 0 m) + let noOverlapInp = removeOverlap optionsVerbosity hints refacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp posFilter (_, rs) = @@ -95,11 +116,17 @@ applyRefactorings optionsPos inp file = do Just p -> any (flip spans p . pos) rs filtRefacts = filter posFilter refacts + logAt Normal $ "Applying " ++ show (length (concatMap snd filtRefacts)) ++ " hints" + logAt Loud $ show filtRefacts -- need a check here to avoid overlap - (ares, res) <- return . flip evalState 0 $ - foldM (uncurry runRefactoring) (as, m) (concatMap snd filtRefacts) - let output = runIdentity $ exactPrintWithOptions refactOptions res ares - return output + (ares, res) <- case maybeRefactoringLoop of + Just refactoringLoop -> + fromMaybe (as, m) <$> runMaybeT (refactoringLoop as m filtRefacts) + Nothing -> + return . flip evalState 0 $ + foldM (uncurry runRefactoring) (as, m) (concatMap snd filtRefacts) + debugOut (showAnnData ares 0 res) + return . runIdentity $ exactPrintWithOptions refactOptions res ares parseModuleWithArgs :: [String] -> FilePath -> IO (Either (SrcSpan, String) (Anns, GHC.ParsedSource)) parseModuleWithArgs ghcArgs fp = EP.ghcWrapper $ do diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index 730af91..bf42dd3 100644 --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -2,17 +2,13 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DuplicateRecordFields #-} module Refact.Run where import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Print -import Language.Haskell.GHC.ExactPrint.Utils -import Refact.Types hiding (SrcSpan) import Refact.Apply -import Refact.Fixity -import Refact.Utils (toGhcSrcSpan, Module) -import qualified SrcLoc as GHC +import Refact.Utils (Module) import Options.Applicative import Data.Maybe @@ -28,14 +24,12 @@ import qualified System.PosixCompat.Files as F import Control.Monad import Control.Monad.State -import Control.Monad.Identity import Paths_apply_refact import Data.Version import Debug.Trace -import SrcLoc import Text.Read import Data.Char @@ -152,7 +146,6 @@ optionsWithHelp <> header "refactor" ) - -- Given base directory finds all haskell source files findHsFiles :: FilePath -> IO [FilePath] findHsFiles = find filterDirectory filterFilename @@ -181,35 +174,18 @@ filterFilename = do runPipe :: RunOptions -> FilePath -> IO () runPipe RunOptions{..} file = do let logAt lvl = when (optionsVerbosity >= lvl) . traceM - let debugOut = when optionsDebug . putStrLn - let ghcArgs = map ("-X" ++) optionsLanguage - logAt Loud "Parsing module" - (as, m) <- either (error . show) (uncurry applyFixities) - <$> parseModuleWithArgs ghcArgs file - debugOut (showAnnData as 0 m) - rawhints <- getHints optionsRefactFile + + rawHints <- getHints optionsRefactFile logAt Loud "Got raw hints" - let inp :: RawHintList = read rawhints - n = length inp - logAt Loud $ "Read " ++ show n ++ " hints" - let noOverlapInp = removeOverlap optionsVerbosity inp - refacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp - - posFilter (_, rs) = - case optionsPos of - Nothing -> True - Just p -> any (flip spans p . pos) rs - filtRefacts = filter posFilter refacts - - logAt Normal $ "Applying " ++ show (length (concatMap snd filtRefacts)) ++ " hints" - logAt Loud $ show filtRefacts - -- need a check here to avoid overlap - (ares, res) <- if optionsStep - then fromMaybe (as, m) <$> runMaybeT (refactoringLoop as m filtRefacts) - else return . flip evalState 0 $ - foldM (uncurry runRefactoring) (as, m) (concatMap snd filtRefacts) - debugOut (showAnnData ares 0 res) - let output = runIdentity $ exactPrintWithOptions refactOptions res ares + let hints :: RawHintList = read rawHints + logAt Loud $ "Read " ++ show (length hints) ++ " hints" + + output <- applyRefactorings' + ApplyOptions{..} + hints + (if optionsStep then Just refactoringLoop else Nothing) + file + if optionsInplace && isJust optionsTarget then writeFile file output else case optionsOutput of diff --git a/tests/Test.hs b/tests/Test.hs index 063cf98..0702501 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} module Main where import Test.Tasty