diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index d2b3c79..05bc969 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -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 diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 7785613..119f745 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 0904eea..fe2b179 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 52c1650..5f00138 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 79c63de..48337e0 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 5fab120..a7768ff 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 431b9b8..5d90aee 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Monad/Log.hs b/Language/Haskell/GhcMod/Monad/Log.hs index f0b245b..4da0fec 100644 --- a/Language/Haskell/GhcMod/Monad/Log.hs +++ b/Language/Haskell/GhcMod/Monad/Log.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 8b2ac50..c94efcc 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -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 + ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index 7b56330..f8dfa4b 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Stack.hs b/Language/Haskell/GhcMod/Stack.hs index 6cce20e..498430e 100644 --- a/Language/Haskell/GhcMod/Stack.hs +++ b/Language/Haskell/GhcMod/Stack.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 6818ef0..7985d1a 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 51d4c3c..779c5c9 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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 diff --git a/Setup.hs b/Setup.hs index 982ec70..00db893 100755 --- a/Setup.hs +++ b/Setup.hs @@ -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' diff --git a/System/Directory/ModTime.hs b/System/Directory/ModTime.hs index 8a4eeee..0e38eae 100644 --- a/System/Directory/ModTime.hs +++ b/System/Directory/ModTime.hs @@ -13,10 +13,11 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 25edb40..01358b5 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 40340fc..fdade72 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -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 diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 3848a2c..2e1f60a 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -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 diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 9068ec7..6396437 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -8,6 +8,7 @@ import System.Directory (canonicalizePath) import System.FilePath (pathSeparator) import Test.Hspec import TestUtils +import Prelude import Dir diff --git a/test/FindSpec.hs b/test/FindSpec.hs index 74f3b85..6f693aa 100644 --- a/test/FindSpec.hs +++ b/test/FindSpec.hs @@ -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"]