haskell-tools-cli 0.3.0.1 → 0.4.0.0

raw patch · 6 files changed

+454/−140 lines, 6 filesdep +aesondep +bytestringdep +criteriondep −HUnitdep ~filepathdep ~haskell-tools-astdep ~haskell-tools-cliPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, bytestring, criterion, knob, tasty, tasty-hunit, time

Dependencies removed: HUnit

Dependency ranges changed: filepath, haskell-tools-ast, haskell-tools-cli, haskell-tools-prettyprint, haskell-tools-refactor

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/Refactor/CLI.hs +105/−83
• Language/Haskell/Tools/Refactor/Session.hs +0/−24
• benchmark/Main.hs +174/−0
• exe/Main.hs +2/−1
• haskell-tools-cli.cabal +31/−9
• test/Main.hs +142/−23

@@ -1,6 +1,8 @@ {-# LANGUAGE LambdaCase
            , TupleSections
            , FlexibleContexts
+           , TemplateHaskell
+           , TypeFamilies
            #-}
 module Language.Haskell.Tools.Refactor.CLI (refactorSession) where
 
@@ -11,9 +13,12 @@ import Data.List
 import Data.List.Split
 import Control.Monad.State
+import Control.Applicative ((<|>))
 import Control.Reference
 
 import GHC
+import ErrUtils
+import Digraph
 import HscTypes as GHC
 import Module as GHC
 import GHC.Paths ( libdir )
@@ -26,124 +31,141 @@ 
 import Debug.Trace
 
-tryOut = refactorSession [ "-dry-run", "-one-shot", "-module-name=Language.Haskell.Tools.AST", "-refactoring=OrganizeImports"
-                         , "-package", "ghc", "src/ast", "src/backend-ghc", "src/prettyprint", "src/rewrite", "src/refactor"]
+type CLIRefactorSession = StateT CLISessionState Ghc
 
-refactorSession :: [String] -> IO String
-refactorSession args = runGhc (Just libdir) $ flip evalStateT initSession $
+data CLISessionState = 
+  CLISessionState { _refactState :: RefactorSessionState
+                  , _actualMod :: Maybe SourceFileKey
+                  , _exiting :: Bool
+                  , _dryMode :: Bool
+                  }
+
+makeReferences ''CLISessionState
+
+tryOut = refactorSession stdin stdout 
+           [ "-dry-run", "-one-shot", "-module-name=Language.Haskell.Tools.AST", "-refactoring=OrganizeImports"
+           , "src/ast", "src/backend-ghc", "src/prettyprint", "src/rewrite", "src/refactor"]
+
+refactorSession :: Handle -> Handle -> [String] -> IO ()
+refactorSession input output args = runGhc (Just libdir) $ handleSourceError printSrcErrors 
+                                                         $ flip evalStateT initSession $
   do lift $ initGhcFlags
      workingDirsAndHtFlags <- lift $ useFlags args
      let (htFlags, workingDirs) = partition (\f -> head f == '-') workingDirsAndHtFlags
-     if null workingDirs then return usageMessage
-                         else do initializeSession workingDirs htFlags
-                                 runSession htFlags
+     if null workingDirs then liftIO $ hPutStrLn output usageMessage
+                         else do initializeSession output workingDirs htFlags
+                                 runSession input output htFlags
      
-  where initializeSession :: [FilePath] -> [String] -> RefactorSession Ghc ()
-        initializeSession workingDirs flags = do
-          moduleNames <- liftIO $ concat <$> mapM getModules workingDirs
-          lift $ useDirs (concatMap fst moduleNames)
-          lift $ setTargets $ map (\mod -> (Target (TargetModule (GHC.mkModuleName mod)) True Nothing)) 
-                                  (concatMap snd moduleNames)
-          liftIO $ putStrLn "Compiling modules. This may take some time. Please wait."
-          lift $ load LoadAllTargets
-          allMods <- lift getModuleGraph
-          mods <- lift $ forM allMods loadModule
-          liftIO $ putStrLn "All modules loaded. Use 'SelectModule module-name' to select a module"
-          modify $ refSessMods .= Map.fromList mods
-          liftIO $ hSetBuffering stdout NoBuffering
-          when ("-dry-run" `elem` flags) $ modify (dryMode .= True)
+  where printSrcErrors err = do dfs <- getSessionDynFlags 
+                                liftIO $ printBagOfErrors dfs (srcErrorMessages err)
 
-        loadModule :: ModSummary -> Ghc ((FilePath, String, IsBoot), TypedModule)
-        loadModule ms = 
-          do mm <- parseTyped ms
-             let modName = GHC.moduleNameString $ moduleName $ ms_mod ms
-                 wd = srcDirFromRoot (fromJust $ ml_hs_file $ ms_location ms) modName            
-             liftIO $ putStrLn ("Loaded module: " ++ modName)
-             return ((wd, modName, case ms_hsc_src ms of HsSrcFile -> NormalHs; _ -> IsHsBoot), mm)
+        initializeSession :: Handle -> [FilePath] -> [String] -> CLIRefactorSession ()
+        initializeSession output workingDirs flags = do
+          liftIO $ hSetBuffering output NoBuffering
+          liftIO $ hPutStrLn output "Compiling modules. This may take some time. Please wait."
+          (_, ignoredMods) <- loadPackagesFrom (\ms -> liftIO $ hPutStrLn output ("Loaded module: " ++ modSumName ms)) workingDirs
+          when (not $ null ignoredMods) 
+            $ liftIO $ hPutStrLn output 
+            $ "The following modules are ignored: " 
+                ++ concat (intersperse ", " $ ignoredMods)
+                ++ ". Multiple modules with the same qualified name are not supported."
+          liftIO $ hPutStrLn output "All modules loaded. Use 'SelectModule module-name' to select a module"
+          when ("-dry-run" `elem` flags) $ modify (dryMode .= True)
 
-        runSession :: [String] -> RefactorSession Ghc String
-        runSession flags | "-one-shot" `elem` flags
+        runSession :: Handle -> Handle -> [String] -> CLIRefactorSession ()
+        runSession _ output flags | "-one-shot" `elem` flags
           = let modName = catMaybes $ map (\f -> case splitOn "=" f of ["-module-name", mod] -> Just mod; _ -> Nothing) flags
                 refactoring = catMaybes $ map (\f -> case splitOn "=" f of ["-refactoring", ref] -> Just ref; _ -> Nothing) flags
              in case (modName, refactoring) of 
                   ([modName],[refactoring]) ->
-                    do performSessionCommand (LoadModule modName)
-                       command <- readSessionCommand (takeWhile (/='"') $ dropWhile (=='"') $ refactoring)
-                       performSessionCommand command
-                  _ -> return usageMessage
-        runSession _ = runSessionLoop
+                    do performSessionCommand output (LoadModule modName)
+                       command <- readSessionCommand output (takeWhile (/='"') $ dropWhile (=='"') $ refactoring)
+                       performSessionCommand output command
+                  _ -> liftIO $ hPutStrLn output usageMessage
+        runSession input output _ = runSessionLoop input output
 
-        runSessionLoop :: RefactorSession Ghc String
-        runSessionLoop = do 
+        runSessionLoop :: Handle -> Handle -> CLIRefactorSession ()
+        runSessionLoop input output = do 
           actualMod <- gets (^. actualMod)
-          liftIO $ putStr (maybe "no-module-selected" (\(_,m,_) -> m) actualMod ++ ">")
-          cmd <- liftIO $ getLine 
-          sessionComm <- readSessionCommand cmd
-          liftIO . putStrLn =<< performSessionCommand sessionComm
+          liftIO $ hPutStr output (maybe "no-module-selected> " (\sfk -> (sfk ^. sfkModuleName) ++ "> ") actualMod)
+          cmd <- liftIO $ hGetLine input 
+          sessionComm <- readSessionCommand output cmd
+          performSessionCommand output sessionComm
           doExit <- gets (^. exiting)
-          when (not doExit) (void runSessionLoop)
-          return ""
+          when (not doExit) (void (runSessionLoop input output))
 
         usageMessage = "Usage: ht-refact [ht-flags, ghc-flags] package-pathes\n"
                          ++ "ht-flags: -dry-run -one-shot -module-name=modulename -refactoring=\"refactoring\""
 
 data RefactorSessionCommand 
   = LoadModule String
+  | Skip
   | Exit
   | RefactorCommand RefactorCommand
   deriving Show
 
-readSessionCommand :: Monad m => String -> RefactorSession m RefactorSessionCommand
-readSessionCommand cmd = case splitOn " " cmd of 
+readSessionCommand :: Handle -> String -> CLIRefactorSession RefactorSessionCommand
+readSessionCommand output cmd = case splitOn " " cmd of 
     ["SelectModule", mod] -> return $ LoadModule mod
     ["Exit"] -> return Exit
     _ -> do actualMod <- gets (^. actualMod)
-            case actualMod of Just (wd,m,_) -> return $ RefactorCommand $ readCommand (toFileName wd m) cmd
-                              Nothing -> error "Set the actual module first"
+            case actualMod of Just _ -> return $ RefactorCommand $ readCommand cmd
+                              Nothing -> do liftIO $ hPutStrLn output "Set the actual module first"
+                                            return Skip
 
-performSessionCommand :: RefactorSessionCommand -> RefactorSession Ghc String
-performSessionCommand (LoadModule mod) = do fnd <- gets (find (\(_,m,hs) -> m == mod && hs == NormalHs) . Map.keys . (^. refSessMods))
-                                            if isJust fnd then modify $ actualMod .= fnd
-                                                          else liftIO $ putStrLn ("Cannot find module: " ++ mod)
-                                            return ""
-performSessionCommand Exit = do modify $ exiting .= True
-                                return ""
-performSessionCommand (RefactorCommand cmd) 
-  = do RefactorSessionState { _refSessMods = mods, _actualMod = Just act@(_, mod, _) } <- get
-       res <- lift $ performCommand cmd (mod, mods Map.! act) (map (\((_,m,_),mod) -> (m,mod)) $ Map.assocs (Map.delete act mods))
+performSessionCommand :: Handle -> RefactorSessionCommand -> CLIRefactorSession ()
+performSessionCommand output (LoadModule modName) = do 
+  mod <- gets (lookupModInSCs (SourceFileKey NormalHs modName) . (^. refSessMCs))
+  if isJust mod then modify $ actualMod .= fmap fst mod
+                else liftIO $ hPutStrLn output ("Cannot find module: " ++ modName)
+performSessionCommand _ Skip = return ()
+performSessionCommand _ Exit = modify $ exiting .= True
+performSessionCommand output (RefactorCommand cmd) 
+  = do actMod <- gets (^. actualMod)
+       (Just actualMod, otherMods) <- getMods actMod
+       res <- lift $ performCommand cmd actualMod otherMods
        inDryMode <- gets (^. dryMode)
-       case res of Left err -> return err
-                   Right resMods -> performChanges inDryMode resMods
-                     
-  where performChanges False resMods = do 
-          mss <- forM resMods $ \case 
+       case res of Left err -> liftIO $ hPutStrLn output err
+                   Right resMods -> performChanges output inDryMode resMods
+
+  where performChanges output False resMods = do 
+          changedMods <- forM resMods $ \case 
+            ModuleCreated n m otherM -> do 
+              Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs))
+              let Just otherMS = otherMR ^? modRecMS
+              otherSrcDir <- liftIO $ getSourceDir otherMS
+              let loc = srcDirFromRoot otherSrcDir n
+              liftIO $ withBinaryFile loc WriteMode (`hPutStr` prettyPrint m)
+              return (SourceFileKey NormalHs n)
             ContentChanged (n,m) -> do
-              let modName = semanticsModule $ m ^. semantics
+              let modName = semanticsModule m
               ms <- getModSummary modName (isBootModule $ m ^. semantics)
-              let isBoot = case ms_hsc_src ms of HsSrcFile -> NormalHs; _ -> IsHsBoot
-              Just (workingDir,_,_) <- gets (find (\(_,m,b) -> m == n && b == isBoot) . Map.keys . (^. refSessMods))
-              liftIO $ withBinaryFile ((case isBoot of NormalHs -> toFileName; IsHsBoot -> toBootFileName) workingDir n) 
-                                      WriteMode (`hPutStr` prettyPrint m)
-              return $ Just (n, workingDir, modName, isBoot)
+              let file = fromJust $ ml_hs_file $ ms_location ms
+              liftIO $ withBinaryFile file WriteMode (`hPutStr` prettyPrint m)
+              return n
             ModuleRemoved mod -> do
-              Just (workingDir,_,_) <- gets (find (\(_,m,b) -> m == mod) . Map.keys . (^. refSessMods))
-              liftIO $ removeFile (toFileName workingDir mod)
-              modify $ refSessMods .- Map.delete (workingDir, mod, IsHsBoot) . Map.delete (workingDir, mod, NormalHs)
-              return Nothing
-          lift $ load LoadAllTargets
-          forM_ (catMaybes mss) $ \(n, workingDir, modName, isBoot) -> do
-              -- TODO: add target if module is added as a change
-              ms <- getModSummary modName (isBoot == IsHsBoot)
-              newm <- lift $ parseTyped ms
-              modify $ refSessMods .- Map.insert (workingDir, n, isBoot) newm
-              liftIO $ putStrLn ("Re-loaded module: " ++ n)
-          return ""
-        performChanges True resMods = concat <$> forM resMods (liftIO . \case 
+              Just (_,m) <- gets (lookupModInSCs (SourceFileKey NormalHs mod) . (^. refSessMCs))
+              case ( fmap semanticsModule (m ^? typedRecModule) <|> fmap semanticsModule (m ^? renamedRecModule)
+                   , fmap isBootModule (m ^? typedRecModule) <|> fmap isBootModule (m ^? renamedRecModule)) of 
+                (Just modName, Just isBoot) -> do
+                  ms <- getModSummary modName isBoot
+                  let file = fromJust $ ml_hs_file $ ms_location ms
+                  modify $ (refSessMCs .- removeModule mod)
+                  liftIO $ removeFile file
+                _ -> do liftIO $ hPutStrLn output ("Module " ++ mod ++ " could not be removed.")
+              return (SourceFileKey NormalHs mod)
+          void $ reloadChangedModules (hPutStrLn output . ("Re-loaded module: " ++) . modSumName) 
+                   (\ms -> keyFromMS ms `elem` changedMods)
+        performChanges output True resMods = forM_ resMods (liftIO . \case 
           ContentChanged (n,m) -> do
-            return $ "### UModule changed: " ++ n ++ "\n### new content:\n" ++ prettyPrint m
+            hPutStrLn output $ "### Module changed: " ++ (n ^. sfkModuleName) ++ "\n### new content:\n" ++ prettyPrint m
           ModuleRemoved mod ->
-            return $ "### UModule removed: " ++ mod)
+            hPutStrLn output $ "### Module removed: " ++ mod)
 
         getModSummary name boot
           = do allMods <- lift getModuleGraph
                return $ fromJust $ find (\ms -> ms_mod ms == name && (ms_hsc_src ms == HsSrcFile) /= boot) allMods 
+
+instance IsRefactSessionState CLISessionState where
+  refSessMCs = refactState & _refSessMCs
+  initSession = CLISessionState initSession Nothing False False

@@ -1,24 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}
-module Language.Haskell.Tools.Refactor.Session where
-
-import Data.Map as Map
-import Control.Monad.State
-import Control.Reference
-
-import Language.Haskell.Tools.AST (IdDom)
-import Language.Haskell.Tools.Refactor (IsBoot(..))
-import Language.Haskell.Tools.Refactor.RefactorBase (UnnamedModule)
-
-type RefactorSession = StateT RefactorSessionState
-
-data RefactorSessionState
-  = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom)
-                         , _actualMod :: Maybe (String, String, IsBoot)
-                         , _exiting :: Bool
-                         , _dryMode :: Bool
-                         }
-
-initSession :: RefactorSessionState
-initSession = RefactorSessionState Map.empty Nothing False False
-
-makeReferences ''RefactorSessionState

@@ -0,0 +1,174 @@+
+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , TypeFamilies
+           , RecordWildCards
+           , DeriveGeneric
+           #-}
+module Main where
+
+import Criterion.Measurement hiding (runBenchmark)
+import Criterion.Types hiding(measure)
+
+import qualified Data.ByteString.Lazy.Char8 as LazyBS (pack, unpack)
+import qualified Data.ByteString.Char8 as BS (pack, unpack)
+import Data.Aeson
+import Data.Knob
+import GHC.Generics
+import System.FilePath
+import System.Directory
+import System.IO
+import Control.Monad
+import Control.Exception
+import System.Environment
+import Data.List
+import Data.List.Split
+import Data.Time.Clock
+import Data.Time.Calendar
+
+import Language.Haskell.Tools.Refactor.CLI
+
+rootDir = ".." </> ".." </> "examples"
+
+main :: IO ()
+main = do
+  args <- getArgs
+  (year, month, day) <- date
+  cases <- bms2Mcases (Date {..}) bms
+  case args of 
+    [file] -> writeFile file (show $ encode cases)
+    _ -> putStrLn $ LazyBS.unpack $ encode cases
+  putStrLn "Execution times (cycles):"
+  mapM_ (\c -> putStrLn $ "# " ++ bmId (bm c) ++ ": " ++ showGrouped (measCycles (ms c))) cases
+    where showGrouped = reverse . concat . intersperse " " . chunksOf 3 . reverse . show
+
+date :: IO (Integer,Int,Int) -- (year,month,day)
+date = getCurrentTime >>= return . toGregorian . utctDay
+
+data Date = Date { year  :: Integer
+                 , month :: Int
+                 , day   :: Int
+                 }
+  deriving (Eq, Show, Generic)
+
+data BM = BM { bmId       :: String
+             , workingDir :: FilePath
+             , refactors  :: [String]
+             }
+  deriving (Eq, Show, Generic)
+
+data BMCase = BMCase { bm :: BM
+                     , ms :: Measured
+                     , dt :: Date
+                     }
+  deriving (Eq, Show, Generic)
+
+instance FromJSON Date
+instance ToJSON Date
+instance FromJSON BM
+instance ToJSON BM
+instance FromJSON BMCase
+instance ToJSON BMCase
+
+bms :: [BM]
+bms = [ BM { bmId = "full-1", workingDir = rootDir </> "CppHs", refactors = [
+          "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "ExtractBinding 182:8-182:36 parseResult"
+        , "RenameDefinition 181:1 gDefined"
+        , "GenerateSignature 51:5-51:5"
+        , "GenerateSignature 50:5-50:5"
+        , "GenerateSignature 49:5-49:5"
+        , "ExtractBinding 47:46-47:64 linesFixed"
+        , "RenameDefinition 46:1 cppIfDef"
+        , "OrganizeImports"
+        , "Exit"
+        ]  }
+      , BM { bmId = "full-2", workingDir = rootDir </> "CppHs", refactors = [
+          "SelectModule Language.Preprocessor.Cpphs.MacroPass"
+        , "ExtractBinding 96:29-96:47 tokenizeTT"
+        , "ExtractBinding 90:11-90:67 fun"
+        , "OrganizeImports"
+        , "Exit"
+        ]  }
+      , BM { bmId = "full-3", workingDir = rootDir </> "CppHs", refactors = [
+          "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "ExtractBinding 182:8-182:36 parseResult"
+        , "RenameDefinition 181:1 gDefined"
+        , "SelectModule Language.Preprocessor.Cpphs.MacroPass"
+        , "ExtractBinding 96:29-96:47 tokenizeTT"
+        , "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "GenerateSignature 51:5-51:5"
+        , "GenerateSignature 50:5-50:5"
+        , "GenerateSignature 49:5-49:5"
+        , "SelectModule Language.Preprocessor.Cpphs.MacroPass"
+        , "ExtractBinding 90:11-90:67 fun"
+        , "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "ExtractBinding 47:46-47:64 linesFixed"
+        , "RenameDefinition 46:1 cppIfDef"
+        , "OrganizeImports"
+        , "Exit"
+        ]  }
+      , BM { bmId = "3xGenerateTypeSignature", workingDir = rootDir </> "CppHs", refactors = [
+          "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "GenerateSignature 51:5-51:5"
+        , "GenerateSignature 50:5-50:5"
+        , "GenerateSignature 49:5-49:5"
+        , "Exit"
+        ]  }
+      , BM { bmId ="selects", workingDir = rootDir </> "CppHs", refactors = [
+          "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "SelectModule Language.Preprocessor.Cpphs.MacroPass"
+        , "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "SelectModule Language.Preprocessor.Cpphs.MacroPass"
+        , "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "SelectModule Language.Preprocessor.Cpphs.MacroPass"
+        , "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "SelectModule Language.Preprocessor.Cpphs.MacroPass"
+        , "SelectModule Language.Preprocessor.Cpphs.CppIfdef"
+        , "Exit"
+        ]  }
+      , BM { bmId ="empty", workingDir = rootDir </> "CppHs", refactors = [ "Exit" ] }
+      ]
+
+
+
+bms2Mcases :: Date -> [BM] -> IO [BMCase]
+bms2Mcases = mapM . bm2Mcase
+
+runBenchmark :: Benchmarkable -> IO Measured
+runBenchmark bm = fst <$> (measure bm 1)
+
+bm2Mms :: BM -> IO Measured
+bm2Mms (BM { .. }) = runBenchmark $ benchmakable workingDir refactors
+
+bm2Mcase :: Date -> BM -> IO BMCase
+bm2Mcase d bm = BMCase bm <$> (bm2Mms bm) <*> (return d)
+
+benchmakable :: String -> [String] -> Benchmarkable -- IO (Either String String)
+benchmakable wd rfs = Benchmarkable $ \ _ -> do
+  makeCliTest wd rfs
+
+makeCliTest :: String -> [String] -> IO ()
+makeCliTest wd rfs = do   
+    copyDir wd (wd ++ "_orig")
+    inKnob <- newKnob (BS.pack $ unlines rfs)
+    inHandle <- newFileHandle inKnob "<input>" ReadMode
+    outKnob <- newKnob (BS.pack [])
+    outHandle <- newFileHandle outKnob "<output>" WriteMode
+    refactorSession inHandle outHandle [wd]
+  `finally` do removeDirectoryRecursive wd
+               renameDirectory (wd ++ "_orig") wd
+
+
+copyDir ::  FilePath -> FilePath -> IO ()
+copyDir src dst = do
+  createDirectory dst
+  content <- getDirectoryContents src
+  let xs = filter (`notElem` [".", ".."]) content
+  forM_ xs $ \name -> do
+    let srcPath = src </> name
+    let dstPath = dst </> name
+    isDirectory <- doesDirectoryExist srcPath
+    if isDirectory
+      then copyDir srcPath dstPath
+      else copyFile srcPath dstPath

@@ -1,8 +1,9 @@ module Main where
 
+import System.IO
 import System.Environment
 
 import Language.Haskell.Tools.Refactor.CLI
 
 main :: IO ()
-main = putStrLn =<< refactorSession =<< getArgs
+main = refactorSession stdin stdout =<< getArgs

@@ -1,5 +1,5 @@ name:                haskell-tools-cli
-version:             0.3.0.1
+version:             0.4.0.0
 synopsis:            Command-line frontend for Haskell-tools Refact
 description:         Command-line frontend for Haskell-tools Refact. Not meant as a final product, only for demonstration purposes.
 homepage:            https://github.com/haskell-tools/haskell-tools
@@ -12,38 +12,60 @@ cabal-version:       >=1.10
 
 library
+  ghc-options:         -O2
   build-depends:       base                      >= 4.9 && < 4.10
                      , containers                >= 0.5 && < 0.6
                      , mtl                       >= 2.2 && < 2.3
                      , split                     >= 0.2 && < 0.3
                      , directory                 >= 1.2 && < 1.3
+                     , filepath                  >= 1.4 && < 2
                      , ghc                       >= 8.0 && < 8.1
                      , ghc-paths                 >= 0.1 && < 0.2
                      , references                >= 0.3 && < 0.4
-                     , haskell-tools-ast         >= 0.3 && < 0.4
-                     , haskell-tools-prettyprint >= 0.3 && < 0.4
-                     , haskell-tools-refactor    >= 0.3 && < 0.4
+                     , haskell-tools-ast         >= 0.4 && < 0.5
+                     , haskell-tools-prettyprint >= 0.4 && < 0.5
+                     , haskell-tools-refactor    >= 0.4 && < 0.5
   exposed-modules:     Language.Haskell.Tools.Refactor.CLI
-                     , Language.Haskell.Tools.Refactor.Session
   default-language:    Haskell2010
 
 
 executable ht-refact
+  ghc-options:         -O2
   build-depends:       base                      >= 4.9 && < 4.10
-                     , haskell-tools-cli         >= 0.3 && < 0.4
+                     , haskell-tools-cli         >= 0.4 && < 0.5
   hs-source-dirs:      exe
   main-is:             Main.hs
   default-language:    Haskell2010
   
 test-suite haskell-tools-cli-tests
   type:                exitcode-stdio-1.0
-  ghc-options:         -with-rtsopts=-M2g
+  ghc-options:         -with-rtsopts=-M2g -O2
   hs-source-dirs:      test
   main-is:             Main.hs  
   build-depends:       base                      >= 4.9 && < 4.10
-                     , HUnit                     >= 1.3 && < 1.4
+                     , tasty                     >= 0.11 && < 0.12
+                     , tasty-hunit               >= 0.9 && < 0.10
                      , directory                 >= 1.2 && < 1.3
                      , filepath                  >= 1.4 && < 2.0
-                     , haskell-tools-cli         >= 0.3 && < 0.4
+                     , haskell-tools-cli         >= 0.4 && < 0.5
+                     , knob                      >= 0.1 && < 0.2
+                     , bytestring                >= 0.10 && < 0.11
   default-language:    Haskell2010
+
+benchmark cli-benchmark
+  type:                exitcode-stdio-1.0
+  ghc-options:         -with-rtsopts=-M2g -O2
+  build-depends:       base                      >= 4.9 && < 4.10
+                     , haskell-tools-cli         >= 0.4 && < 0.5
+                     , criterion                 >= 1.1 && < 1.2
+                     , time                      >= 1.6 && < 1.7
+                     , aeson                     >= 0.11 && < 0.12
+                     , directory                 >= 1.2 && < 1.3
+                     , filepath                  >= 1.4 && < 2.0
+                     , knob                      >= 0.1 && < 0.2
+                     , bytestring                >= 0.10 && < 0.11
+                     , split                     >= 0.2 && < 0.3
+  hs-source-dirs:      benchmark
+  main-is:             Main.hs  
+
 

@@ -1,40 +1,159 @@ module Main where
 
-import Test.HUnit
+import Test.Tasty
+import Test.Tasty.HUnit
+
 import System.Exit
+import System.Directory
 import System.FilePath
+import Control.Monad
+import Control.Exception
+import qualified Data.List as List
+import Data.Knob
+import Data.ByteString.Char8 (pack, unpack)
+import System.IO
 
 import Language.Haskell.Tools.Refactor.CLI
 
 main :: IO ()
-main = run allTests
-
-run :: [Test] -> IO ()
-run tests = do results <- runTestTT $ TestList tests
-               if errors results + failures results > 0 
-                  then exitFailure
-                  else exitSuccess
+main = do nightlyTests <- benchTests
+          defaultMain $ testGroup "cli tests" (allTests ++ nightlyTests)
 
-allTests :: [Test]
+allTests :: [TestTree]
 allTests = map makeCliTest cliTests
 
-makeCliTest :: (String, [String], String) -> Test
-makeCliTest (dir, args, expected) = TestLabel dir $ TestCase $ do 
-    res <- refactorSession (args ++ [dir])
-    assertEqual "" (filter (/= '\r') expected) (filter (/= '\r') res)
+makeCliTest :: ([FilePath], [String], String, String) -> TestTree
+makeCliTest (dirs, args, input, output) = let dir = joinPath $ longestCommonPrefix $ map splitDirectories dirs
+                                              testdirs = map (((dir ++ "_test") </>) . makeRelative dir) dirs
+  in testCase dir $ do   
+    exists <- doesDirectoryExist (dir ++ "_test")
+    when exists $ removeDirectoryRecursive (dir ++ "_test")
+    copyDir dir (dir ++ "_test")
+    inKnob <- newKnob (pack input)
+    inHandle <- newFileHandle inKnob "<input>" ReadMode
+    outKnob <- newKnob (pack [])
+    outHandle <- newFileHandle outKnob "<output>" WriteMode
+    res <- refactorSession inHandle outHandle (args ++ testdirs)
+    actualOut <- Data.Knob.getContents outKnob
+    assertEqual "" (filter (/= '\r') output) (filter (/= '\r') $ unpack actualOut)
+  `finally` removeDirectoryRecursive (dir ++ "_test")
 
-cliTests :: [(String, [String], String)]
+cliTests :: [([FilePath], [String], String, String)]
 cliTests 
-  = [ ( ".." </> ".." </> "examples" </> "Project" </> "source-dir"
+  = [ ( [testRoot </> "Project" </> "source-dir"]
       , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] 
-      , "### UModule changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()")
-    , ( ".." </> ".." </> "examples" </> "Project" </> "source-dir-outside"
+      , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n")
+    , ( [testRoot </> "Project" </> "source-dir-outside"]
       , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] 
-      , "### UModule changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()")
-    , ( ".." </> ".." </> "examples" </> "Project" </> "no-cabal"
+      , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n")
+    , ( [testRoot </> "Project" </> "no-cabal"]
       , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] 
-      , "### UModule changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()")
-    , ( ".." </> ".." </> "examples" </> "Project" </> "has-cabal"
+      , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n")
+    , ( [testRoot </> "Project" </> "has-cabal"]
       , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] 
-      , "### UModule changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()")
-    ]+      , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n")
+    , ( [testRoot </> "Project" </> "selection"], [] 
+      , "SelectModule C\nSelectModule B\nRenameDefinition 5:1-5:2 bb\nSelectModule C\nRenameDefinition 3:1-3:2 cc\nExit"
+      , prefixText ["C","B"] ++ "no-module-selected> C> B> " 
+          ++ reloads ["B"] ++ "B> C> "
+          ++ reloads ["C", "B"] ++ "C> "
+          )
+    , ( [testRoot </> "Project" </> "reloading"], [] 
+      , "SelectModule C\nRenameDefinition 3:1-3:2 cc\nSelectModule B\nRenameDefinition 5:1-5:2 bb\nExit"
+      , prefixText ["C","B","A"] ++ "no-module-selected> C> " 
+          ++ reloads ["C", "B", "A"] ++ "C> B> "
+          ++ reloads ["B", "A"] ++ "B> ")
+    , ( map ((testRoot </> "Project" </> "multi-packages") </>) ["package1", "package2"]
+      , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], ""
+      , prefixText ["B", "A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = ()\n" 
+      )
+    , ( map ((testRoot </> "Project" </> "multi-packages-flags") </>) ["package1", "package2"]
+      , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], ""
+      , prefixText ["B", "A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = \\case () -> ()\n"
+      )
+    , ( map ((testRoot </> "Project" </> "multi-packages-same-module") </>) ["package1", "package2"]
+      , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], ""
+      , "Compiling modules. This may take some time. Please wait.\nLoaded module: A\n" 
+          ++ "The following modules are ignored: A. Multiple modules with the same qualified name are not supported.\n"
+          ++ "All modules loaded. Use 'SelectModule module-name' to select a module\n" 
+          ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = ()\n"
+      )
+    ]
+
+benchTests :: IO [TestTree]
+benchTests 
+  = forM ["full-1", "full-2", "full-3"] $ \id -> do
+      commands <- readFile ("bench-tests" </> id <.> "txt")
+      return $ makeCliTest ([".." </> ".." </> "examples" </> "CppHs"], [], filter (/='\r') commands, expectedOut id)
+
+expectedOut "full-1" 
+  = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.CppIfdef> "
+      ++ concat (replicate 8 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> "))
+expectedOut "full-2" 
+  = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.MacroPass> "
+      ++ concat (replicate 3 (reloads macroPassReloads ++ "Language.Preprocessor.Cpphs.MacroPass> "))
+expectedOut "full-3"
+  = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.CppIfdef> "
+      ++ concat (replicate 2 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> "))
+      ++ "Language.Preprocessor.Cpphs.MacroPass> "
+      ++ reloads macroPassReloads ++ "Language.Preprocessor.Cpphs.MacroPass> "
+      ++ "Language.Preprocessor.Cpphs.CppIfdef> "
+      ++ concat (replicate 3 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> "))
+      ++ "Language.Preprocessor.Cpphs.MacroPass> "
+      ++ reloads macroPassReloads ++ "Language.Preprocessor.Cpphs.MacroPass> "
+      ++ "Language.Preprocessor.Cpphs.CppIfdef> "
+      ++ concat (replicate 3 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> "))
+
+cppIfDefReloads = [ "Language.Preprocessor.Cpphs.CppIfdef" 
+                  , "Language.Preprocessor.Cpphs.RunCpphs"
+                  , "Language.Preprocessor.Cpphs" ]
+macroPassReloads = "Language.Preprocessor.Cpphs.MacroPass" : cppIfDefReloads
+
+cppHsMods = [ "Language.Preprocessor.Cpphs.Options"
+            , "Language.Preprocessor.Cpphs.SymTab"
+            , "Language.Preprocessor.Cpphs.Position"
+            , "Language.Preprocessor.Cpphs.ReadFirst"
+            , "Language.Preprocessor.Cpphs.HashDefine"
+            , "Language.Preprocessor.Cpphs.Tokenise"
+            , "Language.Preprocessor.Cpphs.MacroPass"
+            , "Language.Preprocessor.Cpphs.CppIfdef"
+            , "Language.Preprocessor.Unlit"
+            , "Language.Preprocessor.Cpphs.RunCpphs"
+            , "Language.Preprocessor.Cpphs" ]
+
+testRoot = ".." </> ".." </> "examples"
+
+prefixText :: [String] -> String
+prefixText mods 
+  = "Compiling modules. This may take some time. Please wait.\n" 
+      ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods 
+      ++ "All modules loaded. Use 'SelectModule module-name' to select a module\n"
+
+reloads :: [String] -> String
+reloads mods = concatMap (\m -> "Re-loaded module: " ++ m ++ "\n") mods 
+
+copyDir ::  FilePath -> FilePath -> IO ()
+copyDir src dst = do
+  exists <- doesDirectoryExist dst
+  -- clear the target directory from possible earlier test runs
+  when exists $ removeDirectoryRecursive dst
+  createDirectory dst
+  content <- getDirectoryContents src
+  let xs = filter (`notElem` [".", ".."]) content
+  forM_ xs $ \name -> do
+    let srcPath = src </> name
+    let dstPath = dst </> name
+    isDirectory <- doesDirectoryExist srcPath
+    if isDirectory
+      then copyDir srcPath dstPath
+      else copyFile srcPath dstPath
+
+commonPrefix :: (Eq e) => [e] -> [e] -> [e]
+commonPrefix _ [] = []
+commonPrefix [] _ = []
+commonPrefix (x:xs) (y:ys)
+  | x == y    = x : commonPrefix xs ys
+  | otherwise = []
+
+longestCommonPrefix :: (Eq a) => [[a]] -> [a]
+longestCommonPrefix = foldl1 commonPrefix