module Language.Haskell.Tools.Refactor.CLI (refactorSession) where
import System.Directory
import System.IO
import qualified Data.Map as Map
import Data.Maybe
import Data.List
import Data.List.Split
import Control.Monad.State
import Control.Reference
import GHC
import HscTypes as GHC
import Module as GHC
import GHC.Paths ( libdir )
import Language.Haskell.Tools.PrettyPrint
import Language.Haskell.Tools.Refactor
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/backend-ghc", "src/prettyprint", "src/rewrite", "src/refactor"]
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
if null workingDirs then return usageMessage
else do initializeSession workingDirs htFlags
runSession 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)
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)
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)
command <- readSessionCommand (takeWhile (/='"') $ dropWhile (=='"') $ refactoring)
performSessionCommand command
_ -> return usageMessage
runSession _ = runSessionLoop
runSessionLoop :: RefactorSession Ghc String
runSessionLoop = do
actualMod <- gets (^. actualMod)
liftIO $ putStr (maybe "no-module-selected" (\(_,m,_) -> m) actualMod ++ ">")
cmd <- liftIO $ getLine
sessionComm <- readSessionCommand cmd
liftIO . putStrLn =<< performSessionCommand sessionComm
doExit <- gets (^. exiting)
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\""
data RefactorSessionCommand
= LoadModule String
| Exit
| RefactorCommand RefactorCommand
deriving Show
readSessionCommand :: Monad m => String -> RefactorSession m RefactorSessionCommand
readSessionCommand 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"
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))
inDryMode <- gets (^. dryMode)
case res of Left err -> return err
Right resMods -> performChanges inDryMode resMods
where performChanges False resMods = do
mss <- forM resMods $ \case
ContentChanged (n,m) -> do
let modName = semanticsModule $ m ^. semantics
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)
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
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
ContentChanged (n,m) -> do
return $ "### UModule changed: " ++ n ++ "\n### new content:\n" ++ prettyPrint m
ModuleRemoved mod ->
return $ "### UModule removed: " ++ mod)
getModSummary name boot
= do allMods <- lift getModuleGraph
return $ fromJust $ find (\ms -> ms_mod ms == name && (ms_hsc_src ms == HsSrcFile) /= boot) allMods