module Language.Haskell.Refact.Utils.Utils
(
sameOccurrence
, getModuleGhc
, parseSourceFileGhc
, activateModule
, getModuleDetails
, runRefacSession
, applyRefac
, refactDone
, ApplyRefacResult
, RefacSource(..)
, update
, fileNameToModName
, fileNameFromModSummary
, getModuleName
, clientModsAndFiles
, serverModsAndFiles
) where
import Control.Monad.State
import Data.List
import Data.Maybe
import Language.Haskell.GhcMod
import Language.Haskell.Refact.Utils.DualTree
import Language.Haskell.Refact.Utils.GhcBugWorkArounds
import Language.Haskell.Refact.Utils.GhcModuleGraph
import Language.Haskell.Refact.Utils.GhcUtils
import Language.Haskell.Refact.Utils.GhcVersionSpecific
import Language.Haskell.Refact.Utils.LocUtils
import Language.Haskell.Refact.Utils.Monad
import Language.Haskell.Refact.Utils.MonadFunctions
import Language.Haskell.Refact.Utils.TypeSyn
import Language.Haskell.Refact.Utils.TypeUtils
import System.Directory
import System.FilePath.Posix
import qualified Digraph as GHC
import qualified FastString as GHC
import qualified GHC
import qualified Outputable as GHC
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
fileNameToModName :: FilePath -> RefactGhc GHC.ModuleName
fileNameToModName fileName = do
mm <- getModuleMaybe fileName
case mm of
Nothing -> error $ "Can't find module name"
Just ms -> return $ GHC.moduleName $ GHC.ms_mod ms
getModuleMaybe :: FilePath -> RefactGhc (Maybe GHC.ModSummary)
getModuleMaybe fileName = do
cfileName <- liftIO $ canonicalizePath fileName
graphs <- gets rsGraph
currentTgt <- gets rsCurrentTarget
logm $ "getModuleMaybe " ++ show fileName ++ ":" ++ show (length graphs,currentTgt)
let cgraph = concatMap (\(_,cg) -> cg) graphs
let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph
case mm of
[] -> return Nothing
_ -> do
let (_mfn,ms) = (ghead "getModuleMaybe" mm)
return $ Just ms
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)
getModuleGhc ::
FilePath -> RefactGhc ()
getModuleGhc targetFile = do
mTarget <- identifyTargetModule targetFile
case mTarget of
Nothing -> return ()
Just tm -> do
void $ activateModule tm
return ()
mm <- getModuleMaybe targetFile
case mm of
Just ms -> getModuleDetails ms
Nothing -> parseSourceFileGhc targetFile
identifyTargetModule :: FilePath -> RefactGhc (Maybe TargetModule)
identifyTargetModule targetFile = do
currentDirectory <- liftIO getCurrentDirectory
target1 <- liftIO $ canonicalizePath targetFile
target2 <- liftIO $ canonicalizePath (combine currentDirectory targetFile)
graphs <- gets rsModuleGraph
let ff = catMaybes $ map (findInTarget target1 target2) graphs
case ff of
[] -> return Nothing
ms -> return (Just (ghead ("identifyTargetModule:" ++ (show ms)) ms))
findInTarget :: FilePath -> FilePath -> ([FilePath],GHC.ModuleGraph) -> Maybe TargetModule
findInTarget f1 f2 (fps,graph) = r'
where
re :: Maybe TargetModule
re = case fps of
[x] -> re'
where
re' = case filter isMainModSummary graph of
[] -> Nothing
ms -> if x == f1 || x == f2 then Just (fps,ghead "findInTarget" ms)
else Nothing
_ -> Nothing
isMainModSummary ms = (show $ GHC.ms_mod ms) == "Main"
r = case filter (compModFiles f1 f2) graph of
[] -> Nothing
ms -> Just (fps,ghead "findInTarget.2" ms)
compModFiles :: FilePath-> FilePath -> GHC.ModSummary -> Bool
compModFiles fileName1 fileName2 ms =
case GHC.ml_hs_file $ GHC.ms_location ms of
Nothing -> False
Just fn -> fn == fileName1 || fn == fileName2
r' = listToMaybe $ catMaybes [r,re]
activateModule :: TargetModule -> RefactGhc GHC.ModSummary
activateModule (target, modSum) = do
logm $ "activateModule:" ++ show (target,GHC.ms_mod modSum)
newModSum <- ensureTargetLoaded (target,modSum)
getModuleDetails newModSum
return newModSum
getModuleDetails :: GHC.ModSummary -> RefactGhc ()
getModuleDetails modSum = do
p <- GHC.parseModule modSum
t <- GHC.typecheckModule p
setGhcContext modSum
tokens <- getRichTokenStreamWA (GHC.ms_mod modSum)
mtm <- gets rsModule
case mtm of
Just tm -> if ((rsStreamModified tm == False)
&& ((GHC.mkFastString $ fileNameFromModSummary modSum) ==
(fileNameFromTok $ ghead "getModuleDetails" tokens)))
then return ()
else if rsStreamModified tm == False
then putParsedModule t tokens
else error $ "getModuleDetails: trying to load a module without finishing with active one."
Nothing -> putParsedModule t tokens
return ()
parseSourceFileGhc :: FilePath -> RefactGhc ()
parseSourceFileGhc targetFile = do
loadModuleGraphGhc (Just [targetFile])
mm <- getModuleMaybe targetFile
case mm of
Nothing -> error $ "HaRe:unexpected error parsing " ++ targetFile
Just modSum -> getModuleDetails modSum
type ApplyRefacResult = ((FilePath, Bool), ([Line],[PosToken], GHC.RenamedSource))
runRefacSession ::
RefactSettings
-> Cradle
-> RefactGhc [ApplyRefacResult]
-> IO [FilePath]
runRefacSession settings cradle comp = do
let
initialState = RefSt
{ rsSettings = settings
, rsUniqState = 1
, rsFlags = RefFlags False
, rsStorage = StorageNone
, rsGraph = []
, rsModuleGraph = []
, rsCurrentTarget = Nothing
, rsModule = Nothing
}
(refactoredMods,_s) <- runRefactGhc (initGhcSession cradle (rsetImportPaths settings) >>
comp) initialState
let verbosity = rsetVerboseLevel (rsSettings initialState)
writeRefactoredFiles verbosity refactoredMods
return $ modifiedFiles refactoredMods
data RefacSource = RSFile FilePath
| RSMod GHC.ModSummary
| RSAlreadyLoaded
applyRefac
:: RefactGhc a
-> RefacSource
-> RefactGhc (ApplyRefacResult,a)
applyRefac refac source = do
fileName <- case source of
RSFile fname -> do getModuleGhc fname
return fname
RSMod ms -> do getModuleGhc $ 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' <- getRefactRenamed
toks' <- fetchToksFinal
linesVal <- fetchLinesFinal
m <- getRefactStreamModified
clearParsedModule
return (((fileName,m),(linesVal,toks', mod')),res)
refactDone :: [ApplyRefacResult] -> Bool
refactDone rs = any (\((_,d),_) -> d) rs
modifiedFiles :: [ApplyRefacResult] -> [String]
modifiedFiles refactResult = map (\((s,_),_) -> s)
$ filter (\((_,b),_) -> b) refactResult
fileNameFromModSummary :: GHC.ModSummary -> FilePath
fileNameFromModSummary modSummary = fileName
where
Just fileName = GHC.ml_hs_file (GHC.ms_location modSummary)
class (SYB.Data t, SYB.Data t1) => Update t t1 where
update:: t
-> t
-> t1
-> RefactGhc t1
instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.Located (GHC.HsExpr n)) t where
update oldExp newExp t
= everywhereMStaged SYB.Parser (SYB.mkM inExp) t
where
inExp (e::GHC.Located (GHC.HsExpr n))
| sameOccurrence e oldExp
= do
_ <- updateToks oldExp newExp prettyprint False
return newExp
| otherwise = return e
instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.LPat n) t where
update oldPat newPat t
= everywhereMStaged SYB.Parser (SYB.mkM inPat) t
where
inPat (p::GHC.LPat n)
| sameOccurrence p oldPat
= do
_ <- updateToks oldPat newPat prettyprint False
return newPat
| otherwise = return p
instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.LHsType n) t where
update oldTy newTy t
= everywhereMStaged SYB.Parser (SYB.mkM inTyp) t
where
inTyp (t'::GHC.LHsType n)
| sameOccurrence t' oldTy
= do
_ <- updateToks oldTy newTy prettyprint False
return newTy
| otherwise = return t'
instance (SYB.Data t, GHC.OutputableBndr n1, GHC.OutputableBndr n2, SYB.Data n1, SYB.Data n2) => Update (GHC.LHsBindLR n1 n2) t where
update oldBind newBind t
= everywhereMStaged SYB.Parser (SYB.mkM inBind) t
where
inBind (t'::GHC.LHsBindLR n1 n2)
| sameOccurrence t' oldBind
= do
_ <- updateToks oldBind newBind prettyprint False
return newBind
| otherwise = return t'
writeRefactoredFiles ::
VerboseLevel -> [ApplyRefacResult] -> IO ()
writeRefactoredFiles verbosity files
= do let filesModified = filter (\((_f,m),_) -> m == modified) files
sequence_ (map modifyFile filesModified)
where
modifyFile ((fileName,_),(finalLines,ts,renamed)) = do
let ts' = bypassGHCBug7351 ts
let source = renderLines finalLines
let (baseFileName,ext) = splitExtension fileName
seq (length source) (writeFile (baseFileName ++ ".refactored" ++ ext) source)
when (verbosity == Debug) $
do
writeFile (fileName ++ ".tokens") (showToks ts')
writeFile (fileName ++ ".renamed_out") (showGhc renamed)
writeFile (fileName ++ ".AST_out") $ ((showGhc renamed) ++
"\n\n----------------------\n\n" ++
(SYB.showData SYB.Renamer 0 renamed))
clientModsAndFiles
:: GHC.ModuleName -> RefactGhc [([FilePath],GHC.ModSummary)]
clientModsAndFiles m = do
modsum <- GHC.getModSummary m
ms' <- gets rsModuleGraph
let getClients ms = clientMods
where
mg = getModulesAsGraph False ms Nothing
rg = GHC.transposeG mg
maybeModNode = find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg)
clientMods = case maybeModNode of
Nothing -> []
Just modNode ->
filter (\msum' -> not (mycomp msum' modsum))
$ map summaryNodeSummary $ GHC.reachableG rg modNode
let clients = concatMap (\(f,mg) -> zip (repeat f) (getClients mg)) ms'
clients' = nubBy cc clients
cc (_,mg1) (_,mg2)
= if (show $ GHC.ms_mod mg1) == "Main" || (show $ GHC.ms_mod mg2) == "Main"
then False
else mycomp mg1 mg2
logm $ "clientModsAndFiles:clients=" ++ show clients
logm $ "clientModsAndFiles:clients'=" ++ show clients'
return clients'
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
instance (Show GHC.ModuleName) where
show = GHC.moduleNameString