hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial support for file redirection

Browse Source 
Rewrite, taking discussion into consideration
This commit is contained in:
Nikolay Yakimov 2015-05-31 11:32:46 +03:00
parent 4084e9aafc
commit 3790fca20b
9 changed files with 157 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Language/Haskell/GhcMod.hs
View File

@ -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

62
Language/Haskell/GhcMod/FileMapping.hs Normal file
View File

@ -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

9
Language/Haskell/GhcMod/HomeModuleGraph.hs
View File

@ -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

3
Language/Haskell/GhcMod/Internal.hs
View File

@ -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

30
Language/Haskell/GhcMod/Monad/Types.hs
View File

@ -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

38
Language/Haskell/GhcMod/Target.hs
View File

@ -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

11
Language/Haskell/GhcMod/Types.hs
View File

@ -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
----------------------------------------------------------------

1
ghc-mod.cabal
View File

@ -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

16
src/GHCMod.hs
View File

@ -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