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 Data.Char
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
import Language.Haskell.Tools.Refactor.GetModules
import Language.Haskell.Tools.Refactor.Perform
import Language.Haskell.Tools.Refactor.Session
type CLIRefactorSession = StateT CLISessionState Ghc
data CLISessionState =
CLISessionState { _refactState :: RefactorSessionState
, _actualMod :: Maybe SourceFileKey
, _exiting :: Bool
, _dryMode :: Bool
}
makeReferences ''CLISessionState
deriving instance Show PkgConfRef
tryOut :: IO ()
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 Bool
refactorSession input output args = runGhc (Just libdir) $ handleSourceError printSrcErrors
$ flip evalStateT initSession $
do lift $ initGhcFlags
workingDirsAndHtFlags <- lift $ useFlags args
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
liftIO $ hSetBuffering output NoBuffering
liftIO $ hPutStrLn output "Compiling modules. This may take some time. Please wait."
res <- loadPackagesFrom (\ms -> liftIO $ hPutStrLn output ("Loaded module: " ++ modSumName ms)) (const $ return ()) (\_ _ -> return []) workingDirs
case res of
Right (_, ignoredMods) -> do
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 $ 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 (displayException err)
return False
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 output (LoadModule modName)
command <- readSessionCommand output (takeWhile (/='"') $ dropWhile (=='"') $ refactoring)
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
runSessionLoop :: Handle -> Handle -> CLIRefactorSession ()
runSessionLoop input output = do
actualMod <- gets (^. actualMod)
liftIO $ hPutStr output (maybe "no-module-selected> " (\sfk -> (sfk ^. sfkModuleName) ++ "> ") actualMod)
cmd <- liftIO $ hGetLine input
sessionComm <- readSessionCommand output cmd
changedMods <- performSessionCommand output sessionComm
void $ reloadChangedModules (hPutStrLn output . ("Re-loaded module: " ++) . modSumName) (const $ return ())
(\ms -> keyFromMS ms `elem` changedMods)
doExit <- gets (^. exiting)
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 :: Handle -> String -> CLIRefactorSession RefactorSessionCommand
readSessionCommand output cmd = case (splitOn " " cmd) of
["SelectModule", mod] -> return $ LoadModule mod
["Exit"] -> return Exit
cm | head cm `elem` refactorCommands
-> do actualMod <- gets (^. actualMod)
case readCommand cmd of
Right cmd ->
case actualMod of Just _ -> return $ RefactorCommand cmd
Nothing -> do liftIO $ hPutStrLn output "Set the actual module first"
return Skip
Left err -> do liftIO $ hPutStrLn output err
return Skip
_ -> do liftIO $ hPutStrLn output $ "'" ++ cmd ++ "' is not a known command. Commands are: SelectModule, Exit, "
++ intercalate ", " refactorCommands
return Skip
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)
return []
performSessionCommand _ Skip = return []
performSessionCommand _ Exit = do modify $ exiting .= True
return []
performSessionCommand output (RefactorCommand cmd)
= do actMod <- gets (^. actualMod)
(actualMod, otherMods) <- getMods actMod
res <- case actualMod of
Just mod -> lift $ performCommand cmd mod otherMods
Nothing -> case otherMods of (hd:rest) -> lift $ performCommand cmd hd rest
[] -> return (Right [])
inDryMode <- gets (^. dryMode)
case res of Left err -> do liftIO $ hPutStrLn output err
return []
Right resMods -> performChanges output inDryMode resMods
where performChanges output False resMods =
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 $ \handle -> do
hSetEncoding handle utf8
hPutStr handle (prettyPrint m)
return (SourceFileKey NormalHs n)
ContentChanged (n,m) -> do
let modName = semanticsModule m
ms <- getModSummary modName (isBootModule $ m ^. semantics)
let file = fromJust $ ml_hs_file $ ms_location ms
liftIO $ withBinaryFile file WriteMode $ \handle -> do
hSetEncoding handle utf8
hPutStr handle (prettyPrint m)
return n
ModuleRemoved mod -> do
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)
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
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