From 3790fca20bd264419acb3180de3c7369f70cb035 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 31 May 2015 11:32:46 +0300 Subject: [PATCH] Initial support for file redirection Rewrite, taking discussion into consideration --- Language/Haskell/GhcMod.hs | 4 ++ Language/Haskell/GhcMod/FileMapping.hs | 62 ++++++++++++++++++++++ Language/Haskell/GhcMod/HomeModuleGraph.hs | 9 ++-- Language/Haskell/GhcMod/Internal.hs | 3 ++ Language/Haskell/GhcMod/Monad/Types.hs | 30 +++++++++++ Language/Haskell/GhcMod/Target.hs | 38 ++++++++----- Language/Haskell/GhcMod/Types.hs | 11 +++- ghc-mod.cabal | 1 + src/GHCMod.hs | 16 ++++++ 9 files changed, 157 insertions(+), 17 deletions(-) create mode 100644 Language/Haskell/GhcMod/FileMapping.hs diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index d1eecd8..d17d0e8 100644 --- a/Language/Haskell/GhcMod.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/FileMapping.hs b/Language/Haskell/GhcMod/FileMapping.hs new file mode 100644 index 0000000..f4602e6 --- /dev/null +++ b/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 diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index d10f483..6000a2e 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index ea480c8..d5fdff7 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index cfcb29b..7a866f3 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index c02d38e..386cec4 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/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 filesOrModules = do +loadTargets :: IOish m => [Target] -> GmlT m () +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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 859086c..029cd23 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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 ---------------------------------------------------------------- diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 40cdde3..8336665 100644 --- a/ghc-mod.cabal +++ b/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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 46d858d..c0f2167 100644 --- a/src/GHCMod.hs +++ b/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