From 7bbaa35f5665b2be4964c83cf292043bc09bed54 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Mon, 4 Jan 2016 19:05:15 +0100
Subject: [PATCH] Reinstate cwd setup, this time with locking

---
 Language/Haskell/GhcMod/Monad.hs | 32 +++++++++++++++++++++-----------
 ghc-mod.cabal                    |  2 +-
 test/MonadSpec.hs                | 20 ++++++++++++++++++++
 test/TestUtils.hs                | 15 +--------------
 4 files changed, 43 insertions(+), 26 deletions(-)

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/ghc-mod.cabal b/ghc-mod.cabal
index 1b12725..c35b952 100644
--- a/ghc-mod.cabal
+++ b/ghc-mod.cabal
@@ -256,7 +256,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/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/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