Implement shared "applyRefactorings'" function

src/Refact/Apply.hs

@@ -4,15 +4,15 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE GADTs #-}
 module Refact.Apply
-  (
-    runRefactoring
+  ( runRefactoring
   , applyRefactorings
-
-  -- * Support for runPipe in the main process
+  , applyRefactorings'
+  , ApplyOptions(..)
+  , defaultApplyOptions
+  , RawHintList
+  , RefactoringLoop
   , Verbosity(..)
-  , rigidLayout
   , removeOverlap
-  , refactOptions
   )  where
 
 import Language.Haskell.GHC.ExactPrint
@@ -22,6 +22,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)
@@ -30,6 +37,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
 
@@ -38,6 +46,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)
 
@@ -53,7 +63,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
 
@@ -63,12 +73,41 @@ refactOptions = stringOptions { epRigidity = RigidLayout }
 rigidLayout :: DeltaOptions
 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) -> [(String, [Refactoring R.SrcSpan])] -> FilePath -> IO String
-applyRefactorings optionsPos inp file = do
+applyRefactorings :: Maybe (Int, Int) -> RawHintList -> FilePath -> IO String
+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) =
@@ -77,22 +116,36 @@ 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
-
-data Verbosity = Silent | Normal | Loud deriving (Eq, Show, Ord)
+  (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
+  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.
-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)

src/Refact/Run.hs

@@ -2,28 +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 qualified Language.Haskell.GHC.ExactPrint.Parsers as EP
-  ( defaultCppOptions
-  , ghcWrapper
-  , initDynFlags
-  , parseModuleApiAnnsWithCppInternal
-  , postParseTransform
-  )
-import Language.Haskell.GHC.ExactPrint.Utils
-
-
-import qualified Refact.Types as R
-import Refact.Types hiding (SrcSpan)
+
 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 Refact.Utils (Module)
 
 import Options.Applicative
 import Data.Maybe
@@ -39,20 +24,18 @@ 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
 
 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")
@@ -87,7 +70,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
@@ -101,9 +84,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)
@@ -154,7 +137,7 @@ options =
            <> help "Apply hints relevant to a specific position")
 
 
-optionsWithHelp :: ParserInfo Options
+optionsWithHelp :: ParserInfo RunOptions
 optionsWithHelp
   =
     info (helper <*> options)
@@ -163,7 +146,6 @@ optionsWithHelp
           <> header "refactor" )
 
 
-
 -- Given base directory finds all haskell source files
 findHsFiles :: FilePath -> IO [FilePath]
 findHsFiles = find filterDirectory filterFilename
@@ -189,60 +171,34 @@ filterFilename = do
 
 -- Pipe
 
-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)
-  _ <- GHC.setSessionDynFlags dflags2
-  res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions dflags2 fp
-  return $ EP.postParseTransform res rigidLayout
-
-runPipe :: Options -> FilePath  -> IO ()
-runPipe Options{..} file = do
-  let verb = optionsVerbosity
-  let ghcArgs = map ("-X" ++) optionsLanguage
-  when (verb == Loud) (traceM "Parsing module")
-  (as, m) <- either (error . show) (uncurry applyFixities)
-              <$> parseModuleWithArgs ghcArgs file
-  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
-      n = length inp
-  when (verb == Loud) (traceM $ "Read " ++ show n ++ " hints")
-  let noOverlapInp = removeOverlap verb 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
-
-
-  when (verb >= Normal) (traceM $ "Applying " ++ show (length (concatMap snd filtRefacts)) ++ " hints")
-  when (verb == Loud) (traceM $ 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))
-  let output = runIdentity $ exactPrintWithOptions refactOptions res ares
+runPipe :: RunOptions -> FilePath  -> IO ()
+runPipe RunOptions{..} file = do
+  let logAt lvl = when (optionsVerbosity >= lvl) . traceM
+
+  rawHints <- getHints optionsRefactFile
+  logAt Loud "Got raw hints"
+  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
            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
                     { 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) =

tests/Test.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 module Main where
 
 import Test.Tasty
@@ -37,7 +38,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