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

Merge release-5.5.0.0 into master (using imerge)

This commit is contained in:
Daniel Gröber 2016-01-17 21:03:28 +01:00
parent 5efa123f36 54fe4a0edb
commit 566dbebe29
20 changed files with 195 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.Browse (
BrowseOpts(..)
) where
import Safe
import Control.Applicative
import Control.Exception (SomeException(..))
import Data.Char
@ -49,7 +50,7 @@ browse opts pkgmdl = do
goHomeModule = runGmlT [Right mdlname] $ do
processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing
tryModuleInfo m = fromJust <$> G.getModuleInfo m
tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m
(mpkg, mdl) = splitPkgMdl pkgmdl
mdlname = G.mkModuleName mdl

35
Language/Haskell/GhcMod/CabalHelper.hs
View File

@ -113,32 +113,30 @@ getComponents = chCached $ \distdir -> Cached {
, (a', c) <- lc
, a == a'
]
runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
runCHQuery a = do
getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv
getQueryEnv = do
crdl <- cradle
progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
readProc <- gmReadProcess
let projdir = cradleRootDir crdl
distdir = projdir </> cradleDistDir crdl
return (defaultQueryEnv projdir distdir) {
qeReadProcess = readProc
, qePrograms = helperProgs progs
}
opts <- options
progs <- patchStackPrograms crdl (optPrograms opts)
readProc <- gmReadProcess
let qe = (defaultQueryEnv projdir distdir) {
qeReadProcess = readProc
, qePrograms = helperProgs progs
}
runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
runCHQuery a = do
qe <- getQueryEnv
runQuery qe a
prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
prepareCabalHelper = do
crdl <- cradle
let projdir = cradleRootDir crdl
distdir = projdir </> cradleDistDir crdl
readProc <- gmReadProcess
when (isCabalHelperProject $ cradleProject crdl) $
withCabal $ liftIO $ prepare readProc projdir distdir
withCabal $ prepare' =<< getQueryEnv
withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
withAutogen action = do
@ -155,15 +153,14 @@ withAutogen action = do
when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do
gmLog GmDebug "" $ strDoc $ "autogen files out of sync"
writeAutogen projdir distdir
writeAutogen
action
where
writeAutogen projdir distdir = do
readProc <- gmReadProcess
writeAutogen = do
gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
liftIO $ writeAutogenFiles readProc projdir distdir
writeAutogenFiles' =<< getQueryEnv
withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a

15
Language/Haskell/GhcMod/Cradle.hs
View File

@ -17,10 +17,10 @@ import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Stack
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Error
import Safe
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Maybe
import System.Directory
@ -28,7 +28,6 @@ import System.FilePath
import Prelude
import Control.Monad.Trans.Journal (runJournalT)
----------------------------------------------------------------
-- | Finding 'Cradle'.
@ -40,7 +39,7 @@ findCradle = findCradle' =<< liftIO getCurrentDirectory
findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle
findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
findCradle' dir = run $
msum [ stackCradle dir
@ -48,7 +47,7 @@ findCradle' dir = run $
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
findSpecCradle dir = do
@ -99,9 +98,9 @@ stackCradle wdir = do
-- If dist/setup-config already exists the user probably wants to use cabal
-- rather than stack, or maybe that's just me ;)
whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ do
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
mzero
whenM (liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist") $ do
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
mzero
senv <- MaybeT $ getStackEnv cabalDir

134
Language/Haskell/GhcMod/Find.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, TupleSections #-}
{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}
module Language.Haskell.GhcMod.Find
#ifndef SPEC
@ -18,47 +18,47 @@ module Language.Haskell.GhcMod.Find
#endif
where
import Control.Applicative
import Control.Monad
import Control.Exception
import Control.Concurrent
import Data.List
import Data.Binary
import Data.IORef
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified GHC as G
import FastString
import Module
import OccName
import HscTypes
import Exception
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.LightGhc
import Exception
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans.Control
import Control.Concurrent
import Data.List
import Data.Binary
import Data.Function
import System.Directory
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.IORef
import System.Directory.ModTime
import System.FilePath ((</>))
import System.IO
import System.IO.Unsafe
import Prelude
import GHC.Generics (Generic)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Prelude
----------------------------------------------------------------
-- | Type of function and operation names.
@ -67,22 +67,23 @@ type ModuleNameBS = BS.ByteString
-- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb
{ table :: Map Symbol [ModuleNameBS]
, symbolDbCachePath :: FilePath
}
{ sdTable :: Map Symbol (Set ModuleNameBS)
, sdTimestamp :: ModTime
} deriving (Generic)
instance Binary SymbolDb
instance NFData SymbolDb
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
isOutdated db =
(liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
isOlderThan (sdTimestamp db) <$> timedPackageCaches
----------------------------------------------------------------
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated. 'loadSymbolDb' is called internally.
findSymbol :: IOish m => String -> GhcModT m String
findSymbol sym = do
tmpdir <- cradleTempDir <$> cradle
loadSymbolDb tmpdir >>= lookupSymbol sym
findSymbol sym = loadSymbolDb >>= lookupSymbol sym
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated.
@ -90,62 +91,36 @@ lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String
lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ M.findWithDefault [] sym $ table db
lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db
---------------------------------------------------------------
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb
loadSymbolDb dir = do
loadSymbolDb :: IOish m => GhcModT m SymbolDb
loadSymbolDb = do
ghcMod <- liftIO ghcModExecutable
readProc <- gmReadProcess
file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""
!db <- M.fromList . decode <$> liftIO (LBS.readFile file)
return $ SymbolDb
{ table = db
, symbolDbCachePath = file
}
where
chop :: String -> String
chop "" = ""
chop xs = init xs
readProc <- gmReadProcess'
out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""
return $!! decode out
----------------------------------------------------------------
-- used 'ghc-mod dumpsym'
-- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file
-- if the file does not exist or is invalid.
-- The file name is printed.
dumpSymbol :: IOish m => FilePath -> GhcModT m String
dumpSymbol dir = do
create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
pkgOpts <- packageGhcOptions
when create $ liftIO $ do
withLightHscEnv pkgOpts $ \env -> do
writeSymbolCache cache =<< getGlobalSymbolTable env
return $ unlines [cache]
where
cache = dir </> symbolCacheFile
writeSymbolCache :: FilePath
-> Map Symbol (Set ModuleNameBS)
-> IO ()
writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl ->
LBS.hPutStr hdl (encode sm)
-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout
dumpSymbol :: IOish m => GhcModT m ()
dumpSymbol = do
ts <- liftIO getCurrentModTime
st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
liftIO . LBS.putStr $ encode SymbolDb {
sdTable = st
, sdTimestamp = ts
}
-- | Check whether given file is older than any file from the given set.
-- Returns True if given file does not exist.
isOlderThan :: FilePath -> [TimedFile] -> IO Bool
isOlderThan cache files = do
exist <- doesFileExist cache
if not exist
then return True
else do
tCache <- getModTime cache
return $ any (tCache <=) $ map tfTime files -- including equal just in case
isOlderThan :: ModTime -> [TimedFile] -> Bool
isOlderThan tCache files =
any (tCache <=) $ map tfTime files -- including equal just in case
-- | Browsing all functions in all system modules.
getGlobalSymbolTable :: HscEnv -> IO (Map Symbol (Set ModuleNameBS))
@ -187,30 +162,29 @@ mkFastStringByteString' = mkFastStringByteString
----------------------------------------------------------------
data AsyncSymbolDb = AsyncSymbolDb FilePath (MVar (Either SomeException SymbolDb))
data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb))
asyncLoadSymbolDb :: IOish m
=> FilePath
-> MVar (Either SomeException SymbolDb)
=> MVar (Either SomeException SymbolDb)
-> GhcModT m ()
asyncLoadSymbolDb tmpdir mv = void $
asyncLoadSymbolDb mv = void $
liftBaseWith $ \run -> forkIO $ void $ run $ do
edb <- gtry $ loadSymbolDb tmpdir
edb <- gtry loadSymbolDb
liftIO $ putMVar mv edb
newAsyncSymbolDb :: IOish m => FilePath -> GhcModT m AsyncSymbolDb
newAsyncSymbolDb tmpdir = do
newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb
newAsyncSymbolDb = do
mv <- liftIO newEmptyMVar
asyncLoadSymbolDb tmpdir mv
return $ AsyncSymbolDb tmpdir mv
asyncLoadSymbolDb mv
return $ AsyncSymbolDb mv
getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb
getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = do
getAsyncSymbolDb (AsyncSymbolDb mv) = do
db <- liftIO $ handleEx <$> takeMVar mv
outdated <- isOutdated db
if outdated
then do
asyncLoadSymbolDb tmpdir mv
asyncLoadSymbolDb mv
liftIO $ handleEx <$> readMVar mv
else do
liftIO $ putMVar mv $ Right db

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

@ -101,6 +101,11 @@ import Module
import qualified Data.IntSet as I (IntSet, empty)
#endif
#if __GLASGOW_HASKELL__ < 706
import Control.DeepSeq (NFData(rnf))
import Data.ByteString.Lazy.Internal (ByteString(..))
#endif
import Bag
import Lexer as L
import Parser
@ -564,3 +569,9 @@ mkErrStyle' = Outputable.mkErrStyle
#else
mkErrStyle' _ = Outputable.mkErrStyle
#endif
#if __GLASGOW_HASKELL__ < 706
instance NFData ByteString where
rnf Empty = ()
rnf (Chunk _ b) = rnf b
#endif

21
Language/Haskell/GhcMod/Logging.hs
View File

@ -45,11 +45,11 @@ gmSetLogLevel :: GmLog m => GmLogLevel -> m ()
gmSetLogLevel level =
gmlJournal $ GhcModLog (Just level) (Last Nothing) []
gmGetLogLevel :: forall m. GmLog m => m GmLogLevel
gmGetLogLevel :: forall m. GmLog m => m GmLogLevel
gmGetLogLevel = do
GhcModLog { gmLogLevel = Just level } <- gmlHistory
return level
gmSetDumpLevel :: GmLog m => Bool -> m ()
gmSetDumpLevel level =
gmlJournal $ GhcModLog Nothing (Last (Just level)) []
@ -76,18 +76,19 @@ gmLog level loc' doc = do
let loc | loc' == "" = empty
| otherwise = text loc' <+>: empty
msgDoc = gmLogLevelDoc level <+>: sep [loc, doc]
msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc
msgDoc = sep [loc, doc]
msg = dropWhileEnd isSpace $ gmRenderDoc $ gmLogLevelDoc level <+>: msgDoc
when (level <= level') $ gmErrStrLn msg
gmLogQuiet level loc' doc
gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])
gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m ()
gmLogQuiet level loc doc =
gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)])
-- | Appends a collection of logs to the logging environment, with effects
-- | if their log level specifies it should
gmAppendLog :: (MonadIO m, GmLog m, GmOut m) => GhcModLog -> m ()
gmAppendLog GhcModLog { gmLogMessages } = (\(level, loc, msgDoc) -> gmLog level loc msgDoc) `mapM_` gmLogMessages
gmAppendLogQuiet :: GmLog m => GhcModLog -> m ()
gmAppendLogQuiet GhcModLog { gmLogMessages } =
forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc
gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()
gmVomit filename doc content = do

8
Language/Haskell/GhcMod/Monad.hs
View File

@ -108,10 +108,10 @@ runGhcModT :: IOish m
runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
runGmOutT opt $
withGhcModEnv dir' opt $ \(env,lg) ->
first (fst <$>) <$> runGhcModT' env defaultGhcModState
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >>
gmAppendLog lg >>
action)
first (fst <$>) <$> runGhcModT' env defaultGhcModState (do
gmSetLogLevel (ooptLogLevel $ optOutput opt)
gmAppendLogQuiet lg
action)
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
-- computation. Note that if the computation that returned @result@ modified the

2
Language/Haskell/GhcMod/Monad/Log.hs
View File

@ -62,7 +62,7 @@ instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where
gmlHistory = lift gmlHistory
gmlClear = lift gmlClear
instance (Monad m, GmLog m) => GmLog (MaybeT m) where
instance (Monad m, GmLog m) => GmLog (MaybeT m) where
gmlJournal = lift . gmlJournal
gmlHistory = lift gmlHistory
gmlClear = lift gmlClear

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

@ -73,6 +73,8 @@ import Language.Haskell.GhcMod.Monad.Out
import Language.Haskell.GhcMod.Monad.Newtypes
import Language.Haskell.GhcMod.Monad.Orphans ()
import Safe
import GHC
import DynFlags
import Exception
@ -84,6 +86,7 @@ import Control.Monad
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.Control
@ -112,14 +115,16 @@ instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
getSession = gmlGetSession
setSession = gmlSetSession
-- | Get the underlying GHC session
gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
gmlGetSession = do
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet
liftIO $ readIORef ref
-- | Set the underlying GHC session
gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m ()
gmlSetSession a = do
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet
liftIO $ flip writeIORef a ref
instance GhcMonad LightGhc where
@ -186,6 +191,13 @@ instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (Journal
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
----------------------------------------------------------------

30
Language/Haskell/GhcMod/Output.hs
View File

@ -17,6 +17,7 @@
-- Derived from process:System.Process
-- Copyright (c) The University of Glasgow 2004-2008
{-# LANGUAGE FlexibleInstances #-}
module Language.Haskell.GhcMod.Output (
gmPutStr
, gmErrStr
@ -27,12 +28,15 @@ module Language.Haskell.GhcMod.Output (
, gmErrStrIO
, gmReadProcess
, gmReadProcess'
, stdoutGateway
, flushStdoutGateway
) where
import Data.List
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS
import qualified Data.Label as L
import qualified Data.Label.Base as LB
import System.IO
@ -51,6 +55,16 @@ import Prelude
import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..))
import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..))
import Language.Haskell.GhcMod.Gap ()
class ProcessOutput a where
hGetContents' :: Handle -> IO a
instance ProcessOutput String where
hGetContents' = hGetContents
instance ProcessOutput ByteString where
hGetContents' = BS.hGetContents
outputFns :: (GmOut m, MonadIO m')
=> m (String -> m' (), String -> m' ())
@ -108,6 +122,9 @@ gmReadProcess = do
Nothing ->
return $ readProcess
gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString)
gmReadProcess' = readProcessStderrChan
flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()
flushStdoutGateway c = do
mv <- newEmptyMVar
@ -175,17 +192,14 @@ zoom l (StateT a) =
return (a', L.set l s' f)
readProcessStderrChan ::
GmOut m => m (FilePath -> [String] -> String -> IO String)
(GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a)
readProcessStderrChan = do
(_, e :: String -> IO ()) <- outputFns
return $ readProcessStderrChan' e
readProcessStderrChan' ::
(String -> IO ()) -> FilePath -> [String] -> String -> IO String
readProcessStderrChan' pute = go pute
where
go :: (String -> IO ()) -> FilePath -> [String] -> String -> IO String
go putErr exe args input = do
readProcessStderrChan' :: (ProcessOutput a, NFData a) =>
(String -> IO ()) -> FilePath -> [String] -> String -> IO a
readProcessStderrChan' putErr exe args input = do
let cp = (proc exe args) {
std_out = CreatePipe
, std_err = CreatePipe
@ -195,7 +209,7 @@ readProcessStderrChan' pute = go pute
_ <- forkIO $ reader e
output <- hGetContents o
output <- hGetContents' o
withForkWait (evaluate $ rnf output) $ \waitOut -> do
-- now write any input

17
Language/Haskell/GhcMod/Stack.hs
View File

@ -16,7 +16,7 @@
module Language.Haskell.GhcMod.Stack where
import Safe
import Control.Applicative
import Control.Exception as E
import Control.Monad
@ -33,6 +33,8 @@ import Exception
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Error
import qualified Language.Haskell.GhcMod.Utils as U
import Prelude
@ -46,10 +48,10 @@ patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do
}
patchStackPrograms _crdl progs = return progs
getStackEnv :: (IOish m, GmOut m) => FilePath -> m (Maybe StackEnv)
getStackEnv :: (IOish m, GmOut m, GmLog m) => FilePath -> m (Maybe StackEnv)
getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do
env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]
let look k = fromJust $ lookup k env
let look k = fromJustNote "getStackEnv" $ lookup k env
return StackEnv {
seDistDir = look "dist-dir"
, seBinPath = splitSearchPath $ look "bin-path"
@ -80,11 +82,14 @@ findExecutablesInDirectories' path binary =
exeExtension = if isWindows then "exe" else ""
readStack :: (IOish m, GmOut m) => [String] -> MaybeT m String
readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String
readStack args = do
stack <- MaybeT $ liftIO $ findExecutable "stack"
readProc <- lift gmReadProcess
lift $ flip gcatch (\(e :: IOError) -> exToErr e) $ do
flip gcatch handler $ do
liftIO $ evaluate =<< readProc stack args ""
where
exToErr = throw . GMEStackBootstrap . GMEString . show
handler (e :: IOError) = do
gmLog GmWarning "readStack" $ gmeDoc $ exToErr e
mzero
exToErr = GMEStackBootstrap . GMEString . show

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

@ -40,6 +40,7 @@ import Language.Haskell.GhcMod.LightGhc
import Language.Haskell.GhcMod.CustomPackageDb
import Language.Haskell.GhcMod.Output
import Safe
import Data.Maybe
import Data.Monoid as Monoid
import Data.Either
@ -104,10 +105,13 @@ dropSession = do
Nothing -> return ()
-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context
-- of certain files or modules
runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a
runGmlT fns action = runGmlT' fns return action
-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context
-- of certain files or modules, with updated GHC flags
runGmlT' :: IOish m
=> [Either FilePath ModuleName]
-> (DynFlags -> Ghc DynFlags)
@ -115,6 +119,9 @@ runGmlT' :: IOish m
-> GhcModT m a
runGmlT' fns mdf action = runGmlTWith fns mdf id action
-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context
-- of certain files or modules, with updated GHC flags and a final
-- transformation
runGmlTWith :: IOish m
=> [Either FilePath ModuleName]
-> (DynFlags -> Ghc DynFlags)
@ -182,13 +189,13 @@ targetGhcOptions crdl sefnmn = do
let cns = filter (/= ChSetupHsName) $ Map.keys mcs
gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."
return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs
return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs
else do
when noCandidates $
throwError $ GMECabalCompAssignment mdlcs
let cn = pickComponent candidates
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs
resolvedComponentsCache :: IOish m => FilePath ->
Cached (GhcModT m) GhcModState

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

@ -1,5 +1,6 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,
StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}
StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,
GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types (
module Language.Haskell.GhcMod.Types
@ -15,6 +16,7 @@ import Control.Exception (Exception)
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.DeepSeq
import Data.Binary
import Data.Binary.Generic
import Data.Map (Map)
@ -232,7 +234,7 @@ newtype Expression = Expression { getExpression :: String }
-- | Module name.
newtype ModuleString = ModuleString { getModuleString :: String }
deriving (Show, Read, Eq, Ord)
deriving (Show, Eq, Ord, Binary, NFData)
data GmLogLevel =
GmSilent

3
Setup.hs
View File

@ -8,6 +8,7 @@ import Distribution.Simple.InstallDirs as ID
import Distribution.Simple.LocalBuildInfo
import Distribution.PackageDescription
import Safe
import Control.Arrow
import Control.Applicative
import Control.Monad
@ -99,7 +100,7 @@ xInstallTarget pd lbi fn = do
libexecdir' = fromPathTemplate (libexecdir idirtpl)
pd_extended = onlyExePackageDesc [exe] pd
install_target = fromJust $ installTarget exe
install_target = fromJustNote "xInstallTarget" $ installTarget exe
install_target' = ID.substPathTemplate env install_target
-- $libexec isn't a real thing :/ so we have to simulate it
install_target'' = substLibExec' libexecdir' install_target'

11
System/Directory/ModTime.hs
View File

@ -13,10 +13,11 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
module System.Directory.ModTime where
import Control.Applicative
import Control.DeepSeq
import Data.Binary
#if MIN_VERSION_directory(1,2,0)
import Data.Time (UTCTime(..), Day(..), getCurrentTime)
@ -29,7 +30,7 @@ import Prelude
#if MIN_VERSION_directory(1,2,0)
newtype ModTime = ModTime UTCTime
deriving (Eq, Ord)
deriving (Eq, Ord, NFData)
getCurrentModTime = ModTime <$> getCurrentTime
instance Binary ModTime where
@ -41,7 +42,7 @@ instance Binary ModTime where
#else
newtype ModTime = ModTime ClockTime
deriving (Eq, Ord, Show)
deriving (Eq, Ord)
getCurrentModTime = ModTime <$> getClockTime
instance Binary ModTime where
@ -50,6 +51,10 @@ instance Binary ModTime where
get =
ModTime <$> (TOD <$> get <*> get)
instance NFData ModTime where
rnf (ModTime (TOD s ps)) =
s `seq` ps `seq` (ModTime $! TOD s ps) `seq` ()
#endif
getCurrentModTime :: IO ModTime

4
ghc-mod.cabal
View File

@ -160,7 +160,7 @@ Library
, bytestring < 0.11
, binary < 0.8 && >= 0.5.1.0
, containers < 0.6
, cabal-helper < 0.7 && >= 0.6.1.0
, cabal-helper < 0.7 && >= 0.6.3.0
, deepseq < 1.5
, directory < 1.3
, filepath < 1.5
@ -186,6 +186,7 @@ Library
, fclabels == 2.0.*
, extra == 1.4.*
, pipes == 4.1.*
, safe < 0.4 && >= 0.3.9
if impl(ghc < 7.8)
Build-Depends: convertible
if impl(ghc < 7.5)
@ -231,6 +232,7 @@ Executable ghc-modi
HS-Source-Dirs: src, .
Build-Depends: base < 5 && >= 4.0
, binary < 0.8 && >= 0.5.1.0
, deepseq < 1.5
, directory < 1.3
, filepath < 1.5
, process < 1.3

15
src/GHCMod.hs
View File

@ -6,6 +6,7 @@ import Control.Applicative
import Control.Monad
import Data.Typeable (Typeable)
import Data.List
import Data.List.Split
import Exception
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
@ -49,8 +50,7 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $
legacyInteractive :: IOish m => GhcModT m ()
legacyInteractive = do
prepareCabalHelper
tmpdir <- cradleTempDir <$> cradle
asyncSymbolDb <- newAsyncSymbolDb tmpdir
asyncSymbolDb <- newAsyncSymbolDb
world <- getCurrentWorld
legacyInteractiveLoop asyncSymbolDb world
@ -86,10 +86,15 @@ legacyInteractiveLoop asyncSymbolDb world = do
interactiveHandlers =
[ GHandler $ \(e :: ExitCode) -> throw e
, GHandler $ \(InvalidCommandLine e) -> do
gmErrStrLn $ either ("Invalid command line: "++) Prelude.id e
return ""
let err = notGood $ either ("Invalid command line: "++) Prelude.id e
liftIO $ do
putStr err
exitFailure
, GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
]
notGood msg = "NG " ++ escapeNewlines msg
escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
replace needle replacement = intercalate replacement . splitOn needle
getFileSourceFromStdin :: IO String
getFileSourceFromStdin = do
@ -137,7 +142,7 @@ ghcCommands (CmdBoot) = boot
-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
ghcCommands (CmdModules detail) = modules detail
ghcCommands (CmdDumpSym tmpdir) = dumpSymbol tmpdir
ghcCommands (CmdDumpSym) = dumpSymbol >> return ""
ghcCommands (CmdFind symb) = findSymbol symb
ghcCommands (CmdDoc m) = pkgDoc m
ghcCommands (CmdLint opts file) = lint opts file

7
src/GHCMod/Options/Commands.hs
View File

@ -42,7 +42,7 @@ data GhcModCommands =
| CmdRoot
| CmdLegacyInteractive
| CmdModules Bool
| CmdDumpSym FilePath
| CmdDumpSym
| CmdFind Symbol
| CmdDoc Module
| CmdLint LintOpts FilePath
@ -110,7 +110,7 @@ commands =
$$ info modulesArgSpec
$$ progDesc "List all visible modules"
<> command "dumpsym"
$$ info dumpSymArgSpec idm
$$ info (pure CmdDumpSym) idm
<> command "find"
$$ info findArgSpec
$$ progDesc "List all modules that define SYMBOL"
@ -226,7 +226,7 @@ locArgSpec x = x
<*> argument int (metavar "COL")
)
modulesArgSpec, dumpSymArgSpec, docArgSpec, findArgSpec,
modulesArgSpec, docArgSpec, findArgSpec,
lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,
infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,
sigArgSpec, refineArgSpec, debugComponentArgSpec,
@ -237,7 +237,6 @@ modulesArgSpec = CmdModules
$$ long "detailed"
<=> short 'd'
<=> help "Print package modules belong to"
dumpSymArgSpec = CmdDumpSym <$> strArg "TMPDIR"
findArgSpec = CmdFind <$> strArg "SYMBOL"
docArgSpec = CmdDoc <$> strArg "MODULE"
lintArgSpec = CmdLint

1
test/CradleSpec.hs
View File

@ -8,6 +8,7 @@ import System.Directory (canonicalizePath)
import System.FilePath (pathSeparator)
import Test.Hspec
import TestUtils
import Prelude
import Dir

3
test/FindSpec.hs
View File

@ -2,7 +2,6 @@
module FindSpec where
import Language.Haskell.GhcMod.Find
import Control.Monad
import Test.Hspec
import TestUtils
@ -10,5 +9,5 @@ spec :: Spec
spec = do
describe "db <- loadSymbolDb" $ do
it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do
db <- runD $ loadSymbolDb =<< (cradleTempDir `liftM` cradle)
db <- runD $ loadSymbolDb
lookupSym "head" db `shouldContain` [ModuleString "Data.List"]