Initial support for file redirection

Rewrite, taking discussion into consideration

Language/Haskell/GhcMod.hs

@@ -9,6 +9,7 @@ module Language.Haskell.GhcMod (
   , Options(..)
   , LineSeparator(..)
   , OutputStyle(..)
+  , FileMapping(..)
   , defaultOptions
   -- * Logging
   , GmLogLevel
@@ -63,6 +64,9 @@ module Language.Haskell.GhcMod (
   , gmErrStrLn
   , gmUnsafePutStrLn
   , gmUnsafeErrStrLn
+  -- * FileMapping
+  , getMMappedFiles
+  , setMMappedFiles
   ) where
 
 import Language.Haskell.GhcMod.Boot

Language/Haskell/GhcMod/FileMapping.hs

@@ -0,0 +1,62 @@
+module Language.Haskell.GhcMod.FileMapping
+    ( loadMappedFile
+    , loadMappedFiles
+    , delMMappedFile
+    , mapFile
+    ) where
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Gap
+import Language.Haskell.GhcMod.HomeModuleGraph
+
+import System.Directory
+import System.FilePath
+
+import Data.Time
+
+import GHC
+
+loadMappedFiles :: IOish m => GhcModT m ()
+loadMappedFiles = do
+  Options {fileMappings} <- options
+  mapM_ (uncurry loadMappedFile) $ reverse fileMappings
+
+loadMappedFile :: IOish m => FilePath -> FileMapping -> GhcModT m ()
+loadMappedFile from fm@(RedirectedMapping _) =
+  addToState from fm
+loadMappedFile from (MemoryMapping _) = do
+  let loop' acc = do
+        line <- getLine
+        if not (null line) && last line == '\EOT'
+        then return $ acc ++ init line
+        else loop' (acc++line++"\n")
+  src <- liftIO $ loop' ""
+  addToState from (MemoryMapping $ Just src)
+
+addToState :: IOish m => FilePath -> FileMapping -> GhcModT m ()
+addToState from fm = do
+  crdl <- cradle
+  let ccfn = cradleCurrentDir crdl </> from
+  cfn <- liftIO $ canonicalizePath ccfn
+  addMMappedFile cfn fm
+
+mapFile :: (IOish m, GmState m, GhcMonad m) =>
+            HscEnv -> Target -> m Target
+mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do
+  mapping <- lookupMMappedFile filePath
+  mkMappedTarget tid taoc mapping
+mapFile env (Target tid@(TargetModule moduleName) taoc _) = do
+  filePath <- liftIO $ findModulePath env moduleName
+  mapping <- maybe (return Nothing) lookupMMappedFile $ fmap mpPath filePath
+  mkMappedTarget 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

Language/Haskell/GhcMod/HomeModuleGraph.hs

@@ -62,6 +62,8 @@ import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Gap (parseModuleHeader)
 
+import System.IO
+
 -- | Turn module graph into a graphviz dot file
 --
 -- @dot -Tpng -o modules.png modules.dot@
@@ -124,7 +126,7 @@ pruneUnreachable smp0 gmg@GmModuleGraph {..} = let
 collapseMaybeSet :: Maybe (Set a) -> Set a
 collapseMaybeSet = maybe Set.empty id
 
-homeModuleGraph :: (IOish m, GmLog m, GmEnv m)
+homeModuleGraph :: (IOish m, GmLog m, GmEnv m, GmState m)
     => HscEnv -> Set ModulePath -> m GmModuleGraph
 homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp
 
@@ -159,7 +161,7 @@ canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do
    fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))
 
 
-updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m)
+updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m, GmState m)
                       => HscEnv
                       -> GmModuleGraph
                       -> Set ModulePath -- ^ Initial set of modules
@@ -185,7 +187,7 @@ mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath
 mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp
 
 updateHomeModuleGraph'
-    :: forall m. (MonadState S m, IOish m, GmLog m, GmEnv m)
+    :: forall m. (MonadState S m, IOish m, GmLog m, GmEnv m, GmState m)
     => HscEnv
     -> Set ModulePath     -- ^ Initial set of modules
     -> m ()
@@ -224,6 +226,7 @@ updateHomeModuleGraph' env smp0 = do
             gmLog GmWarning ("preprocess " ++ show fn) $ Monoid.mempty $+$ (vcat $ map text errs)
             return Nothing
 
+
    imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)
    imports mp@ModulePath {..} src dflags =
        case parseModuleHeader src dflags mpPath of

Language/Haskell/GhcMod/Internal.hs

@@ -56,6 +56,8 @@ module Language.Haskell.GhcMod.Internal (
   -- * Misc stuff
   , GHandler(..)
   , gcatches
+  -- * FileMapping
+  , module Language.Haskell.GhcMod.FileMapping
   ) where
 
 import GHC.Paths (libdir)
@@ -70,6 +72,7 @@ import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.World
 import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.FileMapping
 
 -- | Obtaining the directory for ghc system libraries.
 ghcLibDir :: FilePath

Language/Haskell/GhcMod/Monad/Types.hs

@@ -48,6 +48,11 @@ module Language.Haskell.GhcMod.Monad.Types (
   , withOptions
   , getCompilerMode
   , setCompilerMode
+  , getMMappedFiles
+  , setMMappedFiles
+  , addMMappedFile
+  , delMMappedFile
+  , lookupMMappedFile
   -- * Re-exporting convenient stuff
   , MonadIO
   , liftIO
@@ -99,6 +104,8 @@ import qualified Control.Monad.IO.Class as MTL
 import Data.Monoid (Monoid)
 #endif
 
+import Data.Map (Map, empty)
+import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid
 import Data.IORef
@@ -228,6 +235,11 @@ class Monad m => GmState m where
       return a
     {-# MINIMAL gmsState | gmsGet, gmsPut #-}
 
+instance GmState m => GmState (StateT s m) where
+    gmsGet = lift gmsGet
+    gmsPut = lift . gmsPut
+    gmsState = lift . gmsState
+
 instance Monad m => GmState (StateT GhcModState m) where
     gmsGet = get
     gmsPut = put
@@ -434,6 +446,24 @@ getCompilerMode = gmCompilerMode `liftM` gmsGet
 setCompilerMode :: GmState m => CompilerMode -> m ()
 setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
 
+getMMappedFiles :: GmState m => m FileMappingMap
+getMMappedFiles = gmMMappedFiles `liftM` gmsGet
+
+setMMappedFiles :: GmState m => FileMappingMap -> m ()
+setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet
+
+addMMappedFile  :: GmState m => FilePath -> FileMapping -> m ()
+addMMappedFile t fm =
+  getMMappedFiles >>= setMMappedFiles . M.insert t fm
+
+delMMappedFile  :: GmState m => FilePath -> m ()
+delMMappedFile t =
+  getMMappedFiles >>= setMMappedFiles . M.delete t
+
+lookupMMappedFile  :: GmState m => FilePath -> m (Maybe FileMapping)
+lookupMMappedFile t =
+  M.lookup t `liftM` getMMappedFiles
+
 withOptions :: GmEnv m => (Options -> Options) -> m a -> m a
 withOptions changeOpt action = gmeLocal changeEnv action
   where

Language/Haskell/GhcMod/Target.hs

@@ -39,7 +39,7 @@ import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils as U
-
+import Language.Haskell.GhcMod.FileMapping
 
 import Data.Maybe
 import Data.Monoid as Monoid
@@ -163,11 +163,20 @@ runGmlTWith efnmns' mdf wrapper action = do
     initSession opts' $
         setModeSimple >>> setEmptyLogger >>> mdf
 
-    let rfns = map (makeRelative $ cradleRootDir crdl) cfns
-
     unGmlT $ wrapper $ do
-      loadTargets (map moduleNameString mns ++ rfns)
+      targets <-
+        withLightHscEnv opts $ \env ->
+                mapM (`guessTarget` Nothing) (map moduleNameString mns ++ cfns)
+            >>= mapM (mapFile env)
+            >>= mapM relativize
+      loadTargets targets
       action
+  where
+    relativize (Target (TargetFile filePath phase) taoc src) = do
+      crdl <- cradle
+      let tid = makeRelative (cradleRootDir crdl) filePath `TargetFile` phase
+      return $ Target tid taoc src
+    relativize tgt = return tgt
 
 targetGhcOptions :: forall m. IOish m
                   => Cradle
@@ -310,7 +319,7 @@ sandboxOpts crdl = do
     getSandboxPackageDbStack cdir =
         ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
 
-resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
+resolveGmComponent :: (IOish m, GmLog m, GmEnv m, GmState m)
     => Maybe [CompilationUnit] -- ^ Updated modules
     -> GmComponent 'GMCRaw (Set ModulePath)
     -> m (GmComponent 'GMCResolved (Set ModulePath))
@@ -335,7 +344,7 @@ resolveGmComponent mums c@GmComponent {..} = do
            [ "-optP-include", "-optP" ++ macrosHeaderPath ]
         ]
 
-resolveEntrypoint :: (IOish m, GmEnv m, GmLog m)
+resolveEntrypoint :: (IOish m, GmEnv m, GmLog m, GmState m)
     => Cradle
     -> GmComponent 'GMCRaw ChEntrypoint
     -> m (GmComponent 'GMCRaw (Set ModulePath))
@@ -367,7 +376,8 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do
 chModToMod :: ChModuleName -> ModuleName
 chModToMod (ChModuleName mn) = mkModuleName mn
 
-resolveModule :: (MonadIO m, GmEnv m, GmLog m) =>
+
+resolveModule :: (MonadIO m, GmEnv m, GmLog m, GmState m) =>
   HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)
 resolveModule env _srcDirs (Right mn) =
     liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
@@ -427,12 +437,11 @@ resolveGmComponents mumns cs = do
    same f a b = (f a) == (f b)
 
 -- | Set the files as targets and load them.
-loadTargets :: IOish m => [String] -> GmlT m ()
+loadTargets :: IOish m => [Target] -> GmlT m ()
-loadTargets filesOrModules = do
+loadTargets targets = do
     gmLog GmDebug "loadTargets" $
-          text "Loading" <+>: fsep (map text filesOrModules)
+          text "Loading" <+>: fsep (map (text . showTargetId) targets)
 
-    targets <- forM filesOrModules (flip guessTarget Nothing)
     setTargets targets
 
     mode <- getCompilerMode
@@ -459,16 +468,19 @@ loadTargets filesOrModules = do
         void $ setSessionDynFlags (setModeIntelligent df)
         void $ load LoadAllTargets
 
-    resetTargets targets = do
+    resetTargets targets' = do
         setTargets []
         void $ load LoadAllTargets
-        setTargets targets
+        setTargets targets'
 
     setIntelligent = do
         newdf <- setModeIntelligent <$> getSessionDynFlags
         void $ setSessionDynFlags newdf
         setCompilerMode Intelligent
 
+    showTargetId (Target (TargetModule s) _ _) = moduleNameString s
+    showTargetId (Target (TargetFile s _) _ _) = s
+
 needsFallback :: ModuleGraph -> Bool
 needsFallback = any $ \ms ->
                 let df = ms_hspp_opts ms in

Language/Haskell/GhcMod/Types.hs

@@ -69,6 +69,12 @@ 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)
+                  deriving Show
+
+type FileMappingMap = Map FilePath FileMapping
+
 data Options = Options {
     outputStyle   :: OutputStyle
   -- | Line separator string.
@@ -93,6 +99,7 @@ data Options = Options {
   -- | If 'True', 'browse' will return fully qualified name
   , qualified     :: Bool
   , hlintOpts     :: [String]
+  , fileMappings  :: [(FilePath,FileMapping)]
   } deriving (Show)
 
 -- | A default 'Options'.
@@ -110,6 +117,7 @@ defaultOptions = Options {
   , detailed       = False
   , qualified      = False
   , hlintOpts      = []
+  , fileMappings   = []
   }
 
 ----------------------------------------------------------------
@@ -182,13 +190,14 @@ data GhcModState = GhcModState {
     , gmComponents   :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
     , gmCompilerMode :: !CompilerMode
     , gmCaches       :: !GhcModCaches
+    , gmMMappedFiles :: !FileMappingMap
     }
 
 data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
 
 defaultGhcModState :: GhcModState
 defaultGhcModState =
-    GhcModState n Map.empty Simple (GhcModCaches n n n n)
+    GhcModState n Map.empty Simple (GhcModCaches n n n n) Map.empty
  where n = Nothing
 
 ----------------------------------------------------------------

ghc-mod.cabal

@@ -105,6 +105,7 @@ Library
                         Language.Haskell.GhcMod.Doc
                         Language.Haskell.GhcMod.DynFlags
                         Language.Haskell.GhcMod.Error
+                        Language.Haskell.GhcMod.FileMapping
                         Language.Haskell.GhcMod.FillSig
                         Language.Haskell.GhcMod.Find
                         Language.Haskell.GhcMod.Flag

src/GHCMod.hs

@@ -5,6 +5,7 @@ module Main where
 import Config (cProjectVersion)
 import MonadUtils (liftIO)
 import Control.Applicative
+import Control.Arrow
 import Control.Monad
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
@@ -270,6 +271,14 @@ globalArgSpec =
                reqArg "OPT" $ \g o -> Right $
                    o { ghcUserOptions = g : ghcUserOptions o }
 
+      , option "" ["file-map"] "Redirect one file to another, --file-map \"file1.hs=file2.hs\"" $
+               reqArg "OPT" $ \g o ->
+                  let m = case second (drop 1) $ span (/='=') g of
+                            (s,"") -> (s, MemoryMapping Nothing)
+                            (f,t)  -> (f, RedirectedMapping t)
+                  in
+                  Right $ o { fileMappings = m : fileMappings o }
+
       , option "" ["with-ghc"] "GHC executable to use" $
                reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p }
 
@@ -429,6 +438,12 @@ legacyInteractiveLoop symdbreq world = do
         "boot"   -> bootCmd []
         "browse" -> browseCmd args
 
+        "load"   -> loadMappedFile arg (MemoryMapping Nothing)
+                 >> return ""
+
+        "unload" -> delMMappedFile arg
+                 >> return ""
+
         "quit"   -> liftIO $ exitSuccess
         ""       -> liftIO $ exitSuccess
         _        -> fatalError $ "unknown command: `" ++ cmd ++ "'"
@@ -444,6 +459,7 @@ legacyInteractiveLoop symdbreq world = do
 ghcCommands :: IOish m => [String] -> GhcModT m ()
 ghcCommands []         = fatalError "No command given (try --help)"
 ghcCommands (cmd:args) = do
+    loadMappedFiles
     gmPutStr =<< action args
  where
    action = case cmd of