haskell-tools-cli 0.2.0.0 → 0.3.0.0
raw patch · 5 files changed
+122/−58 lines, 5 filesdep +HUnitdep +filepathdep +haskell-tools-clidep ~basedep ~haskell-tools-astdep ~haskell-tools-prettyprint
Dependencies added: HUnit, filepath, haskell-tools-cli
Dependency ranges changed: base, haskell-tools-ast, haskell-tools-prettyprint, haskell-tools-refactor, references, split
Files
- Language/Haskell/Tools/Refactor/CLI.hs +40/−35
- Main.hs +0/−8
- exe/Main.hs +8/−0
- haskell-tools-cli.cabal +34/−15
- test/Main.hs +40/−0
Language/Haskell/Tools/Refactor/CLI.hs view
@@ -18,68 +18,71 @@ import Module as GHC import GHC.Paths ( libdir ) -import Language.Haskell.Tools.AST import Language.Haskell.Tools.PrettyPrint import Language.Haskell.Tools.Refactor -import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.Perform import Language.Haskell.Tools.Refactor.GetModules import Language.Haskell.Tools.Refactor.Session +import Debug.Trace + tryOut = refactorSession [ "-dry-run", "-one-shot", "-module-name=Language.Haskell.Tools.AST", "-refactoring=OrganizeImports" - , "-package", "ghc", "src/ast", "src/ast-trf", "src/ast-ghc", "src/ast-ppr", "src/ast-gen", "src/refactor"] + , "-package", "ghc", "src/ast", "src/backend-ghc", "src/prettyprint", "src/rewrite", "src/refactor"] -refactorSession :: [String] -> IO () +refactorSession :: [String] -> IO String refactorSession args = runGhc (Just libdir) $ flip evalStateT initSession $ do lift $ initGhcFlags workingDirsAndHtFlags <- lift $ useFlags args let (htFlags, workingDirs) = partition (\f -> head f == '-') workingDirsAndHtFlags - lift $ useDirs workingDirs - if null workingDirs then liftIO $ putStrLn usageMessage - else do moduleNames <- initializeSession workingDirs htFlags - runSession moduleNames htFlags + if null workingDirs then return usageMessage + else do initializeSession workingDirs htFlags + runSession htFlags - where initializeSession :: [FilePath] -> [String] -> RefactorSession Ghc [(FilePath, String)] + where initializeSession :: [FilePath] -> [String] -> RefactorSession Ghc () initializeSession workingDirs flags = do - moduleNames <- liftIO $ concat <$> mapM (\wd -> map (wd,) <$> getModules wd) workingDirs - lift $ setTargets (map (\(_,mod) -> (Target (TargetModule (mkModuleName mod)) True Nothing)) moduleNames) + 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 moduleNames) + 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) - return moduleNames - loadModule :: [(String, String)] -> ModSummary -> Ghc ((FilePath, String, IsBoot), TypedModule) - loadModule moduleNames ms = + loadModule :: ModSummary -> Ghc ((FilePath, String, IsBoot), TypedModule) + loadModule ms = do mm <- parseTyped ms - liftIO $ putStrLn ("Loaded module: " ++ (GHC.moduleNameString $ moduleName $ ms_mod ms)) let modName = GHC.moduleNameString $ moduleName $ ms_mod ms - Just wd = find ((modName ==) . snd) moduleNames - return ((fst wd, modName, case ms_hsc_src ms of HsSrcFile -> NormalHs; _ -> IsHsBoot), mm) + 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) - runSession :: [(String, String)] -> [String] -> RefactorSession Ghc () - runSession moduleNames flags | "-one-shot" `elem` flags + runSession :: [String] -> RefactorSession Ghc String + runSession 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) - performSessionCommand =<< readSessionCommand (dropWhile (=='"') $ takeWhile (/='"') $ refactoring) - _ -> liftIO $ putStrLn usageMessage - runSession moduleNames _ = runSessionLoop moduleNames + command <- readSessionCommand (takeWhile (/='"') $ dropWhile (=='"') $ refactoring) + performSessionCommand command + _ -> return usageMessage + runSession _ = runSessionLoop - runSessionLoop :: [(String, String)] -> RefactorSession Ghc () - runSessionLoop moduleNames = do + runSessionLoop :: RefactorSession Ghc String + runSessionLoop = do actualMod <- gets (^. actualMod) liftIO $ putStr (maybe "no-module-selected" (\(_,m,_) -> m) actualMod ++ ">") cmd <- liftIO $ getLine sessionComm <- readSessionCommand cmd - performSessionCommand sessionComm + liftIO . putStrLn =<< performSessionCommand sessionComm doExit <- gets (^. exiting) - when (not doExit) (runSessionLoop moduleNames) + when (not doExit) (void runSessionLoop) + return "" usageMessage = "Usage: ht-refact [ht-flags, ghc-flags] package-pathes\n" ++ "ht-flags: -dry-run -one-shot -module-name=modulename -refactoring=\"refactoring\"" @@ -88,6 +91,7 @@ = LoadModule String | Exit | RefactorCommand RefactorCommand + deriving Show readSessionCommand :: Monad m => String -> RefactorSession m RefactorSessionCommand readSessionCommand cmd = case splitOn " " cmd of @@ -97,16 +101,18 @@ case actualMod of Just (wd,m,_) -> return $ RefactorCommand $ readCommand (toFileName wd m) cmd Nothing -> error "Set the actual module first" -performSessionCommand :: RefactorSessionCommand -> RefactorSession Ghc () +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) -performSessionCommand Exit = modify $ exiting .= True + 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)) inDryMode <- gets (^. dryMode) - case res of Left err -> liftIO $ putStrLn err + case res of Left err -> return err Right resMods -> performChanges inDryMode resMods where performChanges False resMods = do @@ -131,13 +137,12 @@ newm <- lift $ parseTyped ms modify $ refSessMods .- Map.insert (workingDir, n, isBoot) newm liftIO $ putStrLn ("Re-loaded module: " ++ n) - performChanges True resMods = forM_ resMods $ liftIO . \case + return "" + performChanges True resMods = concat <$> forM resMods (liftIO . \case ContentChanged (n,m) -> do - putStrLn $ "### Module changed: " ++ n - putStrLn $ "### new content:" - putStrLn (prettyPrint m) + return $ "### UModule changed: " ++ n ++ "\n### new content:\n" ++ prettyPrint m ModuleRemoved mod -> - putStrLn $ "### Module removed: " ++ mod + return $ "### UModule removed: " ++ mod) getModSummary name boot = do allMods <- lift getModuleGraph
− Main.hs
@@ -1,8 +0,0 @@-module Main where - -import System.Environment - -import Language.Haskell.Tools.Refactor.CLI - -main :: IO () -main = refactorSession =<< getArgs
+ exe/Main.hs view
@@ -0,0 +1,8 @@+module Main where + +import System.Environment + +import Language.Haskell.Tools.Refactor.CLI + +main :: IO () +main = putStrLn =<< refactorSession =<< getArgs
haskell-tools-cli.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-cli -version: 0.2.0.0 +version: 0.3.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 @@ -11,20 +11,39 @@ build-type: Simple cabal-version: >=1.10 +library + 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 + , 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 + exposed-modules: Language.Haskell.Tools.Refactor.CLI + , Language.Haskell.Tools.Refactor.Session + default-language: Haskell2010 + + executable ht-refact - build-depends: base >=4.9 && <5.0 - , containers >=0.5 && <0.6 - , mtl >=2.2 && <2.3 - , split >=0.2 && <1.0 - , directory >=1.2 && <1.3 - , ghc >=8.0 && <8.1 - , ghc-paths >=0.1 && <0.2 - , references >=0.3.2 && <1.0 - , haskell-tools-ast >=0.2 && <0.3 - , haskell-tools-prettyprint >=0.2 && <0.3 - , haskell-tools-refactor >=0.2 && <0.3 + build-depends: base >= 4.9 && < 4.10 + , haskell-tools-cli >= 0.3 && < 0.4 + hs-source-dirs: exe main-is: Main.hs - other-modules: Language.Haskell.Tools.Refactor.CLI - , Language.Haskell.Tools.Refactor.Session default-language: Haskell2010 - + +test-suite haskell-tools-cli-tests + type: exitcode-stdio-1.0 + ghc-options: -with-rtsopts=-M2g + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.9 && < 4.10 + , HUnit >= 1.3 && < 1.4 + , directory >= 1.2 && < 1.3 + , filepath >= 1.4 && < 2.0 + , haskell-tools-cli >= 0.3 && < 0.4 + default-language: Haskell2010 +
+ test/Main.hs view
@@ -0,0 +1,40 @@+module Main where + +import Test.HUnit +import System.Exit +import System.FilePath + +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 + +allTests :: [Test] +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) + +cliTests :: [(String, [String], String)] +cliTests + = [ ( ".." </> ".." </> "examples" </> "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" + , ["-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" + , ["-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" + , ["-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 = ()") + ]