Initial support for file redirection
Rewrite, taking discussion into consideration
This commit is contained in:
Nikolay Yakimov
parent
4084e9aafc
commit
3790fca20b
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue