{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Tools.Refactor.Prepare where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO(..))
import Data.List ((\\), isSuffixOf)
import Data.List.Split (splitOn)
import Data.Maybe (Maybe(..), fromMaybe, fromJust)
import Language.Haskell.TH.LanguageExtensions (Extension(..))
import System.Directory (canonicalizePath)
import System.FilePath
import CmdLineParser (CmdLineP(..), processArgs, Warn(..), Err(..))
import DynFlags
import FastString (mkFastString)
import GHC hiding (loadModule, ModuleName)
import qualified GHC (loadModule)
import GHC.Paths ( libdir )
import GhcMonad
import HscTypes
import Outputable (Outputable(..), showSDocUnsafe, cat, (<>))
import Packages (initPackages)
import SrcLoc
import StringBuffer (hGetStringBuffer)
import Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.BackendGHC
import Language.Haskell.Tools.PrettyPrint (prettyPrint)
import Language.Haskell.Tools.PrettyPrint.Prepare
import Language.Haskell.Tools.Refactor.Monad (Refactoring(..))
import Language.Haskell.Tools.Refactor.Representation
import Language.Haskell.Tools.Refactor.Utils.Monadic (runRefactor)
type ModuleName = String
tryRefactor :: (RealSrcSpan -> Refactoring) -> String -> ModuleName -> IO ()
tryRefactor refact moduleName span
= runGhc (Just libdir) $ do
initGhcFlags
useDirs ["."]
mod <- loadModule "." moduleName >>= parseTyped
res <- runRefactor (SourceFileKey (moduleSourceFile moduleName) 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 -> 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], DynFlags -> DynFlags)
useFlags args = do
let lArgs = map (L noSrcSpan) args
dynflags <- getSessionDynFlags
let change = runCmdLine $ processArgs flagsAll lArgs
let ((leftovers, errs, warnings), newDynFlags) = change dynflags
unless (null warnings)
$ liftIO $ putStrLn $ showSDocUnsafe $ cat $ map pprWarning warnings
unless (null errs)
$ liftIO $ putStrLn $ showSDocUnsafe $ cat $ map pprErr errs
void $ setSessionDynFlags newDynFlags
when (any ("-package-db" `isSuffixOf`) args) reloadPkgDb
return (map unLoc leftovers, snd . change)
pprWarning (Warn reason msg) = ppr reason Outputable.<> ppr msg
pprErr (Err msg) = ppr msg
reloadPkgDb :: Ghc ()
reloadPkgDb = void $ setSessionDynFlags . fst =<< liftIO . initPackages . (\df -> df { pkgDatabase = Nothing })
=<< getSessionDynFlags
initGhcFlags :: Ghc ()
initGhcFlags = initGhcFlags' False True
initGhcFlagsForTest :: Ghc ()
initGhcFlagsForTest = do initGhcFlags' True False
dfs <- getSessionDynFlags
void $ setSessionDynFlags $ dfs { hscTarget = HscAsm }
initGhcFlags' :: Bool -> Bool -> Ghc ()
initGhcFlags' needsCodeGen errorsSuppressed = do
dflags <- getSessionDynFlags
void $ setSessionDynFlags
$ flip gopt_set Opt_KeepRawTokenStream
$ flip gopt_set Opt_NoHsMain
$ (if errorsSuppressed then flip gopt_set Opt_DeferTypeErrors
. flip gopt_set Opt_DeferTypedHoles
. flip gopt_set Opt_DeferOutOfScopeVariables
else id)
$ 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 -> ModuleName -> FilePath
toFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs"
toBootFileName :: FilePath -> ModuleName -> 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
keyFromMS :: ModSummary -> SourceFileKey
keyFromMS ms = SourceFileKey (normalise $ getModSumOrig ms) (getModSumName ms)
getModSumName :: ModSummary -> String
getModSumName = GHC.moduleNameString . moduleName . ms_mod
loadModuleAST :: FilePath -> ModuleName -> Ghc TypedModule
loadModuleAST workingDir moduleName = do
useFlags ["-w"]
modSummary <- loadModule workingDir moduleName
parseTyped modSummary
loadModule :: FilePath -> ModuleName -> 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 hasCppExtension = Cpp `xopt` ms_hspp_opts modSum
ms = modSumNormalizeFlags modSum
when (ApplicativeDo `xopt` ms_hspp_opts modSum) $ liftIO $ throwIO $ UnsupportedExtension "ApplicativeDo"
when (OverloadedLabels `xopt` ms_hspp_opts modSum) $ liftIO $ throwIO $ UnsupportedExtension "OverloadedLabels"
when (ImplicitParams `xopt` ms_hspp_opts modSum) $ liftIO $ throwIO $ UnsupportedExtension "ImplicitParams"
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)
withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms })
$ (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)))
data UnsupportedExtension = UnsupportedExtension String
deriving Show
instance Exception UnsupportedExtension
trfProblem :: String -> a
trfProblem = throw . UnsupportedExtension
withAlteredDynFlags :: GhcMonad m => (DynFlags -> m DynFlags) -> m a -> m a
withAlteredDynFlags modDFs action = do
dfs <- getSessionDynFlags
newFlags <- modDFs dfs
void $ modifySession $ \s -> s { hsc_dflags = newFlags }
res <- action
void $ modifySession $ \s -> s { hsc_dflags = dfs }
return res
forceCodeGen :: ModSummary -> ModSummary
forceCodeGen ms = ms { ms_hspp_opts = codeGenDfs (ms_hspp_opts ms) }
codeGenDfs :: DynFlags -> DynFlags
codeGenDfs dfs = dfs { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
forceAsmGen :: ModSummary -> ModSummary
forceAsmGen ms = ms { ms_hspp_opts = modOpts' }
where modOpts = (ms_hspp_opts ms) { hscTarget = defaultObjectTarget (targetPlatform (ms_hspp_opts ms)) }
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"