Drop memory-mapped files, since ghc doesn't play well with those

All files are now "redirected", either user-created, or created by ghc-mod itself.

Language/Haskell/GhcMod.hs

@@ -66,6 +66,7 @@ module Language.Haskell.GhcMod (
   , gmUnsafeErrStrLn
   -- * FileMapping
   , loadMappedFile
+  , loadMappedFileSource
   , unloadMappedFile
   ) where
 

Language/Haskell/GhcMod/FileMapping.hs

@@ -1,5 +1,6 @@
 module Language.Haskell.GhcMod.FileMapping
     ( loadMappedFile
+    , loadMappedFileSource
     , unloadMappedFile
     , mapFile
     , fileModSummaryWithMapping
@@ -11,43 +12,55 @@ import Language.Haskell.GhcMod.Gap
 import Language.Haskell.GhcMod.HomeModuleGraph
 import Language.Haskell.GhcMod.Utils
 
-import Data.Time
+import System.IO
+import System.FilePath
+import System.Directory
 
 import Control.Monad.Trans.Maybe
 import GHC
+import Control.Monad
+import Control.Monad.Trans (lift)
 
-loadMappedFile :: IOish m => FilePath -> FileMapping -> GhcModT m ()
-loadMappedFile from fm =
-  getCanonicalFileNameSafe from >>= (`addMMappedFile` fm)
+loadMappedFile :: IOish m => FilePath -> FilePath -> GhcModT m ()
+loadMappedFile from to =
+  getCanonicalFileNameSafe from >>= (`addMMappedFile` FileMapping to False)
 
-mapFile :: (IOish m, GmState m, GhcMonad m) =>
+loadMappedFileSource :: IOish m => FilePath -> String -> GhcModT m ()
+loadMappedFileSource from src = do
+  tmpdir <- cradleTempDir `fmap` cradle
+  to <- liftIO $ do
+    (fn, h) <- openTempFile tmpdir (takeFileName from)
+    hPutStr h src
+    hClose h
+    return fn
+  getCanonicalFileNameSafe from >>= (`addMMappedFile` FileMapping to True)
+
+mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>
             HscEnv -> Target -> m Target
 mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do
   mapping <- lookupMMappedFile filePath
-  mkMappedTarget tid taoc mapping
+  mkMappedTarget (Just filePath) tid taoc mapping
 mapFile env (Target tid@(TargetModule moduleName) taoc _) = do
-  mapping <- runMaybeT $ do
-    filePath <- MaybeT $ liftIO $ findModulePath env moduleName
-    MaybeT $ lookupMMappedFile $ mpPath filePath
-  mkMappedTarget tid taoc mapping
+  (fp, mapping) <- do
+    filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)
+    mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile
+    return (filePath, mmf)
+  mkMappedTarget fp tid taoc mapping
 
-mkMappedTarget :: (IOish m, GmState m, GhcMonad m) =>
-                  TargetId -> Bool -> Maybe FileMapping -> m Target
-mkMappedTarget _ taoc (Just (RedirectedMapping to)) =
-  return $ mkTarget (TargetFile to Nothing) taoc Nothing
-mkMappedTarget tid taoc (Just (MemoryMapping (Just src))) = do
-  sb <- toStringBuffer [src]
-  ct <- liftIO getCurrentTime
-  return $ mkTarget tid taoc $ Just (sb, ct)
-mkMappedTarget tid taoc _ = return $ mkTarget tid taoc Nothing
+mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) =>
+                  Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target
+mkMappedTarget _ _ taoc (Just to) =
+  return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing
+mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing
 
 unloadMappedFile :: IOish m => FilePath -> GhcModT m ()
-unloadMappedFile = (delMMappedFile =<<) . getCanonicalFileNameSafe
+unloadMappedFile what = void $ runMaybeT $ do
+  cfn <- lift $ getCanonicalFileNameSafe what
+  fm <- MaybeT $ lookupMMappedFile cfn
+  liftIO $ when (fmTemp fm) $ removeFile (fmPath fm)
+  delMMappedFile cfn
 
 fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>
                             FilePath -> m ModSummary
-fileModSummaryWithMapping fn = do
-  mmf <- getCanonicalFileNameSafe fn >>= lookupMMappedFile
-  case mmf of
-    Just (RedirectedMapping to) -> fileModSummary to
-    _                           -> fileModSummary fn
+fileModSummaryWithMapping fn =
+  withMappedFile fn $ \fn' -> fileModSummary fn'

Language/Haskell/GhcMod/HomeModuleGraph.hs

@@ -44,6 +44,7 @@ import Control.Arrow ((&&&))
 import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Control.Monad.Trans (lift)
 import Control.Monad.State.Strict (execStateT)
 import Control.Monad.State.Class
 import Data.Maybe
@@ -62,7 +63,7 @@ import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Logger
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Utils (getMappedFileSource)
+import Language.Haskell.GhcMod.Utils (withMappedFile)
 import Language.Haskell.GhcMod.Gap (parseModuleHeader)
 
 -- | Turn module graph into a graphviz dot file
@@ -247,19 +248,9 @@ preprocessFile :: (IOish m, GmEnv m, GmState m) =>
   HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))
 preprocessFile env file =
   withLogger' env $ \setDf -> do
-    src <- runMaybeT $ getMappedFileSource file
-    let env' = env { hsc_dflags = setDf (hsc_dflags env) }
-    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)
+    withMappedFile file $ \fn -> do
+      let env' = env { hsc_dflags = setDf (hsc_dflags env) }
+      liftIO $ preprocess env' (fn, Nothing)
 
 fileModuleName :: (IOish m, GmEnv m, GmState m) =>
   HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))
@@ -269,11 +260,12 @@ fileModuleName env fn = do
     case ep of
       Left errs -> do
         return $ Left errs
-      Right (_warns, (dflags, procdFile)) -> handler $ do
+      Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do
         src <- readFile procdFile
         case parseModuleHeader src dflags procdFile of
-          Left errs -> do
-            return $ Left $ errBagToStrList env errs
+          Left errs -> return $ Left errs
           Right (_, lmdl) -> do
             let HsModule {..} = unLoc lmdl
-            return $ Right $ unLoc <$> hsmodName
+            return $ Right $ unLoc <$> hsmodName)
+  where
+    leftM f = either (return . Left <=< f) (return . Right)

Language/Haskell/GhcMod/Logger.hs

@@ -108,12 +108,16 @@ withLogger' env action = do
 
     return ((,) ls <$> a)
 
-errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]
+errBagToStrList :: (Functor m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]
 errBagToStrList env errs = let
     dflags = hsc_dflags env
     pu = icPrintUnqual dflags (hsc_IC env)
     st = mkUserStyle pu AllTheWay
- in runReader (errsToStr (bagToList errs)) GmPprEnv{gpeDynFlags=dflags, gpePprStyle=st}
+ in do
+   rfm <- mkRevRedirMapFunc
+   return $ runReader
+    (errsToStr (bagToList errs))
+    GmPprEnv{gpeDynFlags=dflags, gpePprStyle=st, gpeMapFile=rfm}
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Target.hs

@@ -151,7 +151,7 @@ runGmlTWith efnmns' mdf wrapper action = do
 
     let (fns, mns) = partitionEithers efnmns'
         ccfns = map (cradleCurrentDir crdl </>) fns
-    cfns <- liftIO $ mapM canonicalizePath ccfns
+    cfns <- mapM getCanonicalFileNameSafe ccfns
     let serfnmn = Set.fromList $ map Right mns ++ map Left cfns
     opts <- targetGhcOptions crdl serfnmn
     let opts' = opts ++ ["-O0"] ++ ghcUserOptions

Language/Haskell/GhcMod/Types.hs

@@ -69,8 +69,7 @@ data OutputStyle = LispStyle  -- ^ S expression style.
 -- | The type for line separator. Historically, a Null string is used.
 newtype LineSeparator = LineSeparator String deriving (Show)
 
-data FileMapping =  RedirectedMapping FilePath
-                  | MemoryMapping (Maybe String)
+data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}
                   deriving Show
 
 type FileMappingMap = Map FilePath FileMapping
@@ -99,7 +98,7 @@ data Options = Options {
   -- | If 'True', 'browse' will return fully qualified name
   , qualified     :: Bool
   , hlintOpts     :: [String]
-  , fileMappings  :: [(FilePath,FileMapping)]
+  , fileMappings  :: [(FilePath, Maybe FilePath)]
   } deriving (Show)
 
 -- | A default 'Options'.

Language/Haskell/GhcMod/Utils.hs

@@ -26,25 +26,23 @@ module Language.Haskell.GhcMod.Utils (
 import Control.Applicative
 import Data.Char
 import qualified Data.Map as M
-import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Maybe (fromMaybe)
 import Exception
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad.Types
 import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
-                         getTemporaryDirectory, canonicalizePath, removeFile)
+                         getTemporaryDirectory, canonicalizePath)
 import System.Environment
 import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
                         (</>), makeRelative)
-import System.IO.Temp (createTempDirectory, openTempFile)
-import System.IO (hPutStr, hClose)
+import System.IO.Temp (createTempDirectory)
 import System.Process (readProcess)
 import Text.Printf
 
 import Paths_ghc_mod (getLibexecDir)
 import Utils
 import Prelude
-import Control.Monad.Trans.Maybe
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@@ -167,44 +165,26 @@ withMappedFile :: (IOish m, GmState m, GmEnv m) =>
                   forall a. FilePath -> (FilePath -> m a) -> m a
 withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile
   where
-    runWithFile (Just (RedirectedMapping to)) = action to
-    runWithFile (Just (MemoryMapping (Just src))) = do
-      crdl <- cradle
-      (fp,hndl) <- liftIO $ openTempFile (cradleTempDir crdl) (takeFileName file)
-      liftIO $ hPutStr hndl src
-      liftIO $ hClose hndl
-      result <- action fp
-      liftIO $ removeFile fp
-      return result
+    runWithFile (Just to) = action $ fmPath to
     runWithFile _ = action file
 
 getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath
 getCanonicalFileNameSafe fn = do
   crdl <- cradle
-  let ccfn = cradleCurrentDir crdl </> fn
+  let ccfn = cradleRootDir crdl </> fn
   fex <- liftIO $ doesFileExist ccfn
   if fex
     then liftIO $ canonicalizePath 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 = do
-  rm <- M.fromList <$> mapMaybe (uncurry mf) <$> M.toList <$> getMMappedFiles
+  rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles
   crdl <- cradle
   return $ \key ->
     fromMaybe key
     $ makeRelative (cradleRootDir crdl)
     <$> M.lookup key rm
   where
-    mf :: FilePath -> FileMapping -> Maybe (FilePath, FilePath)
-    mf from (RedirectedMapping to)
-           = Just (to, from)
-    mf _ _ = Nothing
+    mf :: FilePath -> FileMapping -> (FilePath, FilePath)
+    mf from to = (fmPath to, from)