module Language.Haskell.Tools.Refactor.Prepare where
import CmdLineParser
import DynFlags
import FastString
import GHC hiding (loadModule)
import qualified GHC (loadModule)
import GHC.Paths ( libdir )
import Packages
import SrcLoc
import StringBuffer
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans
import Data.IntSet (member)
import Data.List ((\\), intersperse, isSuffixOf)
import Data.List.Split
import Data.Maybe
import Language.Haskell.TH.LanguageExtensions
import System.Directory
import System.FilePath
import Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.AST.FromGHC
import Language.Haskell.Tools.PrettyPrint
import Language.Haskell.Tools.Refactor.RefactorBase
import Language.Haskell.Tools.Transform
tryRefactor :: (RealSrcSpan -> Refactoring IdDom) -> String -> String -> IO ()
tryRefactor refact moduleName span
= runGhc (Just libdir) $ do
initGhcFlags
useDirs ["."]
mod <- loadModule "." moduleName >>= parseTyped
res <- runRefactor (SourceFileKey NormalHs moduleName, mod) []
$ refact $ correctRefactorSpan mod $ readSrcSpan span
case res of Right r -> liftIO $ mapM_ (putStrLn . prettyPrint . snd . fromContentChanged) r
Left err -> liftIO $ putStrLn err
correctRefactorSpan :: UnnamedModule dom -> RealSrcSpan -> RealSrcSpan
correctRefactorSpan mod sp = mkRealSrcSpan (updateSrcFile fileName $ realSrcSpanStart sp)
(updateSrcFile fileName $ realSrcSpanEnd sp)
where fileName = case srcSpanStart $ getRange mod of RealSrcLoc loc -> srcLocFile loc
_ -> error "correctRefactorSpan: no real span"
updateSrcFile fn loc = mkRealSrcLoc fn (srcLocLine loc) (srcLocCol loc)
useFlags :: [String] -> Ghc [String]
useFlags args = do
let lArgs = map (L noSrcSpan) args
dynflags <- getSessionDynFlags
let ((leftovers, _, _), newDynFlags) = (runCmdLine $ processArgs flagsAll lArgs) dynflags
void $ setSessionDynFlags newDynFlags
when (any ("-package-db" `isSuffixOf`) args) reloadPkgDb
return $ map unLoc leftovers
reloadPkgDb :: Ghc ()
reloadPkgDb = void $ setSessionDynFlags . fst =<< liftIO . initPackages . (\df -> df { pkgDatabase = Nothing })
=<< getSessionDynFlags
initGhcFlags :: Ghc ()
initGhcFlags = initGhcFlags' False
initGhcFlagsForTest :: Ghc ()
initGhcFlagsForTest = initGhcFlags' True
initGhcFlags' :: Bool -> Ghc ()
initGhcFlags' needsCodeGen = do
dflags <- getSessionDynFlags
void $ setSessionDynFlags
$ flip gopt_set Opt_KeepRawTokenStream
$ flip gopt_set Opt_NoHsMain
$ dflags { importPaths = []
, hscTarget = if needsCodeGen then HscInterpreted else HscNothing
, ghcLink = if needsCodeGen then LinkInMemory else NoLink
, ghcMode = CompManager
, packageFlags = ExposePackage "template-haskell" (PackageArg "template-haskell") (ModRenaming True []) : packageFlags dflags
}
useDirs :: [FilePath] -> Ghc ()
useDirs workingDirs = do
dynflags <- getSessionDynFlags
void $ setSessionDynFlags dynflags { importPaths = importPaths dynflags ++ workingDirs }
deregisterDirs :: [FilePath] -> Ghc ()
deregisterDirs workingDirs = do
dynflags <- getSessionDynFlags
void $ setSessionDynFlags dynflags { importPaths = importPaths dynflags \\ workingDirs }
toFileName :: FilePath -> String -> FilePath
toFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs"
toBootFileName :: FilePath -> String -> FilePath
toBootFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs-boot"
getSourceDir :: ModSummary -> IO FilePath
getSourceDir ms
= do filePath <- canonicalizePath $ getModSumOrig ms
let modNameParts = splitOn "." $ GHC.moduleNameString (moduleName (ms_mod ms))
filePathParts = splitPath filePath
let srcDirParts = reverse $ drop (length modNameParts) $ reverse filePathParts
return $ joinPath srcDirParts
getModSumOrig :: ModSummary -> FilePath
getModSumOrig = normalise . fromMaybe (error "getModSumOrig: The given module doesn't have haskell source file.") . ml_hs_file . ms_location
getModSumName :: ModSummary -> String
getModSumName = GHC.moduleNameString . moduleName . ms_mod
loadModule :: String -> String -> Ghc ModSummary
loadModule workingDir moduleName
= do initGhcFlagsForTest
useDirs [workingDir]
target <- guessTarget moduleName Nothing
setTargets [target]
void $ load (LoadUpTo $ mkModuleName moduleName)
getModSummary $ mkModuleName moduleName
type TypedModule = Ann AST.UModule IdDom SrcTemplateStage
parseTyped :: ModSummary -> Ghc TypedModule
parseTyped modSum = withAlteredDynFlags (return . normalizeFlags) $ do
let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum
hasCppExtension = Cpp `xopt` ms_hspp_opts modSum
ms = if hasStaticFlags then forceAsmGen (modSumNormalizeFlags modSum) else (modSumNormalizeFlags modSum)
p <- parseModule ms
tc <- typecheckModule p
void $ GHC.loadModule tc
let annots = pm_annotations p
srcBuffer <- if hasCppExtension
then liftIO $ hGetStringBuffer (getModSumOrig ms)
else return (fromJust $ ms_hspp_buf $ pm_mod_summary p)
(if hasCppExtension then prepareASTCpp else prepareAST) srcBuffer . placeComments (fst annots) (getNormalComments $ snd annots)
<$> (addTypeInfos (typecheckedSource tc)
=<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms (pm_parsed_source p)
runTrf (fst annots) (getPragmaComments $ snd annots)
$ trfModuleRename ms parseTrf
(fromJust $ tm_renamed_source tc)
(pm_parsed_source p)))
withAlteredDynFlags :: GhcMonad m => (DynFlags -> m DynFlags) -> m a -> m a
withAlteredDynFlags modDFs action = do
dfs <- getSessionDynFlags
void $ setSessionDynFlags =<< modDFs dfs
res <- action
void $ setSessionDynFlags dfs
return res
forceCodeGen :: ModSummary -> ModSummary
forceCodeGen ms = ms { ms_hspp_opts = modOpts' }
where modOpts = (ms_hspp_opts ms) { hscTarget = HscInterpreted }
modOpts' = modOpts { ghcLink = LinkInMemory }
forceAsmGen :: ModSummary -> ModSummary
forceAsmGen ms = ms { ms_hspp_opts = modOpts' }
where modOpts = (ms_hspp_opts ms) { hscTarget = HscAsm }
modOpts' = modOpts { ghcLink = LinkInMemory }
modSumNormalizeFlags :: ModSummary -> ModSummary
modSumNormalizeFlags ms = ms { ms_hspp_opts = normalizeFlags (ms_hspp_opts ms) }
normalizeFlags :: DynFlags -> DynFlags
normalizeFlags = updOptLevel 0
readSrcSpan :: String -> RealSrcSpan
readSrcSpan s = case splitOn "-" s of
[one] -> mkRealSrcSpan (readSrcLoc one) (readSrcLoc one)
[from,to] -> mkRealSrcSpan (readSrcLoc from) (readSrcLoc to)
readSrcLoc :: String -> RealSrcLoc
readSrcLoc s = case splitOn ":" s of
[line,col] -> mkRealSrcLoc (mkFastString "file-name-should-be-fixed") (read line) (read col)
_ -> error "readSrcLoc: panic: splitOn gives empty list"