{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId module Language.Haskell.Refact.Utils.Utils ( -- * Managing the GHC / project environment getTargetGhc , parseSourceFileGhc -- * The bits that do the work , runRefacSession , applyRefac , applyRefac' , refactDone -- , Update(..) , fileNameFromModSummary , getModuleName , clientModsAndFiles , serverModsAndFiles -- , lookupAnns , runMultRefacSession , modifiedFiles , writeRefactoredFiles , stripCallStack ) where -- import Control.Exception import Control.Monad.Identity import Control.Monad.State import Data.List import Data.Maybe import Data.IORef -- import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Preprocess import Language.Haskell.GHC.ExactPrint.Print import Language.Haskell.GHC.ExactPrint.Utils import qualified GhcMod as GM import qualified GhcMod.Target as GM import qualified GhcMod.Types as GM import Language.Haskell.Refact.Utils.GhcModuleGraph import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions import Language.Haskell.Refact.Utils.Types import System.Directory import System.FilePath.Posix import qualified Digraph as GHC import qualified DynFlags as GHC import qualified GHC as GHC -- import qualified SrcLoc as GHC import qualified Hooks as GHC import qualified HscMain as GHC import qualified HscTypes as GHC import qualified TcRnMonad as GHC -- import qualified GHC.SYB.Utils as SYB -- import qualified Data.Generics as SYB import qualified Data.Map as Map import qualified Data.Set as Set -- import Debug.Trace -- --------------------------------------------------------------------- -- | Extract the module name from the parsed source, if there is one 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) -- --------------------------------------------------------------------- getTargetGhc :: TargetModule -> RefactGhc () getTargetGhc (GM.ModulePath _mn fp) = parseSourceFileGhc fp -- --------------------------------------------------------------------- {- -- | Parse a single source file into a GHC session parseSourceFileGhc' :: FilePath -> RefactGhc () parseSourceFileGhc' targetFile = do logm $ "parseSourceFileGhc:targetFile=" ++ show targetFile setTargetSession targetFile graph <- GHC.getModuleGraph cgraph <- canonicalizeGraph graph cfileName <- liftIO $ canonicalizePath targetFile let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph case mm of [(_,modSum)] -> loadFromModSummary Nothing modSum _ -> error $ "HaRe:unexpected error parsing " ++ targetFile -} -- --------------------------------------------------------------------- -- | Parse a single source file into a GHC session parseSourceFileGhc :: FilePath -> RefactGhc () parseSourceFileGhc targetFile = do logm $ "parseSourceFileGhc:targetFile=" ++ show targetFile cfileName <- liftIO $ canonicalizePath targetFile logm $ "parseSourceFileGhc:cfileName=" ++ show cfileName ref <- liftIO $ newIORef (cfileName,Nothing) let setTarget fileName = RefactGhc $ GM.runGmlT' [Left fileName] (installHooks ref) (return ()) -- setTarget targetFile setTarget cfileName logm $ "parseSourceFileGhc:after setTarget" (_,mtm) <- liftIO $ readIORef ref logm $ "parseSourceFileGhc:isJust mtm:" ++ show (isJust mtm) graph <- GHC.getModuleGraph cgraph <- canonicalizeGraph graph let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph case mm of [(_,modSum)] -> loadFromModSummary mtm modSum -- [(_,modSum)] -> loadFromModSummary Nothing modSum _ -> error $ "HaRe:unexpected error parsing " ++ targetFile -- --------------------------------------------------------------------- installHooks :: (Monad m) => IORef (FilePath,Maybe TypecheckedModule) -> GHC.DynFlags -> m GHC.DynFlags installHooks ref dflags = return $ dflags { GHC.hooks = (GHC.hooks dflags) { #if __GLASGOW_HASKELL__ <= 710 GHC.hscFrontendHook = Just $ hscFrontend ref #else GHC.hscFrontendHook = Just $ runHscFrontend ref #endif } } #if __GLASGOW_HASKELL__ > 710 runHscFrontend :: IORef (FilePath,Maybe TypecheckedModule) -> GHC.ModSummary -> GHC.Hsc GHC.FrontendResult runHscFrontend ref mod_summary = GHC.FrontendTypecheck `fmap` hscFrontend ref mod_summary #endif -- --------------------------------------------------------------------- -- | Given a 'ModSummary', parses and typechecks it, returning the -- 'TcGblEnv' resulting from type-checking. -- Based on GHC.hscFileFrontend -- -- This gets called on every module compiled when loading the wanted target. -- When it is the wanted target, keep the ParsedSource and TypecheckedSource, -- with API Annotations enabled. hscFrontend :: IORef (FilePath,Maybe TypecheckedModule) -> GHC.ModSummary -> GHC.Hsc GHC.TcGblEnv hscFrontend ref mod_summary = do -- liftIO $ putStrLn $ "hscFrontend:entered:" ++ fileNameFromModSummary mod_summary (mfn,_) <- canonicalizeModSummary mod_summary -- liftIO $ putStrLn $ "hscFrontend:mfn:" ++ show mfn (fn,_) <- liftIO $ readIORef ref let keepInfo = case mfn of Just fileName -> fn == fileName Nothing -> False if keepInfo then do -- liftIO $ putStrLn $ "hscFrontend:in keepInfo" let modSumWithRaw = tweakModSummaryDynFlags mod_summary hsc_env <- GHC.getHscEnv let hsc_env_tmp = hsc_env { GHC.hsc_dflags = GHC.ms_hspp_opts modSumWithRaw } hpm <- liftIO $ GHC.hscParse hsc_env_tmp modSumWithRaw let p = GHC.ParsedModule mod_summary (GHC.hpm_module hpm) (GHC.hpm_src_files hpm) (GHC.hpm_annotations hpm) hsc_env' <- GHC.getHscEnv (tc_gbl_env,rn_info) <- liftIO $ GHC.hscTypecheckRename hsc_env' mod_summary hpm details <- liftIO $ GHC.makeSimpleDetails hsc_env' tc_gbl_env let tc = TypecheckedModule { tmParsedModule = p, tmRenamedSource = gfromJust "hscFrontend" rn_info, tmTypecheckedSource = GHC.tcg_binds tc_gbl_env, tmMinfExports = GHC.md_exports details, tmMinfRdrEnv = Just (GHC.tcg_rdr_env tc_gbl_env) } liftIO $ modifyIORef' ref (const (fn,Just tc)) return tc_gbl_env else do hpm <- GHC.hscParse' mod_summary hsc_env <- GHC.getHscEnv tc_gbl_env <- GHC.tcRnModule' hsc_env mod_summary False hpm return tc_gbl_env -- --------------------------------------------------------------------- {- setTargetSession :: FilePath -> RefactGhc () -- setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] setDynFlags (return ()) setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] return (return ()) -- setDynFlags :: GHC.DynFlags -> GHC.Ghc GHC.DynFlags -- setDynFlags df = return (GHC.gopt_set df GHC.Opt_KeepRawTokenStream) -} -- --------------------------------------------------------------------- -- |For GHC 7.10.2, setting 'GHC.Opt_KeepRawTokenStream' prevents the pragmas at -- the top of a source file from being read if there is a comment mixed in them -- anywhere. To work around this, we need to inject that setting into the cached -- dynflags in the 'GHC.ModSummary' before parsing it for refactoring, otherwise -- all comments will be discarded. -- See https://ghc.haskell.org/trac/ghc/ticket/10942 tweakModSummaryDynFlags :: GHC.ModSummary -> GHC.ModSummary tweakModSummaryDynFlags ms = let df = GHC.ms_hspp_opts ms in ms { GHC.ms_hspp_opts = GHC.gopt_set df GHC.Opt_KeepRawTokenStream } -- --------------------------------------------------------------------- -- | In the existing GHC session, put the requested TypeCheckedModule -- into the RefactGhc monad loadFromModSummary :: Maybe TypecheckedModule -> GHC.ModSummary -> RefactGhc () loadFromModSummary mtm modSum = do logm $ "loadFromModSummary:modSum=" ++ show modSum t <- case mtm of Nothing -> do let modSumWithRaw = tweakModSummaryDynFlags modSum p <- GHC.parseModule modSumWithRaw t' <- GHC.typecheckModule p let tm = TypecheckedModule { tmParsedModule = p , tmRenamedSource = gfromJust "loadFromModSummary" $ GHC.tm_renamed_source t' , tmTypecheckedSource = GHC.tm_typechecked_source t' , tmMinfExports = error $ "loadFromModSummary:not visible in ModuleInfo 1" , tmMinfRdrEnv = error $ "loadFromModSummary:not visible in ModuleInfo 2" } return tm Just tm -> return tm -- dflags <- GHC.getDynFlags -- cppComments <- if (GHC.xopt GHC.Opt_Cpp dflags) cppComments <- if True then do -- ++AZ++:TODO: enable the CPP option check some time -- TODO: Set the approriate DynFlag to retain the source, so this can be done more cheaply logm $ "loadFromModSummary:CPP flag set" case GHC.ml_hs_file $ GHC.ms_location modSum of Just fileName -> getCppTokensAsComments defaultCppOptions fileName Nothing -> return [] else do logm $ "loadFromModSummary:no CPP" return [] -- required for inscope queries. Is there a better way to do those? setGhcContext modSum (mfp,_modSum) <- canonicalizeModSummary modSum newTargetModule <- case mfp of Nothing -> error $ "HaRe:no file path for module:" ++ showGhc modSum Just fp -> return $ GM.ModulePath (GHC.moduleName $ GHC.ms_mod modSum) fp oldTargetModule <- gets rsCurrentTarget let putModule = do putParsedModule cppComments t settings <- get put $ settings { rsCurrentTarget = Just newTargetModule } mtm' <- gets rsModule case mtm' of Just tm -> if ((rsStreamModified tm == RefacUnmodifed) && oldTargetModule == Just newTargetModule) then do logm $ "loadFromModSummary:not calling putParsedModule for targetModule=" ++ show newTargetModule return () else if rsStreamModified tm == RefacUnmodifed then putModule else error $ "loadFromModSummary: trying to load a module without finishing with active one." Nothing -> putModule return () -- --------------------------------------------------------------------- -- | Manage a whole refactor session. Initialise the monad, load the -- whole project if required, and then apply the individual -- refactorings, and write out the resulting files. -- -- It is intended that this forms the umbrella function, in which -- applyRefac is called -- runRefacSession :: RefactSettings -> GM.Options -- ^ ghc-mod options -> RefactGhc [ApplyRefacResult] -- ^ The computation doing the -- refactoring. Normally created -- via 'applyRefac' -> IO [FilePath] runRefacSession settings opt comp = do let initialState = RefSt { rsSettings = settings , rsUniqState = 1 , rsSrcSpanCol = 1 , rsFlags = RefFlags False , rsStorage = StorageNone , rsCurrentTarget = Nothing , rsModule = Nothing } (refactoredMods,_s) <- runRefactGhc comp initialState opt let verbosity = rsetVerboseLevel (rsSettings initialState) writeRefactoredFiles verbosity refactoredMods return $ modifiedFiles refactoredMods -- --------------------------------------------------------------------- -- | Like runRefacSession but instead takes an ordered list of RefactGhc -- computations and runs all of them threading the state through all of the -- computations runMultRefacSession :: RefactSettings -> GM.Options -> [RefactGhc [ApplyRefacResult]] -> IO [FilePath] runMultRefacSession settings opt comps = do let initialState = RefSt { rsSettings = settings , rsUniqState = 1 , rsSrcSpanCol = 1 , rsFlags = RefFlags False , rsStorage = StorageNone , rsCurrentTarget = Nothing , rsModule = Nothing } results <- threadState opt initialState comps let (_, finState) = last results verbosity = rsetVerboseLevel (rsSettings finState) refResults = map fst results merged = mergeRefResults refResults writeRefactoredFiles verbosity merged return $ modifiedFiles merged mergeRefResults :: [[ApplyRefacResult]] -> [ApplyRefacResult] mergeRefResults lst = Map.elems $ mergeHelp lst Map.empty where mergeHelp [] mp = mp mergeHelp (x:xs) mp = mergeHelp xs (foldl insertRefRes mp x) insertRefRes mp res@((fp,RefacModified), _) = Map.insert fp res mp insertRefRes mp _ = mp -- | Take an ordered list of refactorings and apply them in order, threading the -- state through all of them threadState :: GM.Options -> RefactState -> [RefactGhc [ApplyRefacResult]] -> IO [([ApplyRefacResult], RefactState)] threadState _ _ [] = return [] threadState opt currState (rGhc : rst) = do res@(_rGhcRes, newState) <- runRefactGhc rGhc currState opt let (Just modu) = rsModule newState newMod = modu {rsStreamModified = RefacUnmodifed} nextState = newState {rsModule = Just newMod } rest <- threadState opt nextState rst return (res : rest) -- --------------------------------------------------------------------- cdAndDo :: FilePath -> IO a -> IO a cdAndDo path fn = do old <- getCurrentDirectory r <- GHC.gbracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old) $ const fn return r -- --------------------------------------------------------------------- {- canonicalizeTargets :: Targets-> IO Targets canonicalizeTargets tgts = do cur <- getCurrentDirectory let canonicalizeTarget (Left path) = Left <$> canonicalizePath (cur path) canonicalizeTarget (Right modname) = return $ Right modname mapM canonicalizeTarget tgts -} -- --------------------------------------------------------------------- -- TODO: the module should be stored in the state, and returned if it -- has been modified in a prior refactoring, instead of being parsed -- afresh each time. -- | Apply a refactoring (or part of a refactoring) to a single module applyRefac :: RefactGhc a -> RefacSource -> RefactGhc (ApplyRefacResult, a) applyRefac = applyRefac' True -- TODO: applyRefac' is never called except from -- here. Do we always need to clear the state on -- completion? applyRefac' :: Bool -- ^ Boolean that determines if the state should be cleared -> RefactGhc a -- ^ The refactoring -> RefacSource -- ^ where to get the module and toks -> RefactGhc (ApplyRefacResult,a) applyRefac' clearSt refac source = do -- TODO: currently a temporary, poor man's surrounding state -- management: store state now, set it to fresh, run refac, then -- restore the state. Fix this to store the modules in some kind of cache. fileName <- case source of RSFile fname -> do parseSourceFileGhc fname return fname RSTarget tgt -> do getTargetGhc tgt return (GM.mpPath tgt) RSMod ms -> do parseSourceFileGhc $ fileNameFromModSummary ms return $ fileNameFromModSummary ms RSAlreadyLoaded -> do mfn <- getRefactFileName case mfn of Just fname -> return fname Nothing -> error "applyRefac RSAlreadyLoaded: nothing loaded" res <- refac -- Run the refactoring, updating the state as required mod' <- getRefactParsed anns <- fetchAnnsFinal m <- getRefactStreamModified -- Clear the refactoring state if clearSt then clearParsedModule else return () absFileName <- liftIO $ canonicalizePath fileName return (((absFileName,m),(anns, mod')),res) -- --------------------------------------------------------------------- -- |Returns True if any of the results has its modified flag set refactDone :: [ApplyRefacResult] -> Bool refactDone rs = any (\((_,d),_) -> d == RefacModified) rs -- --------------------------------------------------------------------- modifiedFiles :: [ApplyRefacResult] -> [String] modifiedFiles refactResult = map (\((s,_),_) -> s) $ filter (\((_,b),_) -> b == RefacModified) refactResult -- --------------------------------------------------------------------- {- getEnabledTargets :: RefactSettings -> ([FilePath],[FilePath],[FilePath],[FilePath]) -> ([FilePath],[FilePath]) getEnabledTargets settings (libt,exet,testt,bencht) = (targetsLib,targetsExe) where (libEnabled, exeEnabled, testEnabled, benchEnabled) = rsetEnabledTargets settings targetsLib = on libEnabled libt targetsExe = on exeEnabled exet ++ on testEnabled testt ++ on benchEnabled bencht on flag xs = if flag then xs else [] -} -- --------------------------------------------------------------------- {- -- ++AZ++ I think the intended function of this class has been superseded by -- ghc-exactprint HasDecls. class (SYB.Data t, SYB.Data t1) => Update t t1 where -- | Update the occurrence of one syntax phrase in a given scope by -- another syntax phrase of the same type update:: t -- ^ The syntax phrase to be updated. -> t -- ^ The new syntax phrase. -> t1 -- ^ The contex where the old syntax phrase occurs. -> RefactGhc t1 -- ^ The result. instance (SYB.Data t, GHC.OutputableBndr n, GHC.DataId n) => Update (GHC.LHsExpr n) t where update oldExp newExp t = SYB.everywhereMStaged SYB.Parser (SYB.mkM inExp) t where inExp (e::GHC.LHsExpr n) | sameOccurrence e oldExp = return newExp | otherwise = return e instance (SYB.Data t, GHC.OutputableBndr n, GHC.DataId n) => Update (GHC.LPat n) t where update oldPat newPat t = SYB.everywhereMStaged SYB.Parser (SYB.mkM inPat) t where inPat (p::GHC.LPat n) | sameOccurrence p oldPat = return newPat | otherwise = return p instance (SYB.Data t, GHC.OutputableBndr n, GHC.DataId n) => Update (GHC.LHsType n) t where update oldTy newTy t = SYB.everywhereMStaged SYB.Parser (SYB.mkM inTyp) t where inTyp (t'::GHC.LHsType n) | sameOccurrence t' oldTy = return newTy | otherwise = return t' instance (SYB.Data t, GHC.OutputableBndr n1, GHC.OutputableBndr n2, GHC.DataId n1, GHC.DataId n2) => Update (GHC.LHsBindLR n1 n2) t where update oldBind newBind t = SYB.everywhereMStaged SYB.Parser (SYB.mkM inBind) t where inBind (t'::GHC.LHsBindLR n1 n2) | sameOccurrence t' oldBind = return newBind | otherwise = return t' -} -- --------------------------------------------------------------------- -- | Write refactored program source to files. writeRefactoredFiles :: VerboseLevel -> [ApplyRefacResult] -> IO () writeRefactoredFiles verbosity files = do let filesModified = filter (\((_f,m),_) -> m == RefacModified) files -- TODO: restore the history function -- ++AZ++ PFE0.addToHistory isSubRefactor (map (fst.fst) filesModified) sequence_ (map modifyFile filesModified) -- mapM_ writeTestDataForFile files -- This should be removed for the release version. where modifyFile ((fileName,_),(ann,parsed)) = do let -- rigidOptions :: PrintOptions Identity String -- rigidOptions = printOptions (\_ b -> return b) return return RigidLayout -- exactPrintRigid ast as = runIdentity (exactPrintWithOptions rigidOptions ast as) exactPrintNormal ast as = runIdentity (exactPrintWithOptions stringOptions ast as) -- let source = exactPrint parsed ann -- let source = exactPrintRigid parsed ann let source = exactPrintNormal parsed ann let (baseFileName,ext) = splitExtension fileName seq (length source) (writeFile (baseFileName ++ ".refactored" ++ ext) source) when (verbosity == Debug) $ do writeFile (fileName ++ ".parsed_out") (showGhc parsed) writeFile (fileName ++ ".AST_out") ((showGhc parsed) ++ "\n\n----------------------\n\n" ++ -- (SYB.showData SYB.Parser 0 parsed) ++ (showAnnData ann 0 parsed) ++ "\n\n----------------------\n\n" ++ (showGhc ann) ++ "\n\n----------------------\n\n" -- (showAnnData (organiseAnns ann) 0 parsed) ) -- --------------------------------------------------------------------- -- | Return the client modules and file names. The client modules of -- module, say m, are those modules which directly or indirectly -- import module m. -- clientModsAndFiles :: GHC.ModuleName -> RefactGhc [TargetModule] clientModsAndFiles :: GM.ModulePath -> RefactGhc [TargetModule] -- TODO: Use ghc-mod cache if there is a cabal file, else normal GHC modulegraph clientModsAndFiles m = do mgs <- cabalModuleGraphs -- logm $ "clientModsAndFiles:mgs=" ++ show mgs -- mgs is [Map ModulePath (Set ModulePath)] -- where eack key imports the corresponding set. -- There are no cycles -- We need the reverse of this, the transitive set of values where if the -- ModulePath is in the set, then the key is of interest. -- So -- Flatten the module graph, reverse the dependencies, then rebuild it let flattenSwap (GM.GmModuleGraph mg) = concatMap (\(k,vs) -> map (\v -> (v,Set.singleton k)) (Set.elems vs)) $ Map.toList mg transposed = mgs' where kvs = concatMap flattenSwap mgs mgs' = foldl' (\acc (k,v) -> Map.insertWith Set.union k v acc) Map.empty kvs -- transposed is a map from each module to those that import it. We need the -- transitive closure of all the importers of the given module. check acc k = case Map.lookup k transposed of Nothing -> (acc,[]) Just s -> (Set.union acc s, Set.toList $ s Set.\\ acc) go (acc,[]) = acc go (acc,c:s) = go (acc',s') where (acc',q) = check acc c s' = nub (q ++ s) r = go (Set.empty, [m]) return $ Set.toList r -- TODO : find decent name and place for this. mycomp :: GHC.ModSummary -> GHC.ModSummary -> Bool mycomp ms1 ms2 = (GHC.ms_mod ms1) == (GHC.ms_mod ms2) -- --------------------------------------------------------------------- -- | Return the server module and file names. The server modules of -- module, say m, are those modules which are directly or indirectly -- imported by module m. This can only be called in a live GHC session -- TODO: make sure this works with multiple targets. Is that needed? serverModsAndFiles :: GHC.GhcMonad m => GHC.ModuleName -> m [GHC.ModSummary] -- TODO: Use ghc-mod cache if there is a cabal file, else normal GHC modulegraph 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 -- --------------------------------------------------------------------- {- -- | Finds all anotations that are contained within the given source span lookupAnns :: Anns -> GHC.SrcSpan -> Anns lookupAnns anns (GHC.RealSrcSpan span) = Map.filterWithKey isInSpan anns where isInSpan k@(AnnKey (GHC.RealSrcSpan annSpan) conN) v = GHC.containsSpan span annSpan -} -- --------------------------------------------------------------------- -- | In GHC 8 an error has an attached callstack. This is not always what we -- want, so this function strips it stripCallStack :: String -> String stripCallStack str = str' where s1 = init $ unlines $ takeWhile (\s -> s /= "CallStack (from HasCallStack):") $ lines str str' = if last str == '\n' then s1 ++ "\n" else s1