haskell-tools-cli 0.4.1.3 → 0.5.0.0
raw patch · 8 files changed
+250/−51 lines, 8 filesdep +processdep ~aesondep ~haskell-tools-astdep ~haskell-tools-clinew-component:exe:ht-test-hackagenew-component:exe:ht-test-stackagePVP ok
version bump matches the API change (PVP)
Dependencies added: process
Dependency ranges changed: aeson, haskell-tools-ast, haskell-tools-cli, haskell-tools-prettyprint, haskell-tools-refactor
API changes (from Hackage documentation)
+ Language.Haskell.Tools.Refactor.CLI: instance GHC.Show.Show DynFlags.PkgConfRef
- Language.Haskell.Tools.Refactor.CLI: refactorSession :: Handle -> Handle -> [String] -> IO ()
+ Language.Haskell.Tools.Refactor.CLI: refactorSession :: Handle -> Handle -> [String] -> IO Bool
Files
- Language/Haskell/Tools/Refactor/CLI.hs +56/−30
- benchmark/Main.hs +1/−1
- examples/Project/illegal-extension/A.hs +2/−0
- exe/Main.hs +5/−1
- haskell-tools-cli.cabal +28/−9
- test-hackage/Main.hs +72/−0
- test-stackage/Main.hs +66/−0
- test/Main.hs +20/−10
Language/Haskell/Tools/Refactor/CLI.hs view
@@ -3,22 +3,28 @@ , FlexibleContexts , TemplateHaskell , TypeFamilies + , StandaloneDeriving #-} module Language.Haskell.Tools.Refactor.CLI (refactorSession, tryOut) where import Control.Applicative ((<|>)) +import Control.Exception (displayException) import Control.Monad.State import Control.Reference import Data.List import Data.List.Split import Data.Maybe import System.Directory +import System.Exit import System.IO +import DynFlags as GHC import ErrUtils import GHC import GHC.Paths ( libdir ) import HscTypes as GHC +import Outputable +import Packages import Language.Haskell.Tools.PrettyPrint import Language.Haskell.Tools.Refactor @@ -37,23 +43,28 @@ makeReferences ''CLISessionState +deriving instance Show PkgConfRef + tryOut :: IO () -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"] +tryOut = void $ 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 +refactorSession :: Handle -> Handle -> [String] -> IO Bool +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 liftIO $ hPutStrLn output usageMessage - else do doRun <- initializeSession output workingDirs htFlags - when doRun $ runSession input output htFlags + let (htFlags, workingDirs) = partition (\case ('-':_) -> True; _ -> False) workingDirsAndHtFlags + if null workingDirs then do liftIO $ hPutStrLn output usageMessage + return False + else do initSuccess <- initializeSession output workingDirs htFlags + when initSuccess $ runSession input output htFlags + return initSuccess where printSrcErrors err = do dfs <- getSessionDynFlags liftIO $ printBagOfErrors dfs (srcErrorMessages err) + return False initializeSession :: Handle -> [FilePath] -> [String] -> CLIRefactorSession Bool initializeSession output workingDirs flags = do @@ -67,10 +78,13 @@ $ "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" + + liftIO . hPutStrLn output $ if ("-one-shot" `elem` flags) + then "All modules loaded." + else "All modules loaded. Use 'SelectModule module-name' to select a module." when ("-dry-run" `elem` flags) $ modify (dryMode .= True) return True - Left err -> liftIO $ do hPutStrLn output err + Left err -> liftIO $ do hPutStrLn output (displayException err) return False runSession :: Handle -> Handle -> [String] -> CLIRefactorSession () @@ -81,7 +95,9 @@ ([modName],[refactoring]) -> do performSessionCommand output (LoadModule modName) command <- readSessionCommand output (takeWhile (/='"') $ dropWhile (=='"') $ refactoring) - performSessionCommand output command + void $ performSessionCommand output command + ([],["ProjectOrganizeImports"]) -> + void $ performSessionCommand output (RefactorCommand ProjectOrganizeImports) _ -> liftIO $ hPutStrLn output "-module-name or -refactoring flag not specified correctly. Not doing any refactoring." runSession input output _ = runSessionLoop input output @@ -91,7 +107,9 @@ liftIO $ hPutStr output (maybe "no-module-selected> " (\sfk -> (sfk ^. sfkModuleName) ++ "> ") actualMod) cmd <- liftIO $ hGetLine input sessionComm <- readSessionCommand output cmd - performSessionCommand output sessionComm + changedMods <- performSessionCommand output sessionComm + void $ reloadChangedModules (hPutStrLn output . ("Re-loaded module: " ++) . modSumName) + (\ms -> keyFromMS ms `elem` changedMods) doExit <- gets (^. exiting) when (not doExit) (void (runSessionLoop input output)) @@ -114,23 +132,30 @@ Nothing -> do liftIO $ hPutStrLn output "Set the actual module first" return Skip -performSessionCommand :: Handle -> RefactorSessionCommand -> CLIRefactorSession () +performSessionCommand :: Handle -> RefactorSessionCommand -> CLIRefactorSession [SourceFileKey] 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 + return [] +performSessionCommand _ Skip = return [] +performSessionCommand _ Exit = do modify $ exiting .= True + return [] performSessionCommand output (RefactorCommand cmd) = do actMod <- gets (^. actualMod) - (Just actualMod, otherMods) <- getMods actMod - res <- lift $ performCommand cmd actualMod otherMods + (actualMod, otherMods) <- getMods actMod + res <- case actualMod of + Just mod -> lift $ performCommand cmd mod otherMods + -- WALKAROUND: support running refactors that need no module selected + Nothing -> case otherMods of (hd:rest) -> lift $ performCommand cmd hd rest + [] -> return (Right []) inDryMode <- gets (^. dryMode) - case res of Left err -> liftIO $ hPutStrLn output err + case res of Left err -> do liftIO $ hPutStrLn output err + return [] Right resMods -> performChanges output inDryMode resMods - where performChanges output False resMods = do - changedMods <- forM resMods $ \case + where performChanges output False resMods = + forM resMods $ \case ModuleCreated n m otherM -> do Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs)) let Just otherMS = otherMR ^? modRecMS @@ -155,15 +180,15 @@ 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 - hPutStrLn output $ "### Module changed: " ++ (n ^. sfkModuleName) ++ "\n### new content:\n" ++ prettyPrint m - ModuleRemoved mod -> - hPutStrLn output $ "### Module removed: " ++ mod - ModuleCreated n m _ -> - hPutStrLn output $ "### Module created: " ++ n ++ "\n### new content:\n" ++ prettyPrint m) + performChanges output True resMods = do + forM_ resMods (liftIO . \case + ContentChanged (n,m) -> do + hPutStrLn output $ "### Module changed: " ++ (n ^. sfkModuleName) ++ "\n### new content:\n" ++ prettyPrint m + ModuleRemoved mod -> + hPutStrLn output $ "### Module removed: " ++ mod + ModuleCreated n m _ -> + hPutStrLn output $ "### Module created: " ++ n ++ "\n### new content:\n" ++ prettyPrint m) + return [] getModSummary name boot = do allMods <- lift getModuleGraph @@ -172,3 +197,4 @@ instance IsRefactSessionState CLISessionState where refSessMCs = refactState & _refSessMCs initSession = CLISessionState initSession Nothing False False +
benchmark/Main.hs view
@@ -155,7 +155,7 @@ inHandle <- newFileHandle inKnob "<input>" ReadMode outKnob <- newKnob (BS.pack []) outHandle <- newFileHandle outKnob "<output>" WriteMode - refactorSession inHandle outHandle [wd] + void $ refactorSession inHandle outHandle [wd] `finally` do removeDirectoryRecursive wd renameDirectory (wd ++ "_orig") wd
+ examples/Project/illegal-extension/A.hs view
@@ -0,0 +1,2 @@+{-# LANGUAGE CPP #-} +module A where
exe/Main.hs view
@@ -2,8 +2,12 @@ import System.IO import System.Environment +import System.Exit import Language.Haskell.Tools.Refactor.CLI main :: IO () -main = refactorSession stdin stdout =<< getArgs +main = exit =<< refactorSession stdin stdout =<< getArgs + where exit :: Bool -> IO () + exit True = exitSuccess + exit False = exitFailure
haskell-tools-cli.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-cli -version: 0.4.1.3 +version: 0.5.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 @@ -29,6 +29,7 @@ , examples/Project/multi-packages-same-module/package2/*.hs , examples/Project/multi-packages-same-module/package2/*.cabal , examples/Project/no-cabal/*.hs + , examples/Project/illegal-extension/*.hs , examples/Project/reloading/*.hs , examples/Project/selection/*.hs , examples/Project/source-dir/*.cabal @@ -47,21 +48,39 @@ , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , references >= 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 + , haskell-tools-ast >= 0.5 && < 0.6 + , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-refactor >= 0.5 && < 0.6 exposed-modules: Language.Haskell.Tools.Refactor.CLI default-language: Haskell2010 executable ht-refact - ghc-options: -O2 + ghc-options: -O2 -rtsopts build-depends: base >= 4.9 && < 4.10 - , haskell-tools-cli >= 0.4 && < 0.5 + , haskell-tools-cli >= 0.5 && < 0.6 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 +executable ht-test-hackage + build-depends: base >= 4.9 && < 4.10 + , directory >= 1.2 && < 1.4 + , process >= 1.4 && < 1.5 + , split >= 0.2 && < 0.3 + hs-source-dirs: test-hackage + main-is: Main.hs + default-language: Haskell2010 + +executable ht-test-stackage + build-depends: base >= 4.9 && < 4.10 + , directory >= 1.2 && < 1.4 + , process >= 1.4 && < 1.5 + , split >= 0.2 && < 0.3 + hs-source-dirs: test-stackage + main-is: Main.hs + default-language: Haskell2010 + test-suite haskell-tools-cli-tests type: exitcode-stdio-1.0 ghc-options: -with-rtsopts=-M2g -O2 @@ -72,7 +91,7 @@ , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 - , haskell-tools-cli >= 0.4 && < 0.5 + , haskell-tools-cli >= 0.5 && < 0.6 , knob >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 default-language: Haskell2010 @@ -81,10 +100,10 @@ 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 + , haskell-tools-cli >= 0.5 && < 0.6 , criterion >= 1.1 && < 1.2 , time >= 1.6 && < 1.7 - , aeson >= 1.0 && < 1.1 + , aeson >= 1.0 && < 1.2 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 , knob >= 0.1 && < 0.2
+ test-hackage/Main.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase + #-} +module Main where + +import Control.Applicative +import Control.Monad +import System.Directory +import System.Process +import System.Environment +import System.Exit +import Data.List +import Data.List.Split + +data Result = GetFailure + | DepInstallFailure + | BuildFailure + | RefactError + | WrongCodeError + | OK + deriving Show + +main :: IO () +main = do args <- getArgs + testHackage args + +testHackage :: [String] -> IO () +testHackage args = do + createDirectoryIfMissing False workDir + withCurrentDirectory workDir $ do + unsetEnv "GHC_PACKAGE_PATH" + callCommand "cabal update" + callCommand "cabal list --simple > packages.txt 2>&1" + packages <- map (map (\case ' ' -> '-'; c -> c)) . lines <$> readFile "packages.txt" + alreadyTested <- if noRetest then do appendFile resultFile "" + map (head . splitOn ";") . filter (not . null) . lines + <$> readFile "results.csv" + else writeFile resultFile "" >> return [] + putStrLn $ "Skipping " ++ show (length alreadyTested) ++ " already tested packages" + let filteredPackages = packages \\ alreadyTested + mapM_ testAndEvaluate filteredPackages + where workDir = "hackage-test" + resultFile = "results.csv" + + noRetest = "-no-retest" `elem` args + testAndEvaluate p = do + res <- testPackage p + appendFile resultFile (p ++ ";" ++ show res ++ "\n") + + +testPackage :: String -> IO Result +testPackage pack = do + downloaded <- doesDirectoryExist pack + getSuccess <- if not downloaded then waitForProcess =<< runCommand ("cabal get " ++ pack) + else return ExitSuccess + case getSuccess of + ExitSuccess -> + withCurrentDirectory pack $ do + callCommand "cabal sandbox init" + runCommands [ ("cabal install -j --only-dependencies --enable-tests --enable-benchmarks > deps-log.txt 2>&1", DepInstallFailure) + , ("cabal configure --enable-tests --enable-benchmarks > config-log.txt 2>&1", BuildFailure) + , ("cabal build -j > build-log.txt 2>&1", BuildFailure) + , ("ht-refact -one-shot -refactoring=ProjectOrganizeImports -package-db .cabal-sandbox\\x86_64-windows-ghc-8.0.1-packages.conf.d . +RTS -M6G -RTS > refact-log.txt 2>&1", RefactError) + , ("cabal build > reload-log.txt 2>&1", WrongCodeError) + ] + ExitFailure _ -> return GetFailure + +runCommands :: [(String, Result)] -> IO Result +runCommands [] = return OK +runCommands ((cmd,failRes):rest) = do + exitCode <- waitForProcess =<< runCommand cmd + case exitCode of ExitSuccess -> runCommands rest + ExitFailure _ -> return failRes
+ test-stackage/Main.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE LambdaCase + #-} +module Main where + +import Control.Applicative +import Control.Monad +import System.Directory +import System.Process +import System.Environment +import System.Exit +import Control.Concurrent +import Data.List +import Data.List.Split + +data Result = GetFailure + | BuildFailure + | RefactError + | WrongCodeError + | OK + deriving Show + +main :: IO () +main = do args <- getArgs + testHackage args + +testHackage :: [String] -> IO () +testHackage args = do + createDirectoryIfMissing False workDir + withCurrentDirectory workDir $ do + packages <- lines <$> readFile (last args) + alreadyTested <- if noRetest then do appendFile resultFile "" + map (head . splitOn ";") . filter (not . null) . lines + <$> readFile resultFile + else writeFile resultFile "" >> return [] + let filteredPackages = packages \\ alreadyTested + createDirectoryIfMissing False "logs" + mapM_ testAndEvaluate filteredPackages + where workDir = "stackage-test" + resultFile = "results.csv" + + noRetest = "-no-retest" `elem` args + testAndEvaluate p = do + res <- testPackage p + appendFile resultFile (p ++ ";" ++ show res ++ "\n") + + +testPackage :: String -> IO Result +testPackage pack = + runCommands [ Left ("cabal get " ++ pack, GetFailure) + , Right $ do threadDelay 1000000 + createDirectoryIfMissing False testedDir + removeDirectoryRecursive testedDir + renameDirectory pack testedDir + , Left ("stack build --test --no-run-tests --bench --no-run-benchmarks > logs\\" ++ pack ++ "-build-log.txt 2>&1", BuildFailure) + , Left ("stack exec ht-refact -- -one-shot -refactoring=ProjectOrganizeImports tested-package +RTS -M6G -RTS > logs\\" ++ pack ++ "-refact-log.txt 2>&1", RefactError) + , Left ("stack build > logs\\" ++ pack ++ "-reload-log.txt 2>&1", WrongCodeError) + ] + where testedDir = "tested-package" + +runCommands :: [Either (String, Result) (IO ())] -> IO Result +runCommands [] = return OK +runCommands (Left (cmd,failRes) : rest) = do + exitCode <- waitForProcess =<< runCommand cmd + case exitCode of ExitSuccess -> runCommands rest + ExitFailure _ -> return failRes +runCommands (Right act : rest) = act >> runCommands rest
test/Main.hs view
@@ -42,16 +42,16 @@ cliTests = [ ( [testRoot </> "Project" </> "source-dir"] , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] - , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") + , "", oneShotPrefix ["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\""] - , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") + , "", oneShotPrefix ["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\""] - , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") + , "", oneShotPrefix ["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\""] - , "", prefixText ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") + , "", oneShotPrefix ["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> " @@ -65,19 +65,22 @@ ++ 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" + , oneShotPrefix ["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" + , oneShotPrefix ["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" + ++ "All modules loaded.\n" ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = ()\n" ) + , ( [testRoot </> "Project" </> "illegal-extension"] + , ["-dry-run", "-one-shot"] + , "", "Compiling modules. This may take some time. Please wait.\nThe following extensions are not allowed: CPP.\n") ] benchTests :: IO [TestTree] @@ -109,15 +112,15 @@ , "Language.Preprocessor.Cpphs" ] macroPassReloads = "Language.Preprocessor.Cpphs.MacroPass" : cppIfDefReloads -cppHsMods = [ "Language.Preprocessor.Cpphs.Options" +cppHsMods = [ "Language.Preprocessor.Unlit" , "Language.Preprocessor.Cpphs.SymTab" , "Language.Preprocessor.Cpphs.Position" , "Language.Preprocessor.Cpphs.ReadFirst" + , "Language.Preprocessor.Cpphs.Options" , "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" ] @@ -127,7 +130,14 @@ 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" + ++ "All modules loaded. Use 'SelectModule module-name' to select a module.\n" + +oneShotPrefix :: [String] -> String +oneShotPrefix mods + = "Compiling modules. This may take some time. Please wait.\n" + ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods + ++ "All modules loaded.\n" + reloads :: [String] -> String reloads mods = concatMap (\m -> "Re-loaded module: " ++ m ++ "\n") mods