Add FileMapping support to HMG/preprocessFile

Post-rebase update
This commit is contained in:
Nikolay Yakimov 2015-08-16 18:22:27 +03:00
parent 70d2a4704b
commit 654b172f5e
2 changed files with 24 additions and 1 deletions

View File

@ -54,12 +54,15 @@ import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import System.FilePath import System.FilePath
import System.Directory import System.Directory
import System.IO
import System.IO.Temp
import Prelude import Prelude
import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils (getMappedFileSource)
import Language.Haskell.GhcMod.Gap (parseModuleHeader) import Language.Haskell.GhcMod.Gap (parseModuleHeader)
-- | Turn module graph into a graphviz dot file -- | Turn module graph into a graphviz dot file
@ -244,8 +247,19 @@ preprocessFile :: (IOish m, GmEnv m, GmState m) =>
HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))
preprocessFile env file = preprocessFile env file =
withLogger' env $ \setDf -> do withLogger' env $ \setDf -> do
src <- runMaybeT $ getMappedFileSource file
let env' = env { hsc_dflags = setDf (hsc_dflags env) } let env' = env { hsc_dflags = setDf (hsc_dflags env) }
liftIO $ preprocess env' (file, Nothing) maybe
(liftIO $ preprocess env' (file, Nothing))
(preprocessWithTemp env' file)
src
where
preprocessWithTemp env' fn src = do
tmpdir <- cradleTempDir <$> cradle
liftIO $ withTempFile tmpdir fn $ \fn' hndl -> do
hPutStr hndl src
hClose hndl
preprocess env' (fn', Nothing)
fileModuleName :: (IOish m, GmEnv m, GmState m) => fileModuleName :: (IOish m, GmEnv m, GmState m) =>
HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName)) HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))

View File

@ -44,6 +44,7 @@ import Text.Printf
import Paths_ghc_mod (getLibexecDir) import Paths_ghc_mod (getLibexecDir)
import Utils import Utils
import Prelude import Prelude
import Control.Monad.Trans.Maybe
-- dropWhileEnd is not provided prior to base 4.5.0.0. -- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@ -186,6 +187,14 @@ getCanonicalFileNameSafe fn = do
then liftIO $ canonicalizePath ccfn then liftIO $ canonicalizePath ccfn
else return ccfn else return ccfn
getMappedFileSource :: (IOish m, GmEnv m, GmState m) => FilePath -> MaybeT m String
getMappedFileSource fn = do
mf <- MaybeT $ getCanonicalFileNameSafe fn >>= lookupMMappedFile
case mf of
RedirectedMapping fn' -> liftIO $ readFile fn'
MemoryMapping (Just src) -> return src
_ -> mzero
mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath) mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
mkRevRedirMapFunc = do mkRevRedirMapFunc = do
rm <- M.fromList <$> mapMaybe (uncurry mf) <$> M.toList <$> getMMappedFiles rm <- M.fromList <$> mapMaybe (uncurry mf) <$> M.toList <$> getMMappedFiles