Merge branch 'release-5.5.0.0'

This commit is contained in:
Daniel Gröber 2016-01-08 16:01:47 +01:00
commit 84fa5f89cf
13 changed files with 150 additions and 161 deletions

View File

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

View File

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

View File

@ -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
@ -58,23 +59,32 @@ withGhcModEnv = withGhcModEnv' withCradle
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

View File

@ -347,8 +347,6 @@ data GhcModError
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
| GMEWrongWorkingDirectory FilePath FilePath
deriving (Eq,Show,Typeable)
instance Error GhcModError where

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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