module Language.Haskell.Refact.Utils.Utils
(
getTargetGhc
, parseSourceFileGhc
, runRefacSession
, applyRefac
, applyRefac'
, refactDone
, fileNameFromModSummary
, getModuleName
, clientModsAndFiles
, serverModsAndFiles
, runMultRefacSession
, modifiedFiles
, writeRefactoredFiles
, stripCallStack
) where
import Control.Monad.Identity
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.IORef
import Language.Haskell.GHC.ExactPrint.Preprocess
import Language.Haskell.GHC.ExactPrint.Print
import Language.Haskell.GHC.ExactPrint.Utils
import qualified GhcMod as GM
import qualified GhcMod.Target as GM
import qualified GhcMod.Types as GM
import Language.Haskell.Refact.Utils.GhcModuleGraph
import Language.Haskell.Refact.Utils.GhcVersionSpecific
import Language.Haskell.Refact.Utils.Monad
import Language.Haskell.Refact.Utils.MonadFunctions
import Language.Haskell.Refact.Utils.Types
import System.Directory
import System.FilePath.Posix
import qualified Digraph as GHC
import qualified DynFlags as GHC
import qualified GHC as GHC
import qualified Hooks as GHC
import qualified HscMain as GHC
import qualified HscTypes as GHC
import qualified TcRnMonad as GHC
import qualified Data.Map as Map
import qualified Data.Set as Set
getModuleName :: GHC.ParsedSource -> Maybe (GHC.ModuleName,String)
getModuleName (GHC.L _ modn) =
case (GHC.hsmodName modn) of
Nothing -> Nothing
Just (GHC.L _ modname) -> Just $ (modname,GHC.moduleNameString modname)
getTargetGhc :: TargetModule -> RefactGhc ()
getTargetGhc (GM.ModulePath _mn fp) = parseSourceFileGhc fp
parseSourceFileGhc :: FilePath -> RefactGhc ()
parseSourceFileGhc targetFile = do
logm $ "parseSourceFileGhc:targetFile=" ++ show targetFile
cfileName <- liftIO $ canonicalizePath targetFile
logm $ "parseSourceFileGhc:cfileName=" ++ show cfileName
ref <- liftIO $ newIORef (cfileName,Nothing)
let
setTarget fileName = RefactGhc $ GM.runGmlT' [Left fileName] (installHooks ref) (return ())
setTarget cfileName
logm $ "parseSourceFileGhc:after setTarget"
(_,mtm) <- liftIO $ readIORef ref
logm $ "parseSourceFileGhc:isJust mtm:" ++ show (isJust mtm)
graph <- GHC.getModuleGraph
cgraph <- canonicalizeGraph graph
let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph
case mm of
[(_,modSum)] -> loadFromModSummary mtm modSum
_ -> error $ "HaRe:unexpected error parsing " ++ targetFile
installHooks :: (Monad m) => IORef (FilePath,Maybe TypecheckedModule) -> GHC.DynFlags -> m GHC.DynFlags
installHooks ref dflags = return $ dflags {
GHC.hooks = (GHC.hooks dflags) {
#if __GLASGOW_HASKELL__ <= 710
GHC.hscFrontendHook = Just $ hscFrontend ref
#else
GHC.hscFrontendHook = Just $ runHscFrontend ref
#endif
}
}
#if __GLASGOW_HASKELL__ > 710
runHscFrontend :: IORef (FilePath,Maybe TypecheckedModule) -> GHC.ModSummary -> GHC.Hsc GHC.FrontendResult
runHscFrontend ref mod_summary
= GHC.FrontendTypecheck `fmap` hscFrontend ref mod_summary
#endif
hscFrontend :: IORef (FilePath,Maybe TypecheckedModule) -> GHC.ModSummary -> GHC.Hsc GHC.TcGblEnv
hscFrontend ref mod_summary = do
(mfn,_) <- canonicalizeModSummary mod_summary
(fn,_) <- liftIO $ readIORef ref
let
keepInfo = case mfn of
Just fileName -> fn == fileName
Nothing -> False
if keepInfo
then do
let modSumWithRaw = tweakModSummaryDynFlags mod_summary
hsc_env <- GHC.getHscEnv
let hsc_env_tmp = hsc_env { GHC.hsc_dflags = GHC.ms_hspp_opts modSumWithRaw }
hpm <- liftIO $ GHC.hscParse hsc_env_tmp modSumWithRaw
let p = GHC.ParsedModule mod_summary
(GHC.hpm_module hpm)
(GHC.hpm_src_files hpm)
(GHC.hpm_annotations hpm)
hsc_env' <- GHC.getHscEnv
(tc_gbl_env,rn_info) <- liftIO $ GHC.hscTypecheckRename hsc_env' mod_summary hpm
details <- liftIO $ GHC.makeSimpleDetails hsc_env' tc_gbl_env
let
tc =
TypecheckedModule {
tmParsedModule = p,
tmRenamedSource = gfromJust "hscFrontend" rn_info,
tmTypecheckedSource = GHC.tcg_binds tc_gbl_env,
tmMinfExports = GHC.md_exports details,
tmMinfRdrEnv = Just (GHC.tcg_rdr_env tc_gbl_env)
}
liftIO $ modifyIORef' ref (const (fn,Just tc))
return tc_gbl_env
else do
hpm <- GHC.hscParse' mod_summary
hsc_env <- GHC.getHscEnv
tc_gbl_env <- GHC.tcRnModule' hsc_env mod_summary False hpm
return tc_gbl_env
tweakModSummaryDynFlags :: GHC.ModSummary -> GHC.ModSummary
tweakModSummaryDynFlags ms =
let df = GHC.ms_hspp_opts ms
in ms { GHC.ms_hspp_opts = GHC.gopt_set df GHC.Opt_KeepRawTokenStream }
loadFromModSummary :: Maybe TypecheckedModule -> GHC.ModSummary -> RefactGhc ()
loadFromModSummary mtm modSum = do
logm $ "loadFromModSummary:modSum=" ++ show modSum
t <- case mtm of
Nothing -> do
let modSumWithRaw = tweakModSummaryDynFlags modSum
p <- GHC.parseModule modSumWithRaw
t' <- GHC.typecheckModule p
let
tm = TypecheckedModule
{ tmParsedModule = p
, tmRenamedSource = gfromJust "loadFromModSummary" $ GHC.tm_renamed_source t'
, tmTypecheckedSource = GHC.tm_typechecked_source t'
, tmMinfExports = error $ "loadFromModSummary:not visible in ModuleInfo 1"
, tmMinfRdrEnv = error $ "loadFromModSummary:not visible in ModuleInfo 2"
}
return tm
Just tm -> return tm
cppComments <- if True
then do
logm $ "loadFromModSummary:CPP flag set"
case GHC.ml_hs_file $ GHC.ms_location modSum of
Just fileName -> getCppTokensAsComments defaultCppOptions fileName
Nothing -> return []
else do
logm $ "loadFromModSummary:no CPP"
return []
setGhcContext modSum
(mfp,_modSum) <- canonicalizeModSummary modSum
newTargetModule <- case mfp of
Nothing -> error $ "HaRe:no file path for module:" ++ showGhc modSum
Just fp -> return $ GM.ModulePath (GHC.moduleName $ GHC.ms_mod modSum) fp
oldTargetModule <- gets rsCurrentTarget
let
putModule = do
putParsedModule cppComments t
settings <- get
put $ settings { rsCurrentTarget = Just newTargetModule }
mtm' <- gets rsModule
case mtm' of
Just tm -> if ((rsStreamModified tm == RefacUnmodifed)
&& oldTargetModule == Just newTargetModule)
then do
logm $ "loadFromModSummary:not calling putParsedModule for targetModule=" ++ show newTargetModule
return ()
else if rsStreamModified tm == RefacUnmodifed
then putModule
else error $ "loadFromModSummary: trying to load a module without finishing with active one."
Nothing -> putModule
return ()
runRefacSession ::
RefactSettings
-> GM.Options
-> RefactGhc [ApplyRefacResult]
-> IO [FilePath]
runRefacSession settings opt comp = do
let
initialState = RefSt
{ rsSettings = settings
, rsUniqState = 1
, rsSrcSpanCol = 1
, rsFlags = RefFlags False
, rsStorage = StorageNone
, rsCurrentTarget = Nothing
, rsModule = Nothing
}
(refactoredMods,_s) <- runRefactGhc comp initialState opt
let verbosity = rsetVerboseLevel (rsSettings initialState)
writeRefactoredFiles verbosity refactoredMods
return $ modifiedFiles refactoredMods
runMultRefacSession :: RefactSettings -> GM.Options -> [RefactGhc [ApplyRefacResult]] -> IO [FilePath]
runMultRefacSession settings opt comps = do
let
initialState = RefSt
{ rsSettings = settings
, rsUniqState = 1
, rsSrcSpanCol = 1
, rsFlags = RefFlags False
, rsStorage = StorageNone
, rsCurrentTarget = Nothing
, rsModule = Nothing
}
results <- threadState opt initialState comps
let (_, finState) = last results
verbosity = rsetVerboseLevel (rsSettings finState)
refResults = map fst results
merged = mergeRefResults refResults
writeRefactoredFiles verbosity merged
return $ modifiedFiles merged
mergeRefResults :: [[ApplyRefacResult]] -> [ApplyRefacResult]
mergeRefResults lst = Map.elems $ mergeHelp lst Map.empty
where mergeHelp [] mp = mp
mergeHelp (x:xs) mp = mergeHelp xs (foldl insertRefRes mp x)
insertRefRes mp res@((fp,RefacModified), _) = Map.insert fp res mp
insertRefRes mp _ = mp
threadState :: GM.Options -> RefactState -> [RefactGhc [ApplyRefacResult]]
-> IO [([ApplyRefacResult], RefactState)]
threadState _ _ [] = return []
threadState opt currState (rGhc : rst) = do
res@(_rGhcRes, newState) <- runRefactGhc rGhc currState opt
let (Just modu) = rsModule newState
newMod = modu {rsStreamModified = RefacUnmodifed}
nextState = newState {rsModule = Just newMod }
rest <- threadState opt nextState rst
return (res : rest)
cdAndDo :: FilePath -> IO a -> IO a
cdAndDo path fn = do
old <- getCurrentDirectory
r <- GHC.gbracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old)
$ const fn
return r
applyRefac :: RefactGhc a -> RefacSource -> RefactGhc (ApplyRefacResult, a)
applyRefac = applyRefac' True
applyRefac'
::
Bool
-> RefactGhc a
-> RefacSource
-> RefactGhc (ApplyRefacResult,a)
applyRefac' clearSt refac source = do
fileName <- case source of
RSFile fname -> do parseSourceFileGhc fname
return fname
RSTarget tgt -> do getTargetGhc tgt
return (GM.mpPath tgt)
RSMod ms -> do parseSourceFileGhc $ fileNameFromModSummary ms
return $ fileNameFromModSummary ms
RSAlreadyLoaded -> do mfn <- getRefactFileName
case mfn of
Just fname -> return fname
Nothing -> error "applyRefac RSAlreadyLoaded: nothing loaded"
res <- refac
mod' <- getRefactParsed
anns <- fetchAnnsFinal
m <- getRefactStreamModified
if clearSt
then clearParsedModule
else return ()
absFileName <- liftIO $ canonicalizePath fileName
return (((absFileName,m),(anns, mod')),res)
refactDone :: [ApplyRefacResult] -> Bool
refactDone rs = any (\((_,d),_) -> d == RefacModified) rs
modifiedFiles :: [ApplyRefacResult] -> [String]
modifiedFiles refactResult = map (\((s,_),_) -> s)
$ filter (\((_,b),_) -> b == RefacModified) refactResult
writeRefactoredFiles ::
VerboseLevel -> [ApplyRefacResult] -> IO ()
writeRefactoredFiles verbosity files
= do let filesModified = filter (\((_f,m),_) -> m == RefacModified) files
sequence_ (map modifyFile filesModified)
where
modifyFile ((fileName,_),(ann,parsed)) = do
let
exactPrintNormal ast as = runIdentity (exactPrintWithOptions stringOptions ast as)
let source = exactPrintNormal parsed ann
let (baseFileName,ext) = splitExtension fileName
seq (length source) (writeFile (baseFileName ++ ".refactored" ++ ext) source)
when (verbosity == Debug) $
do
writeFile (fileName ++ ".parsed_out") (showGhc parsed)
writeFile (fileName ++ ".AST_out") ((showGhc parsed) ++
"\n\n----------------------\n\n" ++
(showAnnData ann 0 parsed) ++
"\n\n----------------------\n\n" ++
(showGhc ann) ++
"\n\n----------------------\n\n"
)
clientModsAndFiles :: GM.ModulePath -> RefactGhc [TargetModule]
clientModsAndFiles m = do
mgs <- cabalModuleGraphs
let
flattenSwap (GM.GmModuleGraph mg)
= concatMap (\(k,vs) -> map (\v -> (v,Set.singleton k)) (Set.elems vs)) $ Map.toList mg
transposed = mgs'
where
kvs = concatMap flattenSwap mgs
mgs' = foldl' (\acc (k,v) -> Map.insertWith Set.union k v acc) Map.empty kvs
check acc k =
case Map.lookup k transposed of
Nothing -> (acc,[])
Just s -> (Set.union acc s, Set.toList $ s Set.\\ acc)
go (acc,[]) = acc
go (acc,c:s) = go (acc',s')
where
(acc',q) = check acc c
s' = nub (q ++ s)
r = go (Set.empty, [m])
return $ Set.toList r
mycomp :: GHC.ModSummary -> GHC.ModSummary -> Bool
mycomp ms1 ms2 = (GHC.ms_mod ms1) == (GHC.ms_mod ms2)
serverModsAndFiles
:: GHC.GhcMonad m => GHC.ModuleName -> m [GHC.ModSummary]
serverModsAndFiles m = do
ms <- GHC.getModuleGraph
modsum <- GHC.getModSummary m
let mg = getModulesAsGraph False ms Nothing
modNode = gfromJust "serverModsAndFiles" $ find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG mg)
serverMods = filter (\msum' -> not (mycomp msum' modsum))
$ map summaryNodeSummary $ GHC.reachableG mg modNode
return serverMods
stripCallStack :: String -> String
stripCallStack str = str'
where
s1 = init $ unlines $ takeWhile (\s -> s /= "CallStack (from HasCallStack):") $ lines str
str' = if last str == '\n'
then s1 ++ "\n"
else s1