HaRe 0.7.0.4 → 0.7.0.5
raw patch · 3 files changed
+127/−129 lines, 3 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Language.Haskell.Refact.Utils.GhcBugWorkArounds: getRichTokenStreamWA :: GhcMonad m => Module -> m [(Located Token, String)]
Files
- HaRe.cabal +2/−1
- src/Language/Haskell/Refact/Utils.hs +5/−128
- src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs +120/−0
HaRe.cabal view
@@ -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
src/Language/Haskell/Refact/Utils.hs view
@@ -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]-
+ src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs view
@@ -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 <http://ghc.haskell.org/trac/ghc/ticket/8265>+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 "<command-line>"+-- # 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+