module Language.Haskell.Tools.Refactor.Prepare where
import GHC hiding (loadModule)
import qualified GHC (loadModule)
import Panic (handleGhcException)
import Outputable
import BasicTypes
import Bag
import Var
import SrcLoc
import Module as GHC
import FastString
import HscTypes
import GHC.Paths ( libdir )
import CmdLineParser
import DynFlags
import StringBuffer
import Control.Monad
import Control.Monad.IO.Class
import System.FilePath
import Data.Maybe
import Data.List (isInfixOf, (\\))
import Data.List.Split
import System.Info (os)
import System.Directory
import Data.IntSet (member)
import Language.Haskell.TH.LanguageExtensions
import Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.AST.FromGHC
import Language.Haskell.Tools.PrettyPrint
import Language.Haskell.Tools.Transform
import Language.Haskell.Tools.Refactor.RefactorBase
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
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, errors, warnings), newDynFlags) = (runCmdLine $ processArgs flagsAll lArgs) dynflags
setSessionDynFlags newDynFlags
return $ map unLoc leftovers
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
loadModule :: String -> String -> Ghc ModSummary
loadModule workingDir moduleName
= do initGhcFlagsForTest
useDirs [workingDir]
target <- guessTarget moduleName Nothing
setTargets [target]
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 compExts = extensionFlags $ ms_hspp_opts modSum
hasStaticFlags = fromEnum StaticPointers `member` compExts
ms = if hasStaticFlags then forceAsmGen (modSumNormalizeFlags modSum) else (modSumNormalizeFlags modSum)
p <- parseModule ms
tc <- typecheckModule p
GHC.loadModule tc
let annots = pm_annotations p
srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p
prepareAST srcBuffer . placeComments (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
setSessionDynFlags =<< modDFs dfs
res <- action
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)