diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index e69cc34..4ec373c 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -104,11 +104,6 @@ gmeDoc e = case e of GMETooManyCabalFiles cfs -> text $ "Multiple cabal files found. Possible cabal files: \"" ++ intercalate "\", \"" cfs ++"\"." - GMEWrongWorkingDirectory projdir cdir -> - (text $ "You must run ghc-mod in the project directory as returned by `ghc-mod root`.") - <+> text "Currently in:" <+> showDoc cdir - <> text "but should be in" <+> showDoc projdir - <> text "." ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc e@(CmdLineError _) = diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 3962b01..382bb08 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -10,34 +10,42 @@ module Language.Haskell.GhcMod.Find , findSymbol , lookupSym , isOutdated + -- * Load 'SymbolDb' asynchronously + , AsyncSymbolDb + , newAsyncSymbolDb + , getAsyncSymbolDb ) #endif where -import Control.Applicative -import Control.Monad (when, void) -import Data.Function (on) -import Data.List (groupBy, sort) -import qualified GHC as G import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Gap (listVisibleModules) +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 (timedPackageCaches) -import Language.Haskell.GhcMod.Output -import Name (getOccString) -import Module (moduleName) -import System.Directory (doesFileExist) +import Language.Haskell.GhcMod.World + +import qualified GHC as G +import Name +import Module +import Exception + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Control +import Control.Concurrent +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import System.Directory import System.Directory.ModTime import System.FilePath (()) import System.IO import Prelude -import Data.Map (Map) -import qualified Data.Map as M - ---------------------------------------------------------------- -- | Type of function and operation names. @@ -147,3 +155,39 @@ collectModules :: [(Symbol, ModuleString)] collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x) + +---------------------------------------------------------------- + +data AsyncSymbolDb = AsyncSymbolDb FilePath (MVar (Either SomeException SymbolDb)) + +asyncLoadSymbolDb :: IOish m + => FilePath + -> MVar (Either SomeException SymbolDb) + -> GhcModT m () +asyncLoadSymbolDb tmpdir mv = void $ + liftBaseWith $ \run -> forkIO $ void $ run $ do + edb <- gtry $ loadSymbolDb tmpdir + liftIO $ putMVar mv edb + +newAsyncSymbolDb :: IOish m => FilePath -> GhcModT m AsyncSymbolDb +newAsyncSymbolDb tmpdir = do + mv <- liftIO newEmptyMVar + asyncLoadSymbolDb tmpdir mv + return $ AsyncSymbolDb tmpdir mv + +getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb +getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = do + db <- liftIO $ handleEx <$> takeMVar mv + outdated <- isOutdated db + if outdated + then do + asyncLoadSymbolDb tmpdir mv + liftIO $ handleEx <$> readMVar mv + else do + liftIO $ putMVar mv $ Right db + return db + where + handleEx edb = + case edb of + Left ex -> throw ex + Right db -> db diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 2e0fe05..431b9b8 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -50,6 +50,7 @@ import Control.Monad.Trans.Journal (runJournalT) import Exception import System.Directory +import System.IO.Unsafe import Prelude withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a @@ -57,24 +58,33 @@ withGhcModEnv = withGhcModEnv' withCradle where withCradle dir = gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst) - + +cwdLock :: MVar ThreadId +cwdLock = unsafePerformIO $ newEmptyMVar +{-# NOINLINE cwdLock #-} + withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a withGhcModEnv' withCradle dir opts f = withCradle dir $ \(crdl,lg) -> withCradleRootDir crdl $ f (GhcModEnv opts crdl, lg) where - withCradleRootDir (cradleRootDir -> projdir) a = do - cdir <- liftIO $ getCurrentDirectory - eq <- liftIO $ pathsEqual projdir cdir - if not eq - then throw $ GMEWrongWorkingDirectory projdir cdir - else a + swapCurrentDirectory ndir = do + odir <- canonicalizePath =<< getCurrentDirectory + setCurrentDirectory ndir + return odir - pathsEqual a b = do - ca <- canonicalizePath a - cb <- canonicalizePath b - return $ ca == cb + withCradleRootDir (cradleRootDir -> projdir) a = do + success <- liftIO $ tryPutMVar cwdLock =<< myThreadId + if not success + then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!" + else gbracket setup teardown (const a) + where + setup = liftIO $ swapCurrentDirectory projdir + + teardown odir = liftIO $ do + setCurrentDirectory odir + void $ takeMVar cwdLock runGmOutT :: IOish m => Options -> GmOutT m a -> m a runGmOutT opts ma = do diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 40a8a83..51d4c3c 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -347,8 +347,6 @@ data GhcModError | GMETooManyCabalFiles [FilePath] -- ^ Too many cabal files found. - | GMEWrongWorkingDirectory FilePath FilePath - deriving (Eq,Show,Typeable) instance Error GhcModError where diff --git a/elisp/ghc.el b/elisp/ghc.el index 82c4fe5..ec14a81 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.4.0.0") +(defconst ghc-version "5.5.0.0") (defgroup ghc-mod '() "ghc-mod customization") diff --git a/ghc-mod.cabal b/ghc-mod.cabal index dea4938..fec548d 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,8 +1,9 @@ Name: ghc-mod -Version: 5.4.0.0 +Version: 5.5.0.0 Author: Kazu Yamamoto , Daniel Gröber , - Alejandro Serrano + Alejandro Serrano , + Nikolay Yakimov Maintainer: Daniel Gröber License: AGPL-3 License-File: LICENSE @@ -206,7 +207,6 @@ Executable ghc-mod Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base < 5 && >= 4.0 - , async < 2.1 , directory < 1.3 , filepath < 1.5 , pretty < 1.2 @@ -214,6 +214,7 @@ Executable ghc-mod , split < 0.3 , mtl < 2.3 && >= 2.0 , ghc < 7.11 + , monad-control ==1.0.* , fclabels ==2.0.* , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod @@ -222,7 +223,6 @@ Executable ghc-modi Default-Language: Haskell2010 Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod - Misc Utils GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) @@ -257,7 +257,7 @@ Test-Suite spec DataKinds, KindSignatures, TypeOperators, ViewPatterns Main-Is: Main.hs Hs-Source-Dirs: test, ., src - Ghc-Options: -Wall -fno-warn-deprecations + Ghc-Options: -Wall -fno-warn-deprecations -threaded CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 Other-Modules: Paths_ghc_mod diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 09c5036..40340fc 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -11,6 +11,7 @@ import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb) import System.FilePath (()) import System.Directory (setCurrentDirectory, getAppUserDataDirectory, removeDirectoryRecursive) @@ -20,8 +21,6 @@ import Text.PrettyPrint hiding ((<>)) import GHCMod.Options import Prelude -import Misc - ghcModStyle :: Style ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } @@ -49,17 +48,14 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $ -- ghc-modi legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do - opt <- options prepareCabalHelper tmpdir <- cradleTempDir <$> cradle - gmo <- gmoAsk - symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir + asyncSymbolDb <- newAsyncSymbolDb tmpdir world <- getCurrentWorld - legacyInteractiveLoop symdbreq world + legacyInteractiveLoop asyncSymbolDb world -legacyInteractiveLoop :: IOish m - => SymDbReq -> World -> GhcModT m () -legacyInteractiveLoop symdbreq world = do +legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m () +legacyInteractiveLoop asyncSymbolDb world = do liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle -- blocking @@ -80,12 +76,12 @@ legacyInteractiveLoop symdbreq world = do $ parseArgsInteractive cmdArg case pargs of CmdFind symbol -> - lookupSymbol symbol =<< checkDb symdbreq =<< getDb symdbreq + lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb -- other commands are handled here x -> ghcCommands x gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) - legacyInteractiveLoop symdbreq world' + legacyInteractiveLoop asyncSymbolDb world' where interactiveHandlers = [ GHandler $ \(e :: ExitCode) -> throw e diff --git a/src/GHCMod/Options/ShellParse.hs b/src/GHCMod/Options/ShellParse.hs index 5799906..acd609b 100644 --- a/src/GHCMod/Options/ShellParse.hs +++ b/src/GHCMod/Options/ShellParse.hs @@ -16,35 +16,20 @@ module GHCMod.Options.ShellParse (parseCmdLine) where import Data.Char -import Data.Maybe +import Data.List -isQuote :: Char -> Bool -isQuote = (==) '"' - -isEscapeChar :: Char -> Bool -isEscapeChar = (==) '\\' - -isEscapable :: Char -> Bool -isEscapable c = any ($ c) [isSpace, isQuote, isEscapeChar] - -go :: String -> String -> [String] -> Maybe Char -> [String] +go :: String -> String -> [String] -> Bool -> [String] -- result go [] curarg accargs _ = reverse $ reverse curarg : accargs --- escaped character -go (esc:c:cl) curarg accargs quote - | isEscapeChar esc - = if isEscapable c - then go cl (c:curarg) accargs quote - else go (c:cl) (esc:curarg) accargs quote go (c:cl) curarg accargs quotes - -- quote character -- opens quotes - | isQuote c, isNothing quotes - = go cl curarg accargs (Just c) + -- open quotes + | c == '\STX', not quotes + = go cl curarg accargs True -- close quotes - | quotes == Just c - = go cl curarg accargs Nothing - -- space separates argumetns outside quotes - | isSpace c, isNothing quotes + | c == '\ETX', quotes + = go cl curarg accargs False + -- space separates arguments outside quotes + | isSpace c, not quotes = if null curarg then go cl curarg accargs quotes else go cl [] (reverse curarg : accargs) quotes @@ -52,4 +37,8 @@ go (c:cl) curarg accargs quotes | otherwise = go cl (c:curarg) accargs quotes parseCmdLine :: String -> [String] -parseCmdLine comline = go comline [] [] Nothing +parseCmdLine comline' + | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline' + = go (dropWhile isSpace comline) [] [] False +parseCmdLine [] = [""] +parseCmdLine comline = words comline diff --git a/src/Misc.hs b/src/Misc.hs deleted file mode 100644 index 98e8f39..0000000 --- a/src/Misc.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Misc ( - SymDbReq - , newSymDbReq - , getDb - , checkDb - ) where - -import Control.Concurrent.Async (Async, async, wait) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Prelude - -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad - ----------------------------------------------------------------- - -type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) -data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) - -newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq -newSymDbReq opt gmo tmpdir = do - let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir - req <- async act - ref <- newIORef req - return $ SymDbReq ref act - -getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb -getDb (SymDbReq ref _) = do - req <- liftIO $ readIORef ref - -- 'wait' really waits for the asynchronous action at the fist time. - -- Then it reads a cached value from the second time. - hoistGhcModT =<< liftIO (wait req) - -checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb -checkDb (SymDbReq ref act) db = do - outdated <- isOutdated db - if outdated then do - -- async and wait here is unnecessary because this is essentially - -- synchronous. But Async can be used a cache. - req <- liftIO $ async act - liftIO $ writeIORef ref req - hoistGhcModT =<< liftIO (wait req) - else - return db diff --git a/stack.yaml b/stack.yaml index 6d9769e..fdcb756 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,5 +2,5 @@ flags: {} packages: - '.' extra-deps: -- cabal-helper-0.6.1.0 -resolver: lts-3.1 +- cabal-helper-0.6.2.0 +resolver: lts-3.20 diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs index 5e60f55..171dd7d 100644 --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -3,6 +3,8 @@ module MonadSpec where import Test.Hspec import TestUtils import Control.Monad.Error.Class +import Control.Concurrent +import Control.Exception spec :: Spec spec = do @@ -15,3 +17,21 @@ spec = do return "hello" `catchError` (const $ fail "oh noes") a `shouldBe` (Left $ GMEString "oh noes") + + describe "runGhcModT" $ + it "throws an exception when run in multiple threads" $ do + mv1 :: MVar (Either SomeException ()) + <- newEmptyMVar + mv2 :: MVar (Either SomeException ()) + <- newEmptyMVar + + _ <- forkOS $ putMVar mv1 =<< (try $ evaluate =<< (runD $ liftIO $ readMVar mv2 >> return ())) + _ <- forkOS $ putMVar mv2 =<< (try $ evaluate =<< (runD $ return ())) + e1 <- takeMVar mv1 + e2 <- takeMVar mv2 + + (isLeft e1 || isLeft e2) `shouldBe` True + +isLeft :: Either a b -> Bool +isLeft (Right _) = False +isLeft (Left _) = True diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 3d02f43..2c5cefe 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -8,29 +8,27 @@ import Test.Hspec spec :: Spec spec = describe "parseCmdLine" $ do - it "splits arguments" $ + it "splits arguments" $ do parseCmdLine "test command line" `shouldBe` ["test", "command", "line"] - it "honors double quotes" $ - parseCmdLine "test command line \"with double quotes\"" - `shouldBe` ["test", "command", "line", "with double quotes"] - it "escapes spaces" $ do - parseCmdLine "with\\ spaces" - `shouldBe` ["with spaces"] - parseCmdLine "\"with\\ spaces\"" - `shouldBe` ["with spaces"] - it "escapes '\\'" $ do - parseCmdLine "\\\\" - `shouldBe` ["\\"] - parseCmdLine "\"\\\\\"" - `shouldBe` ["\\"] - it "escapes double quotes" $ do - parseCmdLine "\\\"" - `shouldBe` ["\""] - parseCmdLine "\"\\\"\"" - `shouldBe` ["\""] - it "doesn't escape random characters" $ - parseCmdLine "\\a\\b\\c" - `shouldBe` ["\\a\\b\\c"] - it "squashes multiple spaces" $ + parseCmdLine "ascii-escape test command line" `shouldBe` ["test", "command", "line"] + it "honors quoted segments if turned on" $ + parseCmdLine "ascii-escape test command line \STXwith quoted segment\ETX" + `shouldBe` ["test", "command", "line", "with quoted segment"] + it "doesn't honor quoted segments if turned off" $ + parseCmdLine "test command line \STXwith quoted segment\ETX" + `shouldBe` words "test command line \STXwith quoted segment\ETX" + it "squashes multiple spaces" $ do parseCmdLine "test command" `shouldBe` ["test", "command"] + parseCmdLine "ascii-escape test command" + `shouldBe` ["test", "command"] + it "ingores leading spaces" $ do + parseCmdLine " test command" + `shouldBe` ["test", "command"] + parseCmdLine " ascii-escape test command" + `shouldBe` ["test", "command"] + it "parses empty string as no argument" $ do + parseCmdLine "" + `shouldBe` [""] + parseCmdLine "ascii-escape " + `shouldBe` [""] diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 9251b9b..9ce67b5 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -45,20 +45,7 @@ extract action = do withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a withSpecCradle cradledir f = do - gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) $ \arg@(crdl,_) -> - bracketWorkingDirectory (cradleRootDir crdl) $ - f arg - -bracketWorkingDirectory :: - (ExceptionMonad m, MonadIO m) => FilePath -> m c -> m c -bracketWorkingDirectory dir a = - gbracket (swapWorkingDirectory dir) (liftIO . setCurrentDirectory) (const a) - -swapWorkingDirectory :: MonadIO m => FilePath -> m FilePath -swapWorkingDirectory ndir = liftIO $ do - odir <- getCurrentDirectory >>= canonicalizePath - setCurrentDirectory $ ndir - return odir + gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do