module Language.Haskell.Refact.Utils
(
sameOccurrence
, loadModuleGraphGhc
, getModuleGhc
, parseSourceFileGhc
, getModuleDetails
, runRefacSession
, applyRefac
, refactDone
, ApplyRefacResult
, RefacSource(..)
, update
, fileNameToModName
, fileNameFromModSummary
, getModuleName
, clientModsAndFiles
, serverModsAndFiles
, getCurrentModuleGraph
, sortCurrentModuleGraph
, pwd
) where
import Control.Monad.State
import Data.List
import Data.Maybe
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
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 qualified Digraph as GHC
import qualified DynFlags 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
pwd :: IO FilePath
pwd = getCurrentDirectory
fileNameToModName :: FilePath -> RefactGhc GHC.ModuleName
fileNameToModName fileName = do
graph <- GHC.getModuleGraph
let mm = filter (\(mfn,_ms) -> mfn == Just fileName) $
map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
case mm of
[] -> error $ "Can't find module name"
_ -> return $ GHC.moduleName $ GHC.ms_mod $ snd $ head mm
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)
loadModuleGraphGhc ::
Maybe FilePath -> RefactGhc ()
loadModuleGraphGhc maybeTargetFile = do
case maybeTargetFile of
Just targetFile -> do
target <- GHC.guessTarget (targetFile) Nothing
GHC.setTargets [target]
GHC.load GHC.LoadAllTargets
return ()
Nothing -> return ()
return ()
getModuleGhc ::
FilePath -> RefactGhc ()
getModuleGhc targetFile = do
graph <- GHC.getModuleGraph
let mm = filter (\(mfn,_ms) -> mfn == Just targetFile) $
map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
case mm of
[(_,modSum)] -> getModuleDetails modSum
_ -> parseSourceFileGhc targetFile
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 error "getModuleDetails: trying to load a module without finishing with active one"
Nothing -> putParsedModule t tokens
return ()
parseSourceFileGhc ::
String -> RefactGhc ()
parseSourceFileGhc targetFile = do
target <- GHC.guessTarget ("*" ++ targetFile) Nothing
GHC.setTargets [target]
GHC.load GHC.LoadAllTargets
graph <- GHC.getModuleGraph
let mm = filter (\(mfn,_ms) -> mfn == Just targetFile) $
map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
let [(_,modSum)] = mm
getModuleDetails modSum
type ApplyRefacResult = ((FilePath, Bool), ([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
, rsModule = Nothing
}
maybeMainFile = rsetMainFile settings
(refactoredMods,_s) <- runRefactGhc (initGhcSession cradle (rsetImportPaths settings) >>
loadModuleGraphGhc maybeMainFile >>
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
m <- getRefactStreamModified
clearParsedModule
return (((fileName,m),(toks', mod')),res)
refactDone :: [ApplyRefacResult] -> Bool
refactDone rs = any (\((_,d),_) -> d) rs
modifiedFiles :: [((String, Bool), ([PosToken], GHC.RenamedSource))] -> [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
drawTokenTree "update Located HsExpr starting"
_ <- updateToks oldExp newExp prettyprint False
drawTokenTree "update Located HsExpr done"
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
getDynFlags :: IO GHC.DynFlags
getDynFlags = getDynamicFlags
writeRefactoredFiles ::
VerboseLevel -> [((String, Bool), ([PosToken], GHC.RenamedSource))] -> IO ()
writeRefactoredFiles verbosity files
= do let filesModified = filter (\((_f,m),_) -> m == modified) files
sequence_ (map modifyFile filesModified)
where
modifyFile ((fileName,_),(ts,renamed)) = do
let ts' = bypassGHCBug7351 ts
let source = GHC.showRichTokenStream ts'
seq (length source) (writeFile (fileName ++ ".refactored") 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))
bypassGHCBug7351 :: [PosToken] -> [PosToken]
bypassGHCBug7351 ts = map go ts
where
go :: (GHC.Located GHC.Token, String) -> (GHC.Located GHC.Token, String)
go rt@(GHC.L (GHC.UnhelpfulSpan _) _t,_s) = rt
go (GHC.L (GHC.RealSrcSpan l) t,s) = (GHC.L (fixCol l) t,s)
fixCol l = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanStartLine l) ((GHC.srcSpanStartCol l) 1))
(GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanEndLine l) ((GHC.srcSpanEndCol l) 1))
clientModsAndFiles
:: GHC.GhcMonad m => GHC.ModuleName -> m [GHC.ModSummary]
clientModsAndFiles m = do
ms <- GHC.getModuleGraph
modsum <- GHC.getModSummary m
let mg = getModulesAsGraph False ms Nothing
rg = GHC.transposeG mg
modNode = fromJust $ find (\(msum,_,_) -> mycomp msum modsum) (GHC.verticesG rg)
clientMods = filter (\msum -> not (mycomp msum modsum))
$ map summaryNodeSummary $ GHC.reachableG rg modNode
return clientMods
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 = fromJust $ 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
getCurrentModuleGraph :: RefactGhc GHC.ModuleGraph
getCurrentModuleGraph = GHC.getModuleGraph
sortCurrentModuleGraph :: RefactGhc [GHC.SCC GHC.ModSummary]
sortCurrentModuleGraph = do
g <- getCurrentModuleGraph
let scc = GHC.topSortModuleGraph False g Nothing
return scc