diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.0.4 +Version: 0.7.0.5 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha @@ -78,6 +78,7 @@ , Language.Haskell.Refact.Renaming , Language.Haskell.Refact.SwapArgs , Language.Haskell.Refact.Utils + , Language.Haskell.Refact.Utils.GhcBugWorkArounds , Language.Haskell.Refact.Utils.GhcModuleGraph , Language.Haskell.Refact.Utils.GhcUtils , Language.Haskell.Refact.Utils.GhcVersionSpecific diff --git a/src/Language/Haskell/Refact/Utils.hs b/src/Language/Haskell/Refact/Utils.hs --- a/src/Language/Haskell/Refact/Utils.hs +++ b/src/Language/Haskell/Refact/Utils.hs @@ -44,6 +44,7 @@ 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 @@ -67,34 +68,6 @@ -- --------------------------------------------------------------------- --- Term defined in ../StrategyLib-4.0-beta/models/deriving/TermRep.hs - --- type PosToken = (Token, (Pos, String)) --- -- Defined at ../tools/base/parse2/Lexer/HsLayoutPre.hs:14:6 --- data Pos --- = Pos {HsLexerPass1.char :: !Int, line :: !Int, column :: !Int} --- -- Defined at ../tools/base/parse2/Lexer/HsLexerPos.hs:3:6 --- data Token --- -- Defined at ../tools/base/parse2/Lexer/HsTokens.hs:5:6 - --- GHC version --- getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] - --- getStartEndLoc :: --- forall t. --- (Term t, StartEndLoc t, Printable t) => --- [PosToken] -> t -> (SimpPos, SimpPos) --- -- Defined at RefacLocUtils.hs:1188:1 - --- type HsExpP = HsExpI PNT -- Defined at RefacTypeSyn.hs:17:6 - - --- data PNT = PNT PName (IdTy PId) OptSrcLoc --- -- Defined at ../tools/base/defs/PNT.hs:23:6 - - --- --------------------------------------------------------------------- - pwd :: IO FilePath pwd = getCurrentDirectory @@ -172,7 +145,10 @@ -- GHC.setContext [GHC.IIModule (GHC.moduleName $ GHC.ms_mod modSum)] setGhcContext modSum - tokens <- GHC.getRichTokenStream (GHC.ms_mod modSum) + -- Use the workaround to get the tokens, the existing one does + -- not return tokens for CPP processed files. + -- tokens <- GHC.getRichTokenStream (GHC.ms_mod modSum) + tokens <- getRichTokenStreamWA (GHC.ms_mod modSum) mtm <- gets rsModule case mtm of Just tm -> if ((rsStreamModified tm == False) @@ -205,13 +181,6 @@ let [(_,modSum)] = mm getModuleDetails modSum -{- -getExports (GHC.L _ hsmod) = - case hsmod of - GHC.HsModule _ (Just exports) _ _ _ _ -> exports - _ -> [] --} - -- --------------------------------------------------------------------- -- | The result of a refactoring is the file, a flag as to whether it @@ -226,31 +195,6 @@ -- It is intended that this forms the umbrella function, in which -- applyRefac is called -- -{- -runRefacSessionOld :: Maybe RefactSettings - -> Maybe FilePath -- ^ main module for the project being refactored - -> RefactGhc [ApplyRefacResult] -- ^ The computation doing - -- the refactoriing - -> IO [FilePath] -runRefacSessionOld settings maybeMainFile comp = do - let - initialState = RefSt - { rsSettings = fromMaybe defaultSettings settings - , rsUniqState = 1 - , rsFlags = RefFlags False - , rsStorage = StorageNone - , rsModule = Nothing - } - (refactoredMods,_s) <- runRefactGhc (initGhcSession >> - loadModuleGraphGhc maybeMainFile >> - comp) initialState - - let verbosity = rsetVerboseLevel (rsSettings initialState) - writeRefactoredFiles verbosity refactoredMods - return $ modifiedFiles refactoredMods --} --- ------------- - runRefacSession :: RefactSettings -> Cradle -- ^ Identifies the surrounding -- project @@ -347,32 +291,6 @@ -- --------------------------------------------------------------------- -{- ++AZ++ TODO: replace this with a single function -} - -{- --- | Update the occurrence of one syntax phrase in a given scope by --- another syntax phrase -updateR :: (SYB.Data t,SYB.Data t1, GHC.OutputableBndr t) - => 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. -updateR old new t - = everywhereMStaged SYB.Renamer (SYB.mkM inExp) t - where - inExp :: GHC.Located t -> RefactGhc (GHC.Located t) - -- inExp (e::(GHC.OutputableBndr n, SYB.Data n) => GHC.Located n) - -- inExp (e@(GHC.L l _)::(GHC.OutputableBndr n, SYB.Data n) => GHC.Located n) - inExp (e@(GHC.L l _)) - | sameOccurrence e old - = do (new', _) <- updateToks old new prettyprint - -- error "update: updated tokens" -- ++AZ++ debug - return new' - | otherwise = return e --} - --- --------------------------------------------------------------------- - fileNameFromModSummary :: GHC.ModSummary -> FilePath fileNameFromModSummary modSummary = fileName where @@ -506,31 +424,10 @@ getDynFlags :: IO GHC.DynFlags getDynFlags = getDynamicFlags -{- - let - initialState = RefSt - { rsSettings = RefSet [] Normal - , rsUniqState = 1 - , rsFlags = RefFlags False - , rsStorage = StorageNone - , rsModule = Nothing - } - (df,_) <- runRefactGhc GHC.getSessionDynFlags initialState - return df --} -- --------------------------------------------------------------------- -- | Write refactored program source to files. -{- -writeRefactoredFiles::Bool -- ^ True means the current refactoring is a sub-refactoring - ->[((String,Bool),([PosToken],HsModuleP))] - -- ^ String: the file name; Bool: True means the file has - -- been modified.[PosToken]: the token stream; HsModuleP: - -- the module AST. - -> m () --} --- writeRefactoredFiles (isSubRefactor::Bool) (files::[((String,Bool),([PosToken], HsModuleP))]) writeRefactoredFiles :: VerboseLevel -> [((String, Bool), ([PosToken], GHC.RenamedSource))] -> IO () writeRefactoredFiles verbosity files @@ -626,20 +523,6 @@ -- --------------------------------------------------------------------- --- | Return True if the given module name exists in the project. ---isAnExistingMod::( ) =>ModuleName->PFE0MT n i ds ext m Bool - -{- -isAnExistingMod::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=> - ModuleName->PFE0MT n i ds ext m Bool - -isAnExistingMod m - = do ms<-allModules - return (elem m ms) --} - --- --------------------------------------------------------------------- - -- | Get the current module graph, provided we are in a live GHC session getCurrentModuleGraph :: RefactGhc GHC.ModuleGraph getCurrentModuleGraph = GHC.getModuleGraph @@ -650,11 +533,5 @@ g <- getCurrentModuleGraph let scc = GHC.topSortModuleGraph False g Nothing return scc - --- getSubGraph optms = concat # getSortedSubGraph optms --- getSortedSubGraph optms = flip optSubGraph optms # sortCurrentModuleGraph --- allModules = moduleList # sortCurrentModuleGraph --- moduleList g = [m|scc<-g,(_,(m,_))<-scc] - diff --git a/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs b/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs @@ -0,0 +1,120 @@ +-- | Provide workarounds for bugs detected in GHC, until they are +-- fixed in a later version + +module Language.Haskell.Refact.Utils.GhcBugWorkArounds + ( + getRichTokenStreamWA + ) where + +import qualified Bag as GHC +import qualified DynFlags as GHC +import qualified ErrUtils as GHC +import qualified FastString as GHC +import qualified GHC as GHC +import qualified HscTypes as GHC +import qualified Lexer as GHC +import qualified MonadUtils as GHC +import qualified Outputable as GHC +import qualified SrcLoc as GHC +import qualified StringBuffer as GHC + +import Control.Exception +import Data.IORef +import System.Directory +import System.FilePath +import qualified Data.Map as Map + +import Language.Haskell.Refact.Utils.GhcVersionSpecific + + +-- | Replacement for original 'getRichTokenStream' which will return +-- the tokens for a file processed by CPP. +-- See bug +getRichTokenStreamWA :: GHC.GhcMonad m => GHC.Module -> m [(GHC.Located GHC.Token, String)] +getRichTokenStreamWA mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1 + case GHC.lexTokenStream source startLoc flags of + GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc source ts + GHC.PFailed span err -> + do + strSrcBuf <- getPreprocessedSrc sourceFile + case GHC.lexTokenStream strSrcBuf startLoc flags of + GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc source ts + GHC.PFailed span err -> + do dflags <- GHC.getDynFlags + throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags span err) + +-- --------------------------------------------------------------------- + +-- | The preprocessed files are placed in a temporary directory, with +-- a temporary name, and extension .hscpp. Each of these files has +-- three lines at the top identifying the original origin of the +-- files, which is ignored by the later stages of compilation except +-- to contextualise error messages. +getPreprocessedSrc :: + GHC.GhcMonad m => FilePath -> m GHC.StringBuffer +getPreprocessedSrc srcFile = do + df <- GHC.getSessionDynFlags + d <- GHC.liftIO $ getTempDir df + fileList <- GHC.liftIO $ getDirectoryContents d + let suffix = "hscpp" + + let cppFiles = filter (\f -> getSuffix f == suffix) fileList + origNames <- GHC.liftIO $ mapM getOriginalFile $ map (\f -> d f) cppFiles + let tmpFile = head $ filter (\(o,_) -> o == srcFile) origNames + buf <- GHC.liftIO $ GHC.hGetStringBuffer $ snd tmpFile + + -- strSrcWithHead <- GHC.liftIO $ readFile $ snd tmpFile + -- let strSrc = unlines $ drop 3 $ lines strSrcWithHead + -- let strSrcBuf = GHC.stringToStringBuffer strSrc + + return buf + +-- --------------------------------------------------------------------- + +getSuffix :: FilePath -> String +getSuffix fname = reverse $ fst $ break (== '.') $ reverse fname + +-- | A GHC preprocessed file has the following comments at the top +-- @ +-- # 1 "./test/testdata/BCpp.hs" +-- # 1 "" +-- # 1 "./test/testdata/BCpp.hs" +-- @ +-- This function reads the first line of the file and returns the +-- string in it. +-- NOTE: no error checking, will blow up if it fails +getOriginalFile :: FilePath -> IO (FilePath,FilePath) +getOriginalFile fname = do + fcontents <- readFile fname + let firstLine = head $ lines fcontents + let (_,originalFname) = break (== '"') firstLine + return $ (tail $ init $ originalFname,fname) + + +-- --------------------------------------------------------------------- +-- Copied from the GHC source, since not exported + +getModuleSourceAndFlags :: GHC.GhcMonad m => GHC.Module -> m (String, GHC.StringBuffer, GHC.DynFlags) +getModuleSourceAndFlags mod = do + m <- GHC.getModSummary (GHC.moduleName mod) + case GHC.ml_hs_file $ GHC.ms_location m of + Nothing -> do dflags <- GHC.getDynFlags + GHC.liftIO $ throwIO $ GHC.mkApiErr dflags (GHC.text "No source available for module " GHC.<+> GHC.ppr mod) + -- error $ ("No source available for module " ++ showGhc mod) + Just sourceFile -> do + source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile + return (sourceFile, source, GHC.ms_hspp_opts m) + +-- return our temporary directory within tmp_dir, creating one if we +-- don't have one yet +getTempDir :: GHC.DynFlags -> IO FilePath +getTempDir dflags + = do let ref = GHC.dirsToClean dflags + tmp_dir = GHC.tmpDir dflags + mapping <- readIORef ref + case Map.lookup tmp_dir mapping of + Nothing -> error "should already be a tmpDir" + Just d -> return d +