Merge branch 'release-5.5.0.0'
This commit is contained in:
commit
84fa5f89cf
@ -104,11 +104,6 @@ gmeDoc e = case e of
|
|||||||
GMETooManyCabalFiles cfs ->
|
GMETooManyCabalFiles cfs ->
|
||||||
text $ "Multiple cabal files found. Possible cabal files: \""
|
text $ "Multiple cabal files found. Possible cabal files: \""
|
||||||
++ intercalate "\", \"" cfs ++"\"."
|
++ 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 :: GhcException -> Doc
|
||||||
ghcExceptionDoc e@(CmdLineError _) =
|
ghcExceptionDoc e@(CmdLineError _) =
|
||||||
|
@ -10,34 +10,42 @@ module Language.Haskell.GhcMod.Find
|
|||||||
, findSymbol
|
, findSymbol
|
||||||
, lookupSym
|
, lookupSym
|
||||||
, isOutdated
|
, isOutdated
|
||||||
|
-- * Load 'SymbolDb' asynchronously
|
||||||
|
, AsyncSymbolDb
|
||||||
|
, newAsyncSymbolDb
|
||||||
|
, getAsyncSymbolDb
|
||||||
)
|
)
|
||||||
#endif
|
#endif
|
||||||
where
|
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.Convert
|
||||||
import Language.Haskell.GhcMod.Gap (listVisibleModules)
|
import Language.Haskell.GhcMod.Gap
|
||||||
import Language.Haskell.GhcMod.Monad
|
import Language.Haskell.GhcMod.Monad
|
||||||
|
import Language.Haskell.GhcMod.Output
|
||||||
import Language.Haskell.GhcMod.PathsAndFiles
|
import Language.Haskell.GhcMod.PathsAndFiles
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
import Language.Haskell.GhcMod.Utils
|
import Language.Haskell.GhcMod.Utils
|
||||||
import Language.Haskell.GhcMod.World (timedPackageCaches)
|
import Language.Haskell.GhcMod.World
|
||||||
import Language.Haskell.GhcMod.Output
|
|
||||||
import Name (getOccString)
|
import qualified GHC as G
|
||||||
import Module (moduleName)
|
import Name
|
||||||
import System.Directory (doesFileExist)
|
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.Directory.ModTime
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import System.IO
|
import System.IO
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Data.Map (Map)
|
|
||||||
import qualified Data.Map as M
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
-- | Type of function and operation names.
|
-- | Type of function and operation names.
|
||||||
@ -147,3 +155,39 @@ collectModules :: [(Symbol, ModuleString)]
|
|||||||
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
||||||
where
|
where
|
||||||
tieup x = (head (map fst x), map snd x)
|
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
|
||||||
|
@ -50,6 +50,7 @@ import Control.Monad.Trans.Journal (runJournalT)
|
|||||||
import Exception
|
import Exception
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
import System.IO.Unsafe
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
|
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
|
||||||
@ -58,23 +59,32 @@ withGhcModEnv = withGhcModEnv' withCradle
|
|||||||
withCradle dir =
|
withCradle dir =
|
||||||
gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
|
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' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
|
||||||
withGhcModEnv' withCradle dir opts f =
|
withGhcModEnv' withCradle dir opts f =
|
||||||
withCradle dir $ \(crdl,lg) ->
|
withCradle dir $ \(crdl,lg) ->
|
||||||
withCradleRootDir crdl $
|
withCradleRootDir crdl $
|
||||||
f (GhcModEnv opts crdl, lg)
|
f (GhcModEnv opts crdl, lg)
|
||||||
where
|
where
|
||||||
withCradleRootDir (cradleRootDir -> projdir) a = do
|
swapCurrentDirectory ndir = do
|
||||||
cdir <- liftIO $ getCurrentDirectory
|
odir <- canonicalizePath =<< getCurrentDirectory
|
||||||
eq <- liftIO $ pathsEqual projdir cdir
|
setCurrentDirectory ndir
|
||||||
if not eq
|
return odir
|
||||||
then throw $ GMEWrongWorkingDirectory projdir cdir
|
|
||||||
else a
|
|
||||||
|
|
||||||
pathsEqual a b = do
|
withCradleRootDir (cradleRootDir -> projdir) a = do
|
||||||
ca <- canonicalizePath a
|
success <- liftIO $ tryPutMVar cwdLock =<< myThreadId
|
||||||
cb <- canonicalizePath b
|
if not success
|
||||||
return $ ca == cb
|
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 :: IOish m => Options -> GmOutT m a -> m a
|
||||||
runGmOutT opts ma = do
|
runGmOutT opts ma = do
|
||||||
|
@ -347,8 +347,6 @@ data GhcModError
|
|||||||
| GMETooManyCabalFiles [FilePath]
|
| GMETooManyCabalFiles [FilePath]
|
||||||
-- ^ Too many cabal files found.
|
-- ^ Too many cabal files found.
|
||||||
|
|
||||||
| GMEWrongWorkingDirectory FilePath FilePath
|
|
||||||
|
|
||||||
deriving (Eq,Show,Typeable)
|
deriving (Eq,Show,Typeable)
|
||||||
|
|
||||||
instance Error GhcModError where
|
instance Error GhcModError where
|
||||||
|
@ -28,7 +28,7 @@
|
|||||||
(< emacs-minor-version minor)))
|
(< emacs-minor-version minor)))
|
||||||
(error "ghc-mod requires at least Emacs %d.%d" major 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")
|
(defgroup ghc-mod '() "ghc-mod customization")
|
||||||
|
|
||||||
|
@ -1,8 +1,9 @@
|
|||||||
Name: ghc-mod
|
Name: ghc-mod
|
||||||
Version: 5.4.0.0
|
Version: 5.5.0.0
|
||||||
Author: Kazu Yamamoto <kazu@iij.ad.jp>,
|
Author: Kazu Yamamoto <kazu@iij.ad.jp>,
|
||||||
Daniel Gröber <dxld@darkboxed.org>,
|
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>
|
Maintainer: Daniel Gröber <dxld@darkboxed.org>
|
||||||
License: AGPL-3
|
License: AGPL-3
|
||||||
License-File: LICENSE
|
License-File: LICENSE
|
||||||
@ -206,7 +207,6 @@ Executable ghc-mod
|
|||||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||||
HS-Source-Dirs: src
|
HS-Source-Dirs: src
|
||||||
Build-Depends: base < 5 && >= 4.0
|
Build-Depends: base < 5 && >= 4.0
|
||||||
, async < 2.1
|
|
||||||
, directory < 1.3
|
, directory < 1.3
|
||||||
, filepath < 1.5
|
, filepath < 1.5
|
||||||
, pretty < 1.2
|
, pretty < 1.2
|
||||||
@ -214,6 +214,7 @@ Executable ghc-mod
|
|||||||
, split < 0.3
|
, split < 0.3
|
||||||
, mtl < 2.3 && >= 2.0
|
, mtl < 2.3 && >= 2.0
|
||||||
, ghc < 7.11
|
, ghc < 7.11
|
||||||
|
, monad-control ==1.0.*
|
||||||
, fclabels ==2.0.*
|
, fclabels ==2.0.*
|
||||||
, optparse-applicative >=0.11.0 && <0.13.0
|
, optparse-applicative >=0.11.0 && <0.13.0
|
||||||
, ghc-mod
|
, ghc-mod
|
||||||
@ -222,7 +223,6 @@ Executable ghc-modi
|
|||||||
Default-Language: Haskell2010
|
Default-Language: Haskell2010
|
||||||
Main-Is: GHCModi.hs
|
Main-Is: GHCModi.hs
|
||||||
Other-Modules: Paths_ghc_mod
|
Other-Modules: Paths_ghc_mod
|
||||||
Misc
|
|
||||||
Utils
|
Utils
|
||||||
GHC-Options: -Wall -threaded -fno-warn-deprecations
|
GHC-Options: -Wall -threaded -fno-warn-deprecations
|
||||||
if os(windows)
|
if os(windows)
|
||||||
@ -257,7 +257,7 @@ Test-Suite spec
|
|||||||
DataKinds, KindSignatures, TypeOperators, ViewPatterns
|
DataKinds, KindSignatures, TypeOperators, ViewPatterns
|
||||||
Main-Is: Main.hs
|
Main-Is: Main.hs
|
||||||
Hs-Source-Dirs: test, ., src
|
Hs-Source-Dirs: test, ., src
|
||||||
Ghc-Options: -Wall -fno-warn-deprecations
|
Ghc-Options: -Wall -fno-warn-deprecations -threaded
|
||||||
CPP-Options: -DSPEC=1
|
CPP-Options: -DSPEC=1
|
||||||
Type: exitcode-stdio-1.0
|
Type: exitcode-stdio-1.0
|
||||||
Other-Modules: Paths_ghc_mod
|
Other-Modules: Paths_ghc_mod
|
||||||
|
@ -11,6 +11,7 @@ import Language.Haskell.GhcMod
|
|||||||
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
import Language.Haskell.GhcMod.Monad
|
import Language.Haskell.GhcMod.Monad
|
||||||
|
import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb)
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
||||||
removeDirectoryRecursive)
|
removeDirectoryRecursive)
|
||||||
@ -20,8 +21,6 @@ import Text.PrettyPrint hiding ((<>))
|
|||||||
import GHCMod.Options
|
import GHCMod.Options
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Misc
|
|
||||||
|
|
||||||
ghcModStyle :: Style
|
ghcModStyle :: Style
|
||||||
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
|
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
|
||||||
|
|
||||||
@ -49,17 +48,14 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $
|
|||||||
-- ghc-modi
|
-- ghc-modi
|
||||||
legacyInteractive :: IOish m => GhcModT m ()
|
legacyInteractive :: IOish m => GhcModT m ()
|
||||||
legacyInteractive = do
|
legacyInteractive = do
|
||||||
opt <- options
|
|
||||||
prepareCabalHelper
|
prepareCabalHelper
|
||||||
tmpdir <- cradleTempDir <$> cradle
|
tmpdir <- cradleTempDir <$> cradle
|
||||||
gmo <- gmoAsk
|
asyncSymbolDb <- newAsyncSymbolDb tmpdir
|
||||||
symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir
|
|
||||||
world <- getCurrentWorld
|
world <- getCurrentWorld
|
||||||
legacyInteractiveLoop symdbreq world
|
legacyInteractiveLoop asyncSymbolDb world
|
||||||
|
|
||||||
legacyInteractiveLoop :: IOish m
|
legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()
|
||||||
=> SymDbReq -> World -> GhcModT m ()
|
legacyInteractiveLoop asyncSymbolDb world = do
|
||||||
legacyInteractiveLoop symdbreq world = do
|
|
||||||
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
|
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
|
||||||
|
|
||||||
-- blocking
|
-- blocking
|
||||||
@ -80,12 +76,12 @@ legacyInteractiveLoop symdbreq world = do
|
|||||||
$ parseArgsInteractive cmdArg
|
$ parseArgsInteractive cmdArg
|
||||||
case pargs of
|
case pargs of
|
||||||
CmdFind symbol ->
|
CmdFind symbol ->
|
||||||
lookupSymbol symbol =<< checkDb symdbreq =<< getDb symdbreq
|
lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb
|
||||||
-- other commands are handled here
|
-- other commands are handled here
|
||||||
x -> ghcCommands x
|
x -> ghcCommands x
|
||||||
|
|
||||||
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
|
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
|
||||||
legacyInteractiveLoop symdbreq world'
|
legacyInteractiveLoop asyncSymbolDb world'
|
||||||
where
|
where
|
||||||
interactiveHandlers =
|
interactiveHandlers =
|
||||||
[ GHandler $ \(e :: ExitCode) -> throw e
|
[ GHandler $ \(e :: ExitCode) -> throw e
|
||||||
|
@ -16,35 +16,20 @@
|
|||||||
module GHCMod.Options.ShellParse (parseCmdLine) where
|
module GHCMod.Options.ShellParse (parseCmdLine) where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Maybe
|
import Data.List
|
||||||
|
|
||||||
isQuote :: Char -> Bool
|
go :: String -> String -> [String] -> Bool -> [String]
|
||||||
isQuote = (==) '"'
|
|
||||||
|
|
||||||
isEscapeChar :: Char -> Bool
|
|
||||||
isEscapeChar = (==) '\\'
|
|
||||||
|
|
||||||
isEscapable :: Char -> Bool
|
|
||||||
isEscapable c = any ($ c) [isSpace, isQuote, isEscapeChar]
|
|
||||||
|
|
||||||
go :: String -> String -> [String] -> Maybe Char -> [String]
|
|
||||||
-- result
|
-- result
|
||||||
go [] curarg accargs _ = reverse $ reverse curarg : accargs
|
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
|
go (c:cl) curarg accargs quotes
|
||||||
-- quote character -- opens quotes
|
-- open quotes
|
||||||
| isQuote c, isNothing quotes
|
| c == '\STX', not quotes
|
||||||
= go cl curarg accargs (Just c)
|
= go cl curarg accargs True
|
||||||
-- close quotes
|
-- close quotes
|
||||||
| quotes == Just c
|
| c == '\ETX', quotes
|
||||||
= go cl curarg accargs Nothing
|
= go cl curarg accargs False
|
||||||
-- space separates argumetns outside quotes
|
-- space separates arguments outside quotes
|
||||||
| isSpace c, isNothing quotes
|
| isSpace c, not quotes
|
||||||
= if null curarg
|
= if null curarg
|
||||||
then go cl curarg accargs quotes
|
then go cl curarg accargs quotes
|
||||||
else go cl [] (reverse 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
|
| otherwise = go cl (c:curarg) accargs quotes
|
||||||
|
|
||||||
parseCmdLine :: String -> [String]
|
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
|
||||||
|
48
src/Misc.hs
48
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
|
|
@ -2,5 +2,5 @@ flags: {}
|
|||||||
packages:
|
packages:
|
||||||
- '.'
|
- '.'
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- cabal-helper-0.6.1.0
|
- cabal-helper-0.6.2.0
|
||||||
resolver: lts-3.1
|
resolver: lts-3.20
|
||||||
|
@ -3,6 +3,8 @@ module MonadSpec where
|
|||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import TestUtils
|
import TestUtils
|
||||||
import Control.Monad.Error.Class
|
import Control.Monad.Error.Class
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Exception
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
@ -15,3 +17,21 @@ spec = do
|
|||||||
return "hello"
|
return "hello"
|
||||||
`catchError` (const $ fail "oh noes")
|
`catchError` (const $ fail "oh noes")
|
||||||
a `shouldBe` (Left $ GMEString "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
|
||||||
|
@ -8,29 +8,27 @@ import Test.Hspec
|
|||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec =
|
spec =
|
||||||
describe "parseCmdLine" $ do
|
describe "parseCmdLine" $ do
|
||||||
it "splits arguments" $
|
it "splits arguments" $ do
|
||||||
parseCmdLine "test command line" `shouldBe` ["test", "command", "line"]
|
parseCmdLine "test command line" `shouldBe` ["test", "command", "line"]
|
||||||
it "honors double quotes" $
|
parseCmdLine "ascii-escape test command line" `shouldBe` ["test", "command", "line"]
|
||||||
parseCmdLine "test command line \"with double quotes\""
|
it "honors quoted segments if turned on" $
|
||||||
`shouldBe` ["test", "command", "line", "with double quotes"]
|
parseCmdLine "ascii-escape test command line \STXwith quoted segment\ETX"
|
||||||
it "escapes spaces" $ do
|
`shouldBe` ["test", "command", "line", "with quoted segment"]
|
||||||
parseCmdLine "with\\ spaces"
|
it "doesn't honor quoted segments if turned off" $
|
||||||
`shouldBe` ["with spaces"]
|
parseCmdLine "test command line \STXwith quoted segment\ETX"
|
||||||
parseCmdLine "\"with\\ spaces\""
|
`shouldBe` words "test command line \STXwith quoted segment\ETX"
|
||||||
`shouldBe` ["with spaces"]
|
it "squashes multiple spaces" $ do
|
||||||
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 "test command"
|
parseCmdLine "test command"
|
||||||
`shouldBe` ["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` [""]
|
||||||
|
@ -45,20 +45,7 @@ extract action = do
|
|||||||
|
|
||||||
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
|
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
|
||||||
withSpecCradle cradledir f = do
|
withSpecCradle cradledir f = do
|
||||||
gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) $ \arg@(crdl,_) ->
|
gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f
|
||||||
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
|
|
||||||
|
|
||||||
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
|
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
|
||||||
runGhcModTSpec opt action = do
|
runGhcModTSpec opt action = do
|
||||||
|
Loading…
Reference in New Issue
Block a user