Merge branch 'release-5.5.0.0'

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 _) =

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

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

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

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")
 

ghc-mod.cabal

@@ -1,8 +1,9 @@
 Name:                   ghc-mod
-Version:                5.4.0.0
+Version:                5.5.0.0
 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,
                         Daniel Gröber <dxld@darkboxed.org>,
-                        Alejandro Serrano <trupill@gmail.com>
+                        Alejandro Serrano <trupill@gmail.com>,
+                        Nikolay Yakimov <root@livid.pp.ru>
 Maintainer:             Daniel Gröber <dxld@darkboxed.org>
 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

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

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

src/Misc.hs

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

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

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

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` [""]

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