packages feed

hsdev 0.1.5.4 → 0.1.5.5

raw patch · 7 files changed

+90/−105 lines, 7 files

Files

hsdev.cabal view
@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.5.4
+version:             0.1.5.5
 synopsis:            Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc.
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
src/Control/Concurrent/Util.hs view
@@ -1,37 +1,15 @@ module Control.Concurrent.Util (
-	fork, race, timeout, withSync, withSync_
+	fork, timeout
 	) where
 
 import Control.Concurrent
-import Control.Exception
+import Control.Concurrent.Async
 import Control.Monad
 import Control.Monad.IO.Class
 
 fork :: (MonadIO m, Functor m) => IO () -> m ()
 fork = liftIO . void . forkIO
 
-race :: [IO a] -> IO a
-race acts = do
-	var <- newEmptyMVar
-	ids <- forM acts $ \a -> forkIO ((a >>= putMVar var) `catch` ignoreError)
-	r <- takeMVar var
-	forM_ ids killThread
-	return r
-	where
-		ignoreError :: SomeException -> IO ()
-		ignoreError _ = return ()
-
 timeout :: Int -> IO a -> IO (Maybe a)
-timeout 0 act = fmap Just act
-timeout tm act = race [
-	fmap Just act,
-	threadDelay tm >> return Nothing]
-
-withSync :: a -> ((a -> IO ()) -> IO b) -> IO a
-withSync v act = do
-	sync <- newEmptyMVar
-	void $ forkIO $ void $ act (putMVar sync) `onException` putMVar sync v
-	takeMVar sync
-
-withSync_ :: (IO () -> IO a) -> IO ()
-withSync_ act = withSync () $ \sync -> act (sync ())
+timeout 0 act = liftM Just act
+timeout tm act = liftM (either Just (const Nothing)) $ race act (threadDelay tm)
src/HsDev/Database/Async.hs view
@@ -26,4 +26,5 @@ wait db = liftIO $ do
 	waitVar <- newEmptyMVar
 	modifyAsync db (Action $ \d -> putMVar waitVar () >> return d)
+	-- FIXME: what if async process is dead?
 	takeMVar waitVar
src/HsDev/Inspect.hs view
@@ -68,8 +68,11 @@ 		_moduleName = fromString mname, 		_moduleDocs = Nothing, 		_moduleLocation = ModuleSource Nothing,-		_moduleExports = Nothing,-		_moduleImports = [],+		_moduleExports = do+			H.PragmasAndModuleHead _ (_, _, mexports) <- parseModuleHead' source'+			exports <- mexports+			return $ concatMap getExports exports,+		_moduleImports = map getImport $ mapMaybe (uncurry parseImport') parts, 		_moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts } 	where 		parts :: [(Int, String)]@@ -87,12 +90,22 @@ 			g 1  		parseDecl' :: Int -> String -> Maybe H.Decl-		parseDecl' offset cts = fmap (transformBi addOffset) $ case H.parseDeclWithMode (parseMode file exts) cts of-			H.ParseFailed _ _ -> Nothing-			H.ParseOk decl' -> Just decl'-			where-				addOffset :: H.SrcLoc -> H.SrcLoc-				addOffset src = src { H.srcLine = H.srcLine src + offset }+		parseDecl' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $+			H.parseDeclWithMode (parseMode file exts) cts++		parseImport' :: Int -> String -> Maybe H.ImportDecl+		parseImport' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $+			H.parseImportDeclWithMode (parseMode file exts) cts++		parseModuleHead' :: String -> Maybe H.PragmasAndModuleHead+		parseModuleHead' = maybeResult . fmap H.unNonGreedy . H.parseWithMode (parseMode file exts)++		maybeResult :: H.ParseResult a -> Maybe a+		maybeResult (H.ParseFailed _ _) = Nothing+		maybeResult (H.ParseOk r) = Just r++		addOffset :: Int -> H.SrcLoc -> H.SrcLoc+		addOffset offset src = src { H.srcLine = H.srcLine src + offset }  		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces 		source' = map untab source
src/HsDev/Server/Base.hs view
@@ -50,10 +50,6 @@ initLog :: ServerOpts -> IO (Log, Log.Level -> String -> IO (), ([String] -> IO ()) -> IO (), IO ())
 initLog sopts = do
 	msgs <- F.newChan
-	outputDone <- newEmptyMVar
-	void $ forkIO $ finally
-		(F.readChan msgs >>= mapM_ (const $ return ()))
-		(putMVar outputDone ())
 	l <- newLog (constant [rule']) $ concat [
 		[logger text console],
 		[logger text (chaner msgs)],
@@ -63,7 +59,7 @@ 		listenLog f = logException "listen log" (F.putChan msgs) $ do
 			msgs' <- F.dupChan msgs
 			F.readChan msgs' >>= f
-	return (l, \lev -> writeLog l lev . T.pack, listenLog, stopLog l >> F.closeChan msgs >> takeMVar outputDone)
+	return (l, \lev -> writeLog l lev . T.pack, listenLog, stopLog l)
 	where
 		rule' :: Log.Rule
 		rule' = parseRule_ $ T.pack ("/: " ++ serverLogConfig sopts)
src/HsDev/Server/Commands.hs view
@@ -82,7 +82,7 @@ 				parseData cts = case eitherDecode cts of
 					Left err -> putStrLn ("Invalid data: " ++ err) >> exitFailure
 					Right v -> return v
-			dat <- traverse parseData input
+			dat <- traverse parseData input -- FIXME: Not used!
 
 			s <- socket AF_INET Stream defaultProtocol
 			addr' <- inet_addr "127.0.0.1"
@@ -102,7 +102,7 @@ 				r' <- unMmap r
 				case r' of
 					Left n -> onNotification n >> peekResponse h
-					Right r -> return r
+					Right res -> return res
 
 runServerCommand :: ServerCommand -> IO ()
 runServerCommand Version = putStrLn $cabalVersion
@@ -156,45 +156,46 @@ #endif
 runServerCommand (Run sopts) = runServer sopts $ \copts -> do
 	commandLog copts Log.Info $ "Server started at port " ++ show (serverPort sopts)
-
-	waitListen <- newEmptyMVar
 	clientChan <- F.newChan
-
-	void $ forkIO $ do
-		accepter <- myThreadId
-
+	listenerSem <- newQSem 0
+	_ <- async $ Log.scopeLog (commandLogger copts) "listener" $ flip finally (signalQSem listenerSem) $ do
 		let
 			serverStop :: IO ()
-			serverStop = void $ forkIO $ do
-				void $ tryPutMVar waitListen ()
-				killThread accepter
+			serverStop = void $ do
+				commandLog copts Log.Trace "stopping server"
+				-- NOTE: killing listener doesn't work on Windows, because accept blocks async exceptions
+				signalQSem listenerSem
 
 		s <- socket AF_INET Stream defaultProtocol
 		bind s $ SockAddrInet (fromIntegral $ serverPort sopts) iNADDR_ANY
 		listen s maxListenQueue
-		forever $ logAsync (commandLog copts Log.Fatal) $ logIO "accept client exception: " (commandLog copts Log.Error) $ do
+		forever $ logAsync (commandLog copts Log.Fatal) $ logIO "exception: " (commandLog copts Log.Error) $ do
+			commandLog copts Log.Trace "accepting connection"
 			s' <- fst <$> accept s
-			void $ forkIO $ logAsync (commandLog copts Log.Fatal) $ logIO (show s' ++ " exception: ") (commandLog copts Log.Error) $
-				flip finally (close s') $
-					bracket newEmptyMVar (`putMVar` ()) $ \done -> do
-						me <- myThreadId
-						let
-							timeoutWait = do
-								notDone <- isEmptyMVar done
-								when notDone $ do
-									void $ forkIO $ do
-										threadDelay 1000000
-										void $ tryPutMVar done ()
-										killThread me
-									takeMVar done
-							-- waitForever = forever $ hGetLineBS h
-						F.putChan clientChan timeoutWait
-						processClientSocket s' (copts {
-							-- commandHold = waitForever,
-							commandExit = serverStop })
+			commandLog copts Log.Trace $ "accepted " ++ show s'
+			void $ forkIO $ Log.scopeLog (commandLogger copts) (T.pack $ show s') $
+				logAsync (commandLog copts Log.Fatal) $ logIO ("exception: ") (commandLog copts Log.Error) $
+					flip finally (close s') $
+						bracket newEmptyMVar (`putMVar` ()) $ \done -> do
+							me <- myThreadId
+							let
+								timeoutWait = do
+									notDone <- isEmptyMVar done
+									when notDone $ do
+										commandLog copts Log.Trace $ "waiting for " ++ show s' ++ " to complete"
+										waitAsync <- async $ do
+											threadDelay 1000000
+											killThread me
+										void $ waitCatch waitAsync
+							F.putChan clientChan timeoutWait
+							processClientSocket s' (copts {
+								commandExit = serverStop })
 
-	takeMVar waitListen
+	commandLog copts Log.Trace "waiting for accept thread"
+	waitQSem listenerSem
+	commandLog copts Log.Trace "accept thread stopped"
 	DB.readAsync (commandDatabase copts) >>= writeCache sopts (commandLog copts)
+	commandLog copts Log.Trace "waiting for clients"
 	F.stopChan clientChan >>= sequence_
 	commandLog copts Log.Info "server stopped"
 runServerCommand (Stop copts) = runServerCommand (Remote copts False Exit)
@@ -267,7 +268,8 @@ 				ellipsis s
 					| length s < 100 = s
 					| otherwise = take 100 s ++ "..."
-	flip finally (disconnected linkVar) $ forever $ Log.scopeLog (commandLogger copts) (T.pack name) $ do
+	-- flip finally (disconnected linkVar) $ forever $ Log.scopeLog (commandLogger copts) (T.pack name) $ do
+	flip finally (disconnected linkVar) $ forever $ do
 		req' <- receive
 		commandLog copts Log.Trace $ " => " ++ fromUtf8 req'
 		case eitherDecode req' of
@@ -308,6 +310,7 @@ #endif
 		mmap' _ = return
 
+		-- Call on disconnected, either no action or exit command
 		disconnected :: MVar (IO ()) -> IO ()
 		disconnected var = do
 			commandLog copts Log.Info $ name ++ " disconnected"
@@ -352,14 +355,15 @@ mmap :: Pool -> Response -> IO Response
 mmap mmapPool r
 	| L.length msg <= 1024 = return r
-	| otherwise = withSync (responseError "timeout" []) $ \sync -> timeout 10000000 $
-		withName mmapPool $ \mmapName -> do
-			runExceptT $ flip catchError
-				(\e -> liftIO $ sync $ responseError e [])
-				(withMapFile mmapName (L.toStrict msg) $ liftIO $ do
-					sync $ result $ MmapFile mmapName
-					-- give 10 seconds for client to read data
-					threadDelay 10000000)
+	| otherwise = do
+		rvar <- newEmptyMVar
+		_ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ flip catchError
+			(\e -> liftIO $ void $ tryPutMVar rvar r)
+			(withMapFile mmapName (L.toStrict msg) $ liftIO $ do
+				_ <- tryPutMVar rvar $ result $ MmapFile mmapName
+				-- give 10 seconds for client to read data
+				threadDelay 10000000)
+		takeMVar rvar
 	where
 		msg = encode r
 #endif
src/System/Win32/FileMapping/Memory.hs view
@@ -3,7 +3,7 @@ 	withMapFile, readMapFile
 	) where
 
-import Control.Arrow (left)
+import Control.Concurrent
 import Control.Monad.Catch
 import Control.Monad.Cont
 import Control.Monad.Except
@@ -15,27 +15,25 @@ import System.Win32.Types
 import System.Win32.Mem
 
-createMap :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> ContT r IO HANDLE
-createMap mh pf sz mn = ContT $ bracket
-	(verify iNVALID_HANDLE_VALUE "Invalid handle" $
-		createFileMapping mh pf sz mn)
+createMap :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> ExceptT String (ContT r IO) HANDLE
+createMap mh pf sz mn = verify (/= iNVALID_HANDLE_VALUE) "Invalid handle" $ ContT $ bracket
+	(createFileMapping mh pf sz mn)
 	closeHandle
 
-openMap :: FileMapAccess -> Bool -> Maybe String -> ContT r IO HANDLE
-openMap f i mn = ContT $ bracket
-	(verify iNVALID_HANDLE_VALUE "Invalid handle" $
-		openFileMapping f i mn)
+openMap :: FileMapAccess -> Bool -> Maybe String -> ExceptT String (ContT r IO) HANDLE
+openMap f i mn = verify (/= iNVALID_HANDLE_VALUE) "Invalid handle" $ ContT $ bracket
+	(openFileMapping f i mn)
 	closeHandle
 
-mapFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> IO (Ptr a)
-mapFile h f off sz = verify nullPtr "null pointer" $ mapViewOfFile h f off sz
+mapFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> ExceptT String IO (Ptr a)
+mapFile h f off sz = verify (/= nullPtr) "null pointer" $ mapViewOfFile h f off sz
 
 -- | Write data to named map view of file
 withMapFile :: String -> ByteString -> IO a -> ExceptT String IO a
-withMapFile name str act = liftE $ flip runContT return $ do
-	p <- ContT $ BS.useAsCString str
+withMapFile name str act = mapExceptT (`runContT` return) $ do
+	p <- lift $ ContT $ BS.useAsCString str
 	h <- createMap Nothing pAGE_READWRITE (fromIntegral len) (Just name)
-	ptr <- lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
+	ptr <- mapExceptT lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
 	liftIO $ do
 		copyMemory ptr p (fromIntegral len)
 		unmapViewOfFile ptr
@@ -45,17 +43,12 @@ 
 -- | Read data from named map view of file
 readMapFile :: String -> ExceptT String IO ByteString
-readMapFile name = liftE $ flip runContT return $ do
+readMapFile name = mapExceptT (`runContT` return) $ do
 	h <- openMap fILE_MAP_ALL_ACCESS True (Just name)
-	ptr <- lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
+	ptr <- mapExceptT lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
 	liftIO $ BS.packCString ptr
 
-verify :: Eq a => a -> String -> IO a -> IO a
-verify v str act = do
-	x <- act
-	if x == v
-		then ioError (userError str)
-		else return x
-
-liftE :: MonadCatch m => m a -> ExceptT String m a
-liftE = ExceptT . liftM (left (\(SomeException e) -> show e)) . try
+verify :: (Eq a, Monad m) => (a -> Bool) -> String -> m a -> ExceptT String m a
+verify p str act = do
+	x <- lift act
+	if p x then return x else throwError str