hsdev 0.1.6.3 → 0.1.6.4

raw patch · 13 files changed

+841/−581 lines, 13 files

Files

• hsdev.cabal +1/−1
• src/Control/Concurrent/FiniteChan.hs +43/−8
• src/Control/Concurrent/Worker.hs +36/−18
• src/Data/Lisp.hs +1/−1
• src/HsDev/Client/Commands.hs +169/−151
• src/HsDev/Database/Update.hs +92/−84
• src/HsDev/Database/Update/Types.hs +61/−66
• src/HsDev/Server/Base.hs +48/−42
• src/HsDev/Server/Commands.hs +165/−129
• src/HsDev/Server/Message.hs +12/−8
• src/HsDev/Server/Types.hs +192/−65
• src/HsDev/Tools/Ghc/Check.hs +2/−0
• src/HsDev/Util.hs +19/−8

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.6.3
+version:             0.1.6.4
 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.

@@ -1,37 +1,72 @@ module Control.Concurrent.FiniteChan (
 	Chan,
-	newChan, dupChan, putChan, getChan, readChan, closeChan, stopChan
+	newChan, dupChan, openedChan, closedChan, doneChan, sendChan, putChan, getChan, readChan, closeChan, stopChan
 	) where
 
+import Control.Monad (void, when, liftM2)
 import qualified Control.Concurrent.Chan as C
+import Control.Concurrent.MVar
 import Data.Maybe
 
+data State = Opened | Closing | Closed deriving (Eq, Ord, Enum, Bounded, Read, Show)
+
 -- | 'Chan' is stoppable channel unline 'Control.Concurrent.Chan'
-newtype Chan a = Chan (C.Chan (Maybe a))
+data Chan a = Chan (C.Chan (Maybe a)) (MVar State)
 
 -- | Create channel
 newChan :: IO (Chan a)
-newChan = fmap Chan C.newChan
+newChan = liftM2 Chan C.newChan (newMVar Opened)
 
 -- | Duplicate channel
 dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan ch) = fmap Chan $ C.dupChan ch
+dupChan (Chan ch st) = liftM2 Chan (C.dupChan ch) (return st)
 
+-- | Is channel opened
+openedChan :: Chan a -> IO Bool
+openedChan (Chan _ st) = (== Opened) <$> readMVar st
+
+-- | Is channel closing/closed
+closedChan :: Chan a -> IO Bool
+closedChan (Chan _ st) = (/= Opened) <$> readMVar st
+
+-- | Is channed closed and all data allready read from it
+doneChan :: Chan a -> IO Bool
+doneChan (Chan _ st) = (== Closed) <$> readMVar st
+
 -- | Write data to channel
+sendChan :: Chan a -> a -> IO Bool
+sendChan (Chan ch st) v = do
+	state <- readMVar st
+	if state == Opened
+		then do
+			C.writeChan ch (Just v)
+			return True
+		else return False
+
+-- | Put data to channel
 putChan :: Chan a -> a -> IO ()
-putChan (Chan ch) = C.writeChan ch . Just
+putChan ch = void . sendChan ch
 
 -- | Get data from channel
 getChan :: Chan a -> IO (Maybe a)
-getChan (Chan ch) = C.readChan ch
+getChan (Chan ch st) = do
+	state <- readMVar st
+	if state == Closed then return Nothing else do
+		r <- C.readChan ch
+		when (isNothing r) (void $ swapMVar st Closed)
+		return r
 
 -- | Read channel contents
 readChan :: Chan a -> IO [a]
-readChan (Chan ch) = fmap (catMaybes . takeWhile isJust) $ C.getChanContents ch
+readChan (Chan ch _) = (catMaybes . takeWhile isJust) <$> C.getChanContents ch
 
 -- | Close channel. 'putChan' will still work, but no data will be available on other ending
 closeChan :: Chan a -> IO ()
-closeChan (Chan ch) = C.writeChan ch Nothing
+closeChan (Chan ch st) = do
+	state <- readMVar st
+	when (state == Opened) $ do
+		_ <- swapMVar st Closing
+		C.writeChan ch Nothing
 
 -- | Stop channel and return all data
 stopChan :: Chan a -> IO [a]

@@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-}
 
 module Control.Concurrent.Worker (
-	Worker(..),
-	startWorker,
+	Worker(..), WorkerStopped(..),
+	startWorker, workerDone,
 	sendTask, pushTask,
-	stopWorker, syncTask,
+	restartWorker, stopWorker, syncTask,
 	inWorkerWith, inWorker, inWorker_,
 
 	module Control.Concurrent.Async
@@ -15,6 +15,7 @@ import Control.Monad.Catch
 import Control.Monad.Except
 import Data.Maybe (isJust)
+import Data.Typeable
 
 import Control.Concurrent.FiniteChan
 import Control.Concurrent.Async
@@ -23,40 +24,57 @@ 	workerChan :: Chan (Async (), m ()),
 	workerWrap :: forall a. m a -> m a,
 	workerTask :: MVar (Async ()),
-	workerRestart :: IO Bool }
+	workerTouch :: IO () }
 
+data WorkerStopped = WorkerStopped deriving (Show, Typeable)
+
+instance Exception WorkerStopped
+
 -- | Create new worker
 startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (forall a. m a -> m a) -> IO (Worker m)
 startWorker run initialize wrap = do
 	ch <- newChan
 	taskVar <- newEmptyMVar
 	let
-		start = async $ do
-			run $ initialize processWork
-			processSkip
-		processWork = whileJust (liftM (fmap snd) $ liftIO $ getChan ch) id
-		processSkip = whileJust (liftM (fmap fst) $ getChan ch) cancel
-		whileJust :: Monad m => m (Maybe a) -> (a -> m b) -> m  ()
-		whileJust v act = v >>= maybe (return ()) (\x -> act x >> whileJust v act)
+		start = async $ run $ initialize go
+		go = do
+			t <- fmap snd <$> liftIO (getChan ch)
+			maybe (return ()) (>> go) t
 	start >>= putMVar taskVar
 	let
 		restart = do
-			task <- readMVar taskVar
-			stopped <- liftM isJust $ poll task
-			when stopped (start >>= void . swapMVar taskVar)
-			return stopped
+			done <- doneChan ch
+			unless done $ do
+				task <- readMVar taskVar
+				stopped <- isJust <$> poll task
+				when stopped (start >>= void . swapMVar taskVar)
 	return $ Worker ch wrap taskVar restart
 
+workerDone :: MonadIO m => Worker m -> IO Bool
+workerDone = doneChan . workerChan
+
 sendTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a)
 sendTask w act = mfix $ \async' -> do
 	var <- newEmptyMVar
 	let
-		act' = (workerWrap w act >>= liftIO . putMVar var . Right) `catch` (liftIO . putMVar var . Left)
-		f = putChan (workerChan w) (void async', void act') >> takeMVar var >>= either (throwM :: SomeException -> IO a) return
+		act' = (workerWrap w act >>= liftIO . putMVar var . Right) `catch` onError
+		onError :: (MonadCatch m, MonadIO m) => SomeException -> m ()
+		onError = liftIO . putMVar var . Left
+		f = do
+			p <- sendChan (workerChan w) (void async', void act')
+			unless p $ putMVar var (Left $ SomeException WorkerStopped)
+			r <- takeMVar var
+			either throwM return r
 	async f
 
 pushTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a)
-pushTask w act = workerRestart w >> sendTask w act
+pushTask w act = workerTouch w >> sendTask w act
+
+restartWorker :: Worker m -> IO ()
+restartWorker w = do
+	async' <- readMVar (workerTask w)
+	cancel async'
+	void $ waitCatch async'
 
 stopWorker :: Worker m -> IO ()
 stopWorker = closeChan . workerChan

@@ -57,7 +57,7 @@ 
 		string :: R.ReadP P.String
 		string = (R.<++ R.pfail) $ do
-			('"':_) <- R.look
+			('\"':_) <- R.look
 			readable n
 
 		number :: R.ReadP Scientific

@@ -1,14 +1,16 @@-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
 
 module HsDev.Client.Commands (
-	runCommand
+	runClient, runCommand
 	) where
 
 import Control.Applicative
 import Control.Arrow
+import Control.Exception (displayException)
 import Control.Lens (view, preview, _Just)
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.Reader
 import Control.Monad.State (gets)
 import Control.Monad.Catch (try, SomeException(..))
 import Data.Aeson hiding (Result, Error)
@@ -19,12 +21,14 @@ import Data.String (fromString)
 import Data.Text (unpack)
 import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf)
+import Data.Text.Lens (packed)
 import System.Directory
 import System.FilePath
-import qualified System.Log.Simple.Base as Log
+import qualified System.Log.Simple as Log
 import Text.Regex.PCRE ((=~))
 
 import System.Directory.Paths
+import Text.Format
 import HsDev.Cache
 import HsDev.Commands
 import qualified HsDev.Database.Async as DB
@@ -46,68 +50,73 @@ 
 import qualified HsDev.Database.Update as Update
 
-runCommandM :: ToJSON a => CommandM a -> IO Result
-runCommandM = liftM toResult . runExceptT where
-	toResult (Left (CommandError e ds)) = Error e $ M.fromList $ map (first unpack) ds
-	toResult (Right r') = Result $ toJSON r'
+runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result
+runClient copts = mapServerM toResult . runClientM where
+	toResult :: (ToJSON a, ServerMonadBase m) => ExceptT CommandError (ReaderT CommandOptions m) a -> m Result
+	toResult act = liftM asResult $ runReaderT (runExceptT act) copts
+	asResult :: ToJSON a => Either CommandError a -> Result
+	asResult (Left (CommandError e ds)) = Error e $ M.fromList $ map (first unpack) ds
+	asResult (Right r') = Result $ toJSON r'
+	mapServerM :: (Monad m, Monad n) => (m a -> n b) -> ServerM m a -> ServerM n b
+	mapServerM f = ServerM . mapReaderT f . runServerM
 
--- | Run command
-runCommand :: CommandOptions -> Command -> IO Result
-runCommand _ Ping = runCommandM $ return $ object ["message" .= ("pong" :: String)]
-runCommand copts Listen = runCommandM $ liftIO $ commandListenLog copts $
-	mapM_ (\msg -> commandNotify copts (Notification $ object ["message" .= msg]))
-runCommand copts (AddData cts) = runCommandM $ mapM_ updateData cts where
-	updateData (AddedDatabase db) = DB.update (dbVar copts) $ return db
-	updateData (AddedModule m) = DB.update (dbVar copts) $ return $ fromModule m
-	updateData (AddedProject p) = DB.update (dbVar copts) $ return $ fromProject p
-runCommand copts (Scan projs cabals fs paths' fcts ghcs' docs' infer') = runCommandM $ do
-	sboxes <- getSandboxes copts cabals
-	updateProcess copts ghcs' docs' infer' $ concat [
+toValue :: (ToJSON a, Monad m) => m a -> m Value
+toValue = liftM toJSON
+
+runCommand :: ServerMonadBase m => Command -> ClientM m Value
+runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]
+runCommand Listen = toValue $ do
+	serverListen >>= mapM_ (\msg -> commandNotify (Notification $ object ["message" .= msg]))
+runCommand (AddData cts) = toValue $ mapM_ updateData cts where
+	updateData (AddedDatabase db) = toValue $ serverUpdateDB db
+	updateData (AddedModule m) = toValue $ serverUpdateDB $ fromModule m
+	updateData (AddedProject p) = toValue $ serverUpdateDB $ fromProject p
+runCommand (Scan projs cabals fs paths' fcts ghcs' docs' infer') = toValue $ do
+	sboxes <- getSandboxes cabals
+	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
 		map (\(FileContents f cts) -> Update.scanFileContents ghcs' f (Just cts)) fcts,
 		map (Update.scanProject ghcs') projs,
 		map (Update.scanFile ghcs') fs,
 		map (Update.scanDirectory ghcs') paths',
 		map (Update.scanCabal ghcs') sboxes]
-runCommand copts (RefineDocs projs fs ms) = runCommandM $ do
-	projects <- traverse (findProject copts) projs
-	dbval <- getDb copts
+runCommand (RefineDocs projs fs ms) = toValue $ do
+	projects <- traverse findProject projs
+	dbval <- getDb
 	let
 		filters = anyOf $ concat [
 			map inProject projects,
 			map inFile fs,
 			map inModule ms]
 		mods = selectModules (filters . view moduleId) dbval
-	updateProcess copts [] False False [Update.scanDocs $ map (getInspected dbval) mods]
-runCommand copts (InferTypes projs fs ms) = runCommandM $ do
-	projects <- traverse (findProject copts) projs
-	dbval <- getDb copts
+	updateProcess (Update.UpdateOptions [] [] False False) [Update.scanDocs $ map (getInspected dbval) mods]
+runCommand (InferTypes projs fs ms) = toValue $ do
+	projects <- traverse findProject projs
+	dbval <- getDb
 	let
 		filters = anyOf $ concat [
 			map inProject projects,
 			map inFile fs,
 			map inModule ms]
 		mods = selectModules (filters . view moduleId) dbval
-	updateProcess copts [] False False [Update.inferModTypes $ map (getInspected dbval) mods]
-runCommand _ (Remove _ _ _ _) = runCommandM $ return $ object ["message" .= ("not implemented" :: String)]
-runCommand copts (InfoModules fs) = runCommandM $ do
-	dbval <- getDb copts
-	filter' <- targetFilters copts fs
+	updateProcess (Update.UpdateOptions [] [] False False) [Update.inferModTypes $ map (getInspected dbval) mods]
+runCommand (Remove _ _ _ _) = toValue $ return $ object ["message" .= ("not implemented" :: String)]
+runCommand (InfoModules fs) = toValue $ do
+	dbval <- getDb
+	filter' <- targetFilters fs
 	return $ map (view moduleId) $ newestPackage $ selectModules (filter' . view moduleId) dbval
-runCommand copts InfoPackages = runCommandM $
-	(ordNub . sort . 	mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules) <$> getDb copts
-runCommand copts InfoProjects = runCommandM $ (toList . databaseProjects) <$> getDb copts
-runCommand copts InfoSandboxes = runCommandM $
-	(ordNub . sort . mapMaybe (cabalOf . view moduleId) . allModules) <$> getDb copts
-runCommand copts (InfoSymbol sq fs locals') = runCommandM $ do
-	dbval <- liftM (localsDatabase locals') $ getDb copts
-	filter' <- targetFilters copts fs
+runCommand InfoPackages = toValue $ (ordNub . sort . 	mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules) <$> getDb
+runCommand InfoProjects = toValue $ (toList . databaseProjects) <$> getDb
+runCommand InfoSandboxes = toValue $ (ordNub . sort . mapMaybe (cabalOf . view moduleId) . allModules) <$> getDb
+runCommand (InfoSymbol sq fs locals') = toValue $ do
+	dbval <- liftM (localsDatabase locals') $ getDb
+	filter' <- targetFilters fs
 	return $ newestPackage $ filterMatch sq $ filter (checkModule filter') $ allDeclarations dbval
-runCommand copts (InfoModule sq fs) = runCommandM $ do
-	dbval <- getDb copts
-	filter' <- targetFilters copts fs
+runCommand (InfoModule sq fs) = toValue $ do
+	dbval <- getDb
+	filter' <- targetFilters fs
 	return $ newestPackage $ filterMatch sq $ filter (filter' . view moduleId) $ allModules dbval
-runCommand copts (InfoResolve fpath exports) = runCommandM $ do
-	dbval <- getDb copts
+runCommand (InfoResolve fpath exports) = toValue $ do
+	dbval <- getDb
 	cabal <- liftIO $ getSandbox fpath
 	let
 		cabaldb = filterDB (restrictCabal cabal) (const True) dbval
@@ -117,54 +126,58 @@ 	case lookupFile fpath dbval of
 		Nothing -> commandError "File not found" []
 		Just m -> return $ getScope $ resolveOne cabaldb m
-runCommand copts (InfoProject (Left projName)) = runCommandM $ findProject copts projName
-runCommand _ (InfoProject (Right projPath)) = runCommandM $ liftIO $ searchProject projPath
-runCommand _ (InfoSandbox sandbox') = runCommandM $ liftIO $ searchSandbox sandbox'
-runCommand copts (Lookup nm fpath) = runCommandM $ do
-	dbval <- getDb copts
+runCommand (InfoProject (Left projName)) = toValue $ findProject projName
+runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject projPath
+runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandbox sandbox'
+runCommand (Lookup nm fpath) = toValue $ do
+	dbval <- getDb
 	cabal <- liftIO $ getSandbox fpath
-	mapCommandErrorStr $ lookupSymbol dbval cabal fpath nm
-runCommand copts (Whois nm fpath) = runCommandM $ do
-	dbval <- getDb copts
+	mapCommandIO $ lookupSymbol dbval cabal fpath nm
+runCommand (Whois nm fpath) = toValue $ do
+	dbval <- getDb
 	cabal <- liftIO $ getSandbox fpath
-	mapCommandErrorStr $ whois dbval cabal fpath nm
-runCommand copts (ResolveScopeModules sq fpath) = runCommandM $ do
-	dbval <- getDb copts
+	mapCommandIO $ whois dbval cabal fpath nm
+runCommand (ResolveScopeModules sq fpath) = toValue $ do
+	dbval <- getDb
 	cabal <- liftIO $ getSandbox fpath
-	liftM (filterMatch sq . map (view moduleId)) $ mapCommandErrorStr $ scopeModules dbval cabal fpath
-runCommand copts (ResolveScope sq global fpath) = runCommandM $ do
-	dbval <- getDb copts
+	liftM (filterMatch sq . map (view moduleId)) $ mapCommandIO $ scopeModules dbval cabal fpath
+runCommand (ResolveScope sq global fpath) = toValue $ do
+	dbval <- getDb
 	cabal <- liftIO $ getSandbox fpath
-	liftM (filterMatch sq) $ mapCommandErrorStr $ scope dbval cabal fpath global
-runCommand copts (Complete input wide fpath) = runCommandM $ do
-	dbval <- getDb copts
+	liftM (filterMatch sq) $ mapCommandIO $ scope dbval cabal fpath global
+runCommand (Complete input wide fpath) = toValue $ do
+	dbval <- getDb
 	cabal <- liftIO $ getSandbox fpath
-	mapCommandErrorStr $ completions dbval cabal fpath input wide
-runCommand _ (Hayoo hq p ps) = runCommandM $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
+	mapCommandIO $ completions dbval cabal fpath input wide
+runCommand (Hayoo hq p ps) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
 	(mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $
-	mapCommandErrorStr $ Hayoo.hayoo hq (Just i)
-runCommand _ (CabalList packages) = runCommandM $ mapCommandErrorStr $ Cabal.cabalList packages
-runCommand _ (Lint fs fcts) = runCommandM $ do
-	mapCommandErrorStr $ liftM2 (++)
+	mapCommandIO $ Hayoo.hayoo hq (Just i)
+runCommand (CabalList packages) = toValue $ mapCommandIO $ Cabal.cabalList packages
+runCommand (Lint fs fcts) = toValue $ do
+	mapCommandIO $ liftM2 (++)
 		(liftM concat $ mapM HLint.hlintFile fs)
 		(liftM concat $ mapM (\(FileContents f c) -> HLint.hlintSource f c) fcts)
-runCommand copts (Check fs fcts ghcs') = runCommandM $ do
-	db <- getDb copts
+runCommand (Check fs fcts ghcs') = toValue $ do
+	db <- getDb
+	ghc <- askSession sessionGhc
+	liftIO $ restartWorker ghc
 	let
 		checkSome file fn = do
 			cabal <- liftIO $ getSandbox file
 			m <- maybe
-				(commandError_ $ "File '" ++ file ++ "' not found")
+				(commandError_ $ "File '{}' not found" ~~ file)
 				return
 				(lookupFile file db)
-			notes <- inWorkerWith (commandError_ . show) (commandGhc copts)
+			notes <- inWorkerWith (commandError_ . show) ghc
 				(runExceptT $ fn cabal m)
 			either commandError_ return notes
 	liftM concat $ mapM (uncurry checkSome) $
 		[(f, Check.checkFile ghcs') | f <- fs] ++
 		[(f, \cabal m -> Check.checkSource ghcs' cabal m src) | FileContents f src <- fcts]
-runCommand copts (CheckLint fs fcts ghcs') = runCommandM $ do
-	db <- getDb copts
+runCommand (CheckLint fs fcts ghcs') = toValue $ do
+	db <- getDb
+	ghc <- askSession sessionGhc
+	liftIO $ restartWorker ghc
 	let
 		checkSome file fn = do
 			cabal <- liftIO $ getSandbox file
@@ -172,18 +185,19 @@ 				(commandError_ $ "File '" ++ file ++ "' not found")
 				return
 				(lookupFile file db)
-			notes <- inWorkerWith (commandError_ . show) (commandGhc copts)
+			notes <- inWorkerWith (commandError_ . show) ghc
 				(runExceptT $ fn cabal m)
 			either commandError_ return notes
 	checkMsgs <- liftM concat $ mapM (uncurry checkSome) $
 		[(f, Check.checkFile ghcs') | f <- fs] ++
 		[(f, \cabal m -> Check.checkSource ghcs' cabal m src) | FileContents f src <- fcts]
-	lintMsgs <- mapCommandErrorStr $ liftM2 (++)
+	lintMsgs <- mapCommandIO $ liftM2 (++)
 		(liftM concat $ mapM HLint.hlintFile fs)
 		(liftM concat $ mapM (\(FileContents f src) -> HLint.hlintSource f src) fcts)
 	return $ checkMsgs ++ lintMsgs
-runCommand copts (Types fs fcts ghcs') = runCommandM $ do
-	db <- getDb copts
+runCommand (Types fs fcts ghcs') = toValue $ do
+	db <- getDb
+	ghc <- askSession sessionGhc
 	let
 		cts = [(f, Nothing) | f <- fs] ++ [(f, Just src) | FileContents f src <- fcts]
 	liftM concat $ forM cts $ \(file, msrc) -> do
@@ -192,42 +206,46 @@ 			(commandError_ $ "File '" ++ file ++ "' not found")
 			return
 			(lookupFile file db)
-		notes <- inWorkerWith (commandError_ . show) (commandGhc copts)
+		notes <- inWorkerWith (commandError_ . show) ghc
 			(runExceptT $ Types.fileTypes ghcs' cabal m msrc)
 		either commandError_ return notes
-runCommand _ (GhcMod GhcModLang) = runCommandM $ mapCommandErrorStr GhcMod.langs
-runCommand _ (GhcMod GhcModFlags) = runCommandM $ mapCommandErrorStr GhcMod.flags
-runCommand copts (GhcMod (GhcModType (Position line column) fpath ghcs')) = runCommandM $ do
-	dbval <- getDb copts
+runCommand (GhcMod GhcModLang) = toValue $ mapCommandIO $ GhcMod.langs
+runCommand (GhcMod GhcModFlags) = toValue $ mapCommandIO $ GhcMod.flags
+runCommand (GhcMod (GhcModType (Position line column) fpath ghcs')) = toValue $ do
+	ghcmod <- askSession sessionGhcMod
+	dbval <- getDb
 	cabal <- liftIO $ getSandbox fpath
-	(fpath', m', _) <- mapCommandErrorStr $ fileCtx dbval fpath
-	mapCommandErrorStr $ GhcMod.waitMultiGhcMod (commandGhcMod copts) fpath' $
+	(fpath', m', _) <- mapCommandIO $ fileCtx dbval fpath
+	mapCommandIO $ GhcMod.waitMultiGhcMod ghcmod fpath' $
 		GhcMod.typeOf (ghcs' ++ moduleOpts (allPackages dbval) m') cabal fpath' line column
-runCommand copts (GhcMod (GhcModLint fs hlints')) = runCommandM $ do
-	mapCommandErrorStr $ liftM concat $ forM fs $ \file ->
-		GhcMod.waitMultiGhcMod (commandGhcMod copts) file $
+runCommand (GhcMod (GhcModLint fs hlints')) = toValue $ do
+	ghcmod <- askSession sessionGhcMod
+	mapCommandIO $ liftM concat $ forM fs $ \file ->
+		GhcMod.waitMultiGhcMod ghcmod file $
 			GhcMod.lint hlints' file
-runCommand copts (GhcMod (GhcModCheck fs ghcs')) = runCommandM $ do
-	dbval <- getDb copts
-	mapCommandErrorStr $ liftM concat $ forM fs $ \file -> do
+runCommand (GhcMod (GhcModCheck fs ghcs')) = toValue $ do
+	ghcmod <- askSession sessionGhcMod
+	dbval <- getDb
+	mapCommandIO $ liftM concat $ forM fs $ \file -> do
 		mproj <- liftIO $ locateProject file
 		cabal <- liftIO $ getSandbox file
 		(_, m', _) <- fileCtx dbval file
-		GhcMod.waitMultiGhcMod (commandGhcMod copts) file $
+		GhcMod.waitMultiGhcMod ghcmod file $
 			GhcMod.check (ghcs' ++ moduleOpts (allPackages dbval) m') cabal [file] mproj
-runCommand copts (GhcMod (GhcModCheckLint fs ghcs' hlints')) = runCommandM $ do
-	dbval <- getDb copts
-	mapCommandErrorStr $ liftM concat $ forM fs $ \file -> do
+runCommand (GhcMod (GhcModCheckLint fs ghcs' hlints')) = toValue $ do
+	ghcmod <- askSession sessionGhcMod
+	dbval <- getDb
+	mapCommandIO $ liftM concat $ forM fs $ \file -> do
 		mproj <- liftIO $ locateProject file
 		cabal <- liftIO $ getSandbox file
 		(_, m', _) <- fileCtx dbval file
-		GhcMod.waitMultiGhcMod (commandGhcMod copts) file $ do
+		GhcMod.waitMultiGhcMod ghcmod file $ do
 			checked <- GhcMod.check (ghcs' ++ moduleOpts (allPackages dbval) m') cabal [file] mproj
 			linted <- GhcMod.lint hlints' file
 			return $ checked ++ linted
-runCommand _ (AutoFix (AutoFixShow ns)) = runCommandM $ return $ AutoFix.corrections ns
-runCommand copts (AutoFix (AutoFixFix ns rest isPure)) = runCommandM $ do
-	files <- liftM (ordNub . sort) $ mapM (findPath copts) $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns
+runCommand (AutoFix (AutoFixShow ns)) = toValue $ return $ AutoFix.corrections ns
+runCommand (AutoFix (AutoFixFix ns rest isPure)) = toValue $ do
+	files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns
 	let
 		doFix :: FilePath -> String -> ([Tools.Note AutoFix.Correction], String)
 		doFix file cts = AutoFix.edit cts fUpCorrs $ do
@@ -244,79 +262,82 @@ 				(corrs', cts') <- liftM (doFix file) $ liftE $ readFileUtf8 file
 				liftE $ writeFileUtf8 file cts'
 				return corrs'
-	mapCommandErrorStr $ liftM concat $ mapM runFix files
-runCommand copts (GhcEval exprs) = runCommandM $ mapCommandErrorStr $ liftM (map toValue) $ liftAsync $
-	pushTask (commandGhci copts) $ mapM (try . evaluate) exprs
+	mapCommandIO $ liftM concat $ mapM runFix files
+runCommand (GhcEval exprs) = toValue $ do
+	ghci <- askSession sessionGhci
+	async' <- liftIO $ pushTask ghci $ mapM (try . evaluate) exprs
+	res <- waitAsync async'
+	return $ map toValue' res
 	where
-		toValue :: Either SomeException String -> Value
-		toValue (Left (SomeException e)) = object ["fail" .= show e]
-		toValue (Right s) = toJSON s
-runCommand copts (Link hold) = runCommandM $ liftIO $ commandLink copts >> when hold (commandHold copts)
-runCommand copts Exit = runCommandM $ liftIO $ commandExit copts
+		waitAsync :: CommandMonad m => Async a -> m a
+		waitAsync a = liftIO (waitCatch a) >>= either (commandError_ . displayException) return
+		toValue' :: ToJSON a => Either SomeException a -> Value
+		toValue' (Left (SomeException e)) = object ["fail" .= show e]
+		toValue' (Right s) = toJSON s
+runCommand (Link hold) = toValue $ commandLink >> when hold commandHold
+runCommand Exit = toValue $ serverExit
 
-targetFilters :: MonadIO m => CommandOptions -> [TargetFilter] -> ExceptT CommandError m (ModuleId -> Bool)
-targetFilters copts fs = do
-	fs_ <- mapM (targetFilter copts) fs
+targetFilters :: CommandMonad m => [TargetFilter] -> m (ModuleId -> Bool)
+targetFilters fs = do
+	fs_ <- mapM targetFilter fs
 	return $ foldr (liftM2 (&&)) (const True) fs_
 
-targetFilter :: MonadIO m => CommandOptions -> TargetFilter -> ExceptT CommandError m (ModuleId -> Bool)
-targetFilter copts f = case f of
-	TargetProject proj -> liftM inProject $ findProject copts proj
+targetFilter :: CommandMonad m => TargetFilter -> m (ModuleId -> Bool)
+targetFilter f = case f of
+	TargetProject proj -> liftM inProject $ findProject proj
 	TargetFile file -> return $ inFile file
 	TargetModule mname -> return $ inModule mname
-	TargetDepsOf dep -> liftM inDeps $ findDep copts dep
-	TargetCabal cabal -> liftM inCabal $ findSandbox copts cabal
+	TargetDepsOf dep -> liftM inDeps $ findDep dep
+	TargetCabal cabal -> liftM inCabal $ findSandbox cabal
 	TargetPackage pack -> return $ inPackage pack
 	TargetSourced -> return byFile
 	TargetStandalone -> return standalone
 
 -- Helper functions
 
-commandStrMsg :: String -> CommandError
-commandStrMsg m = CommandError m []
-
 -- | Find sandbox by path
-findSandbox :: MonadIO m => CommandOptions -> Cabal -> ExceptT CommandError m Cabal
-findSandbox _ Cabal = return Cabal
-findSandbox copts (Sandbox f) = (findPath copts >=> mapCommandErrorStr . liftIO . getSandbox) f
+findSandbox :: CommandMonad m => Cabal -> m Cabal
+findSandbox Cabal = return Cabal
+findSandbox (Sandbox f) = (findPath >=> mapCommandErrorStr . liftIO . getSandbox) f
 
 -- | Canonicalize paths
-findPath :: (MonadIO m, Paths a) => CommandOptions -> a -> ExceptT e m a
-findPath copts = paths findPath' where
-	findPath' :: MonadIO m => FilePath -> ExceptT e m FilePath
-	findPath' f = liftIO $ canonicalizePath (normalise f') where
-		f'
-			| isRelative f = commandRoot copts </> f
-			| otherwise = f
+findPath :: (CommandMonad m, Paths a) => a -> m a
+findPath = paths findPath' where
+	findPath' :: CommandMonad m => FilePath -> m FilePath
+	findPath' f = do
+		r <- commandRoot
+		liftIO $ canonicalizePath (normalise $ if isRelative f then r </> f else f)
 
 -- | Get list of enumerated sandboxes
-getSandboxes :: (MonadIO m, Functor m) => CommandOptions -> [Cabal] -> ExceptT CommandError m [Cabal]
-getSandboxes copts = traverse (findSandbox copts)
+getSandboxes :: (CommandMonad m, Functor m) => [Cabal] -> m [Cabal]
+getSandboxes = traverse findSandbox
 
 -- | Find project by name or path
-findProject :: MonadIO m => CommandOptions -> String -> ExceptT CommandError m Project
-findProject copts proj = do
-	db' <- getDb copts
-	proj' <- liftM addCabal $ findPath copts proj
+findProject :: CommandMonad m => String -> m Project
+findProject proj = do
+	db' <- getDb
+	proj' <- liftM addCabal $ findPath proj
 	let
 		resultProj =
 			refineProject db' (project proj') <|>
 			find ((== proj) . view projectName) (databaseProjects db')
-	maybe (throwError $ commandStrMsg $ "Project " ++ proj ++ " not found") return resultProj
+	maybe (commandError_ $ "Project {} not found" ~~ proj) return resultProj
 	where
 		addCabal p
 			| takeExtension p == ".cabal" = p
 			| otherwise = p </> (takeBaseName p <.> "cabal")
 
 -- | Find dependency: it may be source, project file or project name, also returns sandbox found
-findDep :: MonadIO m => CommandOptions -> String -> ExceptT CommandError m (Project, Maybe FilePath, Cabal)
-findDep copts depName = do
-	depPath <- findPath copts depName
+findDep :: CommandMonad m => String -> m (Project, Maybe FilePath, Cabal)
+findDep depName = do
+	depPath <- findPath depName
 	proj <- msum [
-		mapCommandErrorStr $ do
+		do
 			p <- liftIO (locateProject depPath)
-			maybe (throwError $ "Project " ++ depName ++ " not found") (mapExceptT liftIO . loadProject) p,
-		findProject copts depName]
+			p' <- maybe (commandError_ $ "Project {} not found" ~~ depName) return p
+			r <- liftIO $ runExceptT $ loadProject p'
+			either commandError_ return r,
+		findProject depName]
 	let
 		src
 			| takeExtension depPath == ".hs" = Just depPath
@@ -338,21 +359,18 @@ localsDatabase False = id
 
 -- | Get actual DB state
-getDb :: MonadIO m => CommandOptions -> m Database
-getDb = liftIO . DB.readAsync . commandDatabase
+getDb :: SessionMonad m => m Database
+getDb = askSession sessionDatabase >>= liftIO . DB.readAsync
 
--- | Get DB async var
-dbVar :: CommandOptions -> DB.Async Database
-dbVar = commandDatabase
+mapCommandErrorStr :: CommandMonad m => ExceptT String m a -> m a
+mapCommandErrorStr act = runExceptT act >>= either commandError_ return
 
-mapCommandErrorStr :: (Monad m) => ExceptT String m a -> ExceptT CommandError m a
-mapCommandErrorStr = mapExceptT (liftM $ left commandStrMsg)
+mapCommandIO :: CommandMonad m => ExceptT String IO a -> m a
+mapCommandIO act = liftIO (runExceptT act) >>= either commandError_ return
 
 -- | Run DB update action
-updateProcess :: CommandOptions -> [String] -> Bool -> Bool -> [ExceptT String (Update.UpdateDB IO) ()] -> CommandM ()
-updateProcess copts ghcOpts' docs' infer' acts = lift $ Update.updateDB (Update.settings copts ghcOpts' docs' infer') $ sequence_ [act `catchError` logErr | act <- acts] where
-	logErr :: String -> ExceptT String (Update.UpdateDB IO) ()
-	logErr e = liftIO $ commandLog copts Log.Error e
+updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM m ()] -> ClientM m ()
+updateProcess uopts acts = Update.runUpdate uopts $ sequence_ [act `catchError` (Log.log Log.Error . view (commandErrorMsg . packed)) | act <- acts]
 
 -- | Filter declarations with prefix and infix
 filterMatch :: Symbol a => SearchQuery -> [a] -> [a]

@@ -3,11 +3,13 @@ 
 module HsDev.Database.Update (
 	Status(..), Progress(..), Task(..), isStatus,
-	Settings(..), settings,
+	UpdateOptions(..),
 
-	UpdateDB,
-	updateDB,
+	UpdateM(..),
+	runUpdate,
 
+	UpdateMonad,
+
 	postStatus, waiter, updater, loadCache, getCache, runTask, runTasks,
 	readDB,
 
@@ -24,15 +26,13 @@ 	module Control.Monad.Except
 	) where
 
+import Control.Arrow
 import Control.Concurrent.Lifted (fork)
 import Control.DeepSeq
-import Control.Lens (preview, _Just, view, _1, mapMOf_, each, (^..))
-import Control.Monad.Catch
-import Control.Monad.CatchIO
+import Control.Lens (preview, _Just, view, over, set, _1, mapMOf_, each, (^..), _head)
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Writer
-import Control.Monad.Trans.Control
 import Data.Aeson
 import Data.Aeson.Types
 import Data.Foldable (toList)
@@ -55,20 +55,28 @@ import HsDev.Tools.HDocs
 import qualified HsDev.Scan as S
 import HsDev.Scan.Browse
-import HsDev.Util (liftEIO, isParent, ordNub)
+import HsDev.Util (liftE, isParent, ordNub)
+import HsDev.Server.Types (commandNotify, serverWriteCache, serverReadCache, CommandError(..), commandError_)
+import HsDev.Server.Message
 import HsDev.Database.Update.Types
 import HsDev.Watcher
 import Text.Format
 
+onStatus :: UpdateMonad m => m ()
+onStatus = asks (view updateTasks) >>= commandNotify . Notification . toJSON . reverse
+
+childTask :: UpdateMonad m => Task -> m a -> m a
+childTask t = local (over updateTasks (t:))
+
 isStatus :: Value -> Bool
 isStatus = isJust . parseMaybe (parseJSON :: Value -> Parser Task)
 
--- | Run `UpdateDB` monad
-updateDB :: (MonadBaseControl IO m, MonadCatchIO m) => Settings -> ExceptT String (UpdateDB m) () -> m ()
-updateDB sets act = Log.scopeLog (settingsLogger sets) "update" $ do
-	updatedMods <- execWriterT (runUpdateDB (runExceptT act' >> return ()) `runReaderT` sets)
-	wait $ database sets
-	dbval <- liftIO $ readAsync $ database sets
+runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a
+runUpdate uopts act = Log.scope "update" $ do
+	(r, updatedMods) <- runWriterT (runUpdateM act' `runReaderT` uopts)
+	db <- askSession sessionDatabase
+	wait db
+	dbval <- liftIO $ readAsync db
 	let
 		cabals = ordNub $ mapMaybe (preview moduleCabal) updatedMods
 		projs = ordNub $ mapMaybe (preview $ moduleProject . _Just) updatedMods
@@ -78,74 +86,75 @@ 			map (`cabalDB` dbval) cabals,
 			map (`projectDB` dbval) projs,
 			[standaloneDB dbval | stand]]
-	liftIO $ databaseCacheWriter sets modifiedDb
+	serverWriteCache modifiedDb
+	return r
 	where
 		act' = do
-			mlocs' <- liftM (filter (isJust . preview moduleFile) . snd) $ listen act
-			wait $ database sets
+			(r, mlocs') <- liftM (second $ filter (isJust . preview moduleFile)) $ listen act
+			db <- askSession sessionDatabase
+			wait db
 			let
 				getMods :: (MonadIO m) => m [InspectedModule]
 				getMods = do
-					db' <- liftIO $ readAsync $ database sets
+					db' <- liftIO $ readAsync db
 					return $ filter ((`elem` mlocs') . view inspectedId) $ toList $ databaseModules db'
-			when (updateDocs sets) $ do
+			when (view updateDocs uopts) $ do
 				Log.log Log.Trace "forking inspecting source docs"
 				void $ fork (getMods >>= waiter . mapM_ scanDocs_)
-			when (runInferTypes sets) $ do
+			when (view updateInfer uopts) $ do
 				Log.log Log.Trace "forking inferring types"
 				void $ fork (getMods >>= waiter . mapM_ inferModTypes_)
-		scanDocs_ :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => InspectedModule -> ExceptT String m ()
+			return r
+		scanDocs_ :: UpdateMonad m => InspectedModule -> m ()
 		scanDocs_ im = do
 			im' <- liftExceptT $ S.scanModify (\opts _ -> inspectDocs opts) im
 			updater $ return $ fromModule im'
-		inferModTypes_ :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => InspectedModule -> ExceptT String m ()
+		inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()
 		inferModTypes_ im = do
 			-- TODO: locate sandbox
-			im' <- liftExceptT $ S.scanModify infer' im
+			s <- getSession
+			im' <- liftExceptT $ S.scanModify (infer' s) im
 			updater $ return $ fromModule im'
-		infer' :: [String] -> Cabal -> Module -> ExceptT String IO Module
-		infer' opts cabal m = case preview (moduleLocation . moduleFile) m of
+		infer' :: Session -> [String] -> Cabal -> Module -> ExceptT String IO Module
+		infer' s opts cabal m = case preview (moduleLocation . moduleFile) m of
 			Nothing -> return m
-			Just _ -> inWorkerT (settingsGhcWorker sets) $ inferTypes opts cabal m Nothing
+			Just _ -> inWorkerT (sessionGhc s) $ inferTypes opts cabal m Nothing
 		inWorkerT w = ExceptT . inWorker w . runExceptT 
 
 -- | Post status
-postStatus :: (MonadIO m, MonadReader Settings m) => Task -> m ()
-postStatus s = do
-	on' <- asks onStatus
-	liftIO $ on' [s]
+postStatus :: UpdateMonad m => Task -> m ()
+postStatus t = childTask t onStatus
 
 -- | Wait DB to complete actions
-waiter :: (MonadIO m, MonadReader Settings m) => m () -> m ()
+waiter :: UpdateMonad m => m () -> m ()
 waiter act = do
-	db <- asks database
+	db <- askSession sessionDatabase
 	act
 	wait db
 
 -- | Update task result to database
-updater :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => m Database -> m ()
+updater :: UpdateMonad m => m Database -> m ()
 updater act = do
-	db <- asks database
+	db <- askSession sessionDatabase
 	db' <- act
 	update db $ return $!! db'
 	tell $!! map (view moduleLocation) $ allModules db'
 
 -- | Clear obsolete data from database
-cleaner :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => m Database -> m ()
+cleaner :: UpdateMonad m => m Database -> m ()
 cleaner act = do
-	db <- asks database
+	db <- askSession sessionDatabase
 	db' <- act
 	clear db $ return $!! db'
 
 -- | Get data from cache without updating DB
-loadCache :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => (FilePath -> ExceptT String IO Structured) -> m Database
+loadCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> m Database
 loadCache act = do
-	cacheReader <- asks databaseCacheReader
-	mdat <- liftIO $ cacheReader act
+	mdat <- serverReadCache act
 	return $ fromMaybe mempty mdat
 
 -- | Load data from cache if not loaded yet and wait
-getCache :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => (FilePath -> ExceptT String IO Structured) -> (Database -> Database) -> m Database
+getCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> (Database -> Database) -> m Database
 getCache act check = do
 	dbval <- liftM check readDB
 	if nullDatabase dbval
@@ -157,48 +166,45 @@ 			return dbval
 
 -- | Run one task
-runTask :: (Display t, MonadIO m, NFData a, MonadCatchIO m) => String -> t -> ExceptT String (UpdateDB m) a -> ExceptT String (UpdateDB m) a
+runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a
 runTask action subj act = Log.scope "task" $ do
-	postStatus $ task { taskStatus = StatusWorking }
-	x <- local childTask act
-	x `deepseq` postStatus (task { taskStatus = StatusOk })
+	postStatus $ set taskStatus StatusWorking task
+	x <- childTask task act
+	x `deepseq` postStatus (set taskStatus StatusOk task)
 	return x
 	`catchError`
-	(\e -> postStatus (task { taskStatus = StatusError e }) >> throwError e)
+	(\c@(CommandError e _) -> postStatus (set taskStatus (StatusError e) task) >> throwError c)
 	where
 		task = Task {
-			taskName = action,
-			taskStatus = StatusWorking,
-			taskSubjectType = displayType subj,
-			taskSubjectName = display subj,
-			taskProgress = Nothing }
-		childTask st = st {
-			onStatus = \t -> onStatus st (task : t) }
+			_taskName = action,
+			_taskStatus = StatusWorking,
+			_taskSubjectType = displayType subj,
+			_taskSubjectName = display subj,
+			_taskProgress = Nothing }
 
 -- | Run many tasks with numeration
-runTasks :: Monad m => [ExceptT String (UpdateDB m) ()] -> ExceptT String (UpdateDB m) ()
+runTasks :: UpdateMonad m => [m ()] -> m ()
 runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where
 	total = length ts
 	taskNum n = local setProgress where
-		setProgress st = st {
-			onStatus = \(t:tl) -> onStatus st ((t { taskProgress = Just (Progress n total) }) : tl) }
+		setProgress = set (updateTasks . _head . taskProgress) (Just (Progress n total))
 	noErr v = v `mplus` return ()
 
 -- | Get database value
-readDB :: (MonadIO m, MonadReader Settings m) => m Database
-readDB = asks database >>= liftIO . readAsync
+readDB :: SessionMonad m => m Database
+readDB = askSession sessionDatabase >>= liftIO . readAsync
 
 -- | Scan module
-scanModule :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> ModuleLocation -> Maybe String -> ExceptT String (UpdateDB m) ()
+scanModule :: UpdateMonad m => [String] -> ModuleLocation -> Maybe String -> m ()
 scanModule opts mloc mcts = runTask "scanning" mloc $ Log.scope "module" $ do
-	defs <- asks settingsDefines
+	defs <- askSession sessionDefines
 	im <- liftExceptT $ S.scanModule defs opts mloc mcts
 	updater $ return $ fromModule im
-	_ <- ExceptT $ return $ view inspectionResult im
+	_ <- return $ view inspectionResult im
 	return ()
 
 -- | Scan modules
-scanModules :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> [S.ModuleToScan] -> ExceptT String (UpdateDB m) ()
+scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()
 scanModules opts ms = runTasks $
 	[scanProjectFile opts p >> return () | p <- ps] ++
 	[scanModule (opts ++ mopts) m mcts | (m, mopts, mcts) <- ms]
@@ -208,21 +214,21 @@ 		toProj _ = Nothing
 
 -- | Scan source file
-scanFile :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> FilePath -> ExceptT String (UpdateDB m) ()
+scanFile :: UpdateMonad m => [String] -> FilePath -> m ()
 scanFile opts fpath = scanFileContents opts fpath Nothing
 
 -- | Scan source file with contents
-scanFileContents :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> FilePath -> Maybe String -> ExceptT String (UpdateDB m) ()
+scanFileContents :: UpdateMonad m => [String] -> FilePath -> Maybe String -> m ()
 scanFileContents opts fpath mcts = Log.scope "file" $ do
 	dbval <- readDB
-	fpath' <- liftEIO $ canonicalizePath fpath
-	ex <- liftEIO $ doesFileExist fpath'
+	fpath' <- liftCIO $ canonicalizePath fpath
+	ex <- liftCIO $ doesFileExist fpath'
 	mlocs <- if ex
 		then do
 			mloc <- case lookupFile fpath' dbval of
 				Just m -> return $ view moduleLocation m
 				Nothing -> do
-					mproj <- liftEIO $ locateProject fpath'
+					mproj <- liftCIO $ locateProject fpath'
 					return $ FileModule fpath' mproj
 			return [(mloc, [], mcts)]
 		else return []
@@ -237,7 +243,7 @@ 		inFile f = maybe False (== f) . preview (moduleIdLocation . moduleFile)
 
 -- | Scan cabal modules
-scanCabal :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> Cabal -> ExceptT String (UpdateDB m) ()
+scanCabal :: UpdateMonad m => [String] -> Cabal -> m ()
 scanCabal opts cabalSandbox = runTask "scanning" cabalSandbox $ Log.scope "cabal" $ do
 	watch (\w -> watchSandbox w cabalSandbox opts)
 	mlocs <- liftExceptT $ listModules opts cabalSandbox
@@ -250,11 +256,11 @@ 		setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (T.unpack $ view moduleName m) docs
 
 -- | Scan project file
-scanProjectFile :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> FilePath -> ExceptT String (UpdateDB m) Project
+scanProjectFile :: UpdateMonad m => [String] -> FilePath -> m Project
 scanProjectFile opts cabal = runTask "scanning" cabal $ liftExceptT $ S.scanProjectFile opts cabal
 
 -- | Scan project
-scanProject :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> FilePath -> ExceptT String (UpdateDB m) ()
+scanProject :: UpdateMonad m => [String] -> FilePath -> m ()
 scanProject opts cabal = runTask "scanning" (project cabal) $ Log.scope "project" $ do
 	proj <- scanProjectFile opts cabal
 	watch (\w -> watchProject w proj opts)
@@ -264,7 +270,7 @@ 		updater $ return $ fromProject proj
 
 -- | Scan directory for source files and projects
-scanDirectory :: (MonadIO m, MonadCatch m, MonadCatchIO m) => [String] -> FilePath -> ExceptT String (UpdateDB m) ()
+scanDirectory :: UpdateMonad m => [String] -> FilePath -> m ()
 scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do
 	S.ScanContents standSrcs projSrcs sboxes <- liftExceptT $ S.enumDirectory dir
 	runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs]
@@ -275,7 +281,7 @@ 		inDir = maybe False (dir `isParent`) . preview (moduleIdLocation . moduleFile)
 
 -- | Scan docs for inspected modules
-scanDocs :: (MonadIO m, MonadCatchIO m) => [InspectedModule] -> ExceptT String (UpdateDB m) ()
+scanDocs :: UpdateMonad m => [InspectedModule] -> m ()
 scanDocs ims = do
 	w <- liftIO $ ghcWorker ["-haddock"] (return ())
 	runTasks $ map (scanDocs' w) ims
@@ -287,10 +293,10 @@ 			updater $ return $ fromModule im'
 		inWorkerT w = ExceptT . inWorker w . runExceptT 
 
-inferModTypes :: (MonadIO m, MonadCatchIO m) => [InspectedModule] -> ExceptT String (UpdateDB m) ()
+inferModTypes :: UpdateMonad m => [InspectedModule] -> m ()
 inferModTypes = runTasks . map inferModTypes' where
 	inferModTypes' im = runTask "inferring types" (view inspectedId im) $ Log.scope "docs" $ do
-		w <- asks settingsGhcWorker
+		w <- askSession sessionGhc
 		Log.log Log.Trace $ "Inferring types for {}" ~~ view inspectedId im
 		im' <- liftExceptT $ S.scanModify (\opts cabal m -> inWorkerT w (inferTypes opts cabal m Nothing)) im
 		Log.log Log.Trace $ "Types for {} inferred" ~~ view inspectedId im
@@ -298,7 +304,7 @@ 	inWorkerT w = ExceptT . inWorker w . runExceptT
 
 -- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules.
-scan :: (MonadIO m, MonadCatch m, MonadCatchIO m)
+scan :: UpdateMonad m
 	=> (FilePath -> ExceptT String IO Structured)
 	-- ^ Read data from cache
 	-> (Database -> Database)
@@ -307,9 +313,9 @@ 	-- ^ Actual modules. Other modules will be removed from database
 	-> [String]
 	-- ^ Extra scan options
-	-> ([S.ModuleToScan] -> ExceptT String (UpdateDB m) ())
+	-> ([S.ModuleToScan] -> m ())
 	-- ^ Function to update changed modules
-	-> ExceptT String (UpdateDB m) ()
+	-> m ()
 scan cache' part' mlocs opts act = Log.scope "scan" $ do
 	dbval <- getCache cache' part'
 	let
@@ -318,7 +324,7 @@ 	cleaner $ return obsolete
 	act changed
 
-updateEvent :: (MonadIO m, MonadCatch m, MonadCatchIO m) => Watched -> Event -> ExceptT String (UpdateDB m) ()
+updateEvent :: ServerMonadBase m => Watched -> Event -> UpdateM m ()
 updateEvent (WatchedProject proj projOpts) e
 	| isSource e = do
 		Log.log Log.Info $ "File '{file}' in project {proj} changed"
@@ -353,14 +359,16 @@ 		scanFile opts $ view eventPath e
 	| otherwise = return ()
 
-processEvent :: Settings -> Watched -> Event -> IO ()
-processEvent s w e = updateDB s $ updateEvent w e
+liftExceptT :: CommandMonad m => ExceptT String IO a -> m a
+liftExceptT act = liftIO (runExceptT act) >>= either commandError_ return
 
--- | Lift errors
-liftExceptT :: MonadIO m => ExceptT String IO a -> ExceptT String m a
-liftExceptT = mapExceptT liftIO
+liftCIO ::CommandMonad m => IO a -> m a
+liftCIO = liftExceptT . liftE
 
-watch :: (MonadIO m, MonadReader Settings m) => (Watcher -> IO ()) -> m ()
+processEvent :: UpdateOptions -> Watched -> Event -> ClientM IO ()
+processEvent uopts w e = runUpdate uopts $ updateEvent w e
+
+watch :: SessionMonad m => (Watcher -> IO ()) -> m ()
 watch f = do
-	w <- asks settingsWatcher
+	w <- askSession sessionWatcher
 	liftIO $ f w

@@ -1,32 +1,28 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ConstraintKinds, FlexibleContexts, TemplateHaskell #-}
 
 module HsDev.Database.Update.Types (
-	Status(..), Progress(..), Task(..), Settings(..), settings, UpdateDB(..)
+	Status(..), Progress(..), Task(..), UpdateOptions(..), UpdateM(..), UpdateMonad,
+	taskName, taskStatus, taskSubjectType, taskSubjectName, taskProgress, updateTasks, updateGhcOpts, updateDocs, updateInfer,
+
+	module HsDev.Server.Types
 	) where
 
+import Control.Applicative
+import Control.Lens (makeLenses)
 import Control.Monad.Base
-import Control.Monad.Catch
 import Control.Monad.CatchIO
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Writer
 import Control.Monad.Trans.Control
 import Data.Aeson
+import Data.Default
 import qualified System.Log.Simple as Log
 
-import Control.Concurrent.Worker (Worker)
-import HsDev.Database
-import HsDev.Database.Async hiding (Event)
-import HsDev.Tools.GhcMod (WorkerMap)
-import HsDev.Server.Types (CommandOptions(..))
-import HsDev.Server.Message (Notification(..))
+import HsDev.Server.Types (ServerMonadBase, Session(..), CommandOptions(..), SessionMonad(..), askSession, CommandError, CommandMonad(..), ClientM(..))
 import HsDev.Symbols
 import HsDev.Util ((.::))
-import HsDev.Watcher.Types
 
-import GHC (Ghc)
-
 data Status = StatusWorking | StatusOk | StatusError String
 
 instance ToJSON Status where
@@ -54,19 +50,21 @@ 	parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total")
 
 data Task = Task {
-	taskName :: String,
-	taskStatus :: Status,
-	taskSubjectType :: String,
-	taskSubjectName :: String,
-	taskProgress :: Maybe Progress }
+	_taskName :: String,
+	_taskStatus :: Status,
+	_taskSubjectType :: String,
+	_taskSubjectName :: String,
+	_taskProgress :: Maybe Progress }
 
+makeLenses ''Task
+
 instance ToJSON Task where
 	toJSON t = object [
-		"task" .= taskName t,
-		"status" .= taskStatus t,
-		"type" .= taskSubjectType t,
-		"name" .= taskSubjectName t,
-		"progress" .= taskProgress t]
+		"task" .= _taskName t,
+		"status" .= _taskStatus t,
+		"type" .= _taskSubjectType t,
+		"name" .= _taskSubjectName t,
+		"progress" .= _taskProgress t]
 
 instance FromJSON Task where
 	parseJSON = withObject "task" $ \v -> Task <$>
@@ -76,53 +74,50 @@ 		(v .:: "name") <*>
 		(v .:: "progress")
 
-data Settings = Settings {
-	database :: Async Database,
-	databaseCacheReader :: (FilePath -> ExceptT String IO Structured) -> IO (Maybe Database),
-	databaseCacheWriter :: Database -> IO (),
-	onStatus :: [Task] -> IO (),
-	ghcOptions :: [String],
-	updateDocs :: Bool,
-	runInferTypes :: Bool,
-	settingsGhcWorker :: Worker Ghc,
-	settingsGhcModWorker :: Worker (ReaderT WorkerMap IO),
-	settingsLogger :: Log.Log,
-	settingsWatcher :: Watcher,
-	settingsDefines :: [(String, String)] }
+data UpdateOptions = UpdateOptions {
+	_updateTasks :: [Task],
+	_updateGhcOpts :: [String],
+	_updateDocs :: Bool,
+	_updateInfer :: Bool }
 
-settings :: CommandOptions -> [String] -> Bool -> Bool -> Settings
-settings copts ghcOpts' docs' infer' = Settings
-	(commandDatabase copts)
-	(commandReadCache copts)
-	(commandWriteCache copts)
-	(commandNotify copts . Notification . toJSON)
-	ghcOpts'
-	docs'
-	infer'
-	(commandGhc copts)
-	(commandGhcMod copts)
-	(commandLogger copts)
-	(commandWatcher copts)
-	(commandDefines copts)
+instance Default UpdateOptions where
+	def = UpdateOptions [] [] False False
 
-newtype UpdateDB m a = UpdateDB { runUpdateDB :: ReaderT Settings (WriterT [ModuleLocation] m) a }
-	deriving (Applicative, Monad, MonadIO, MonadCatchIO, MonadThrow, MonadCatch, Functor, MonadReader Settings, MonadWriter [ModuleLocation])
+makeLenses ''UpdateOptions
 
-instance MonadCatchIO m => MonadCatchIO (ExceptT e m) where
-	catch act onError = ExceptT $ Control.Monad.CatchIO.catch (runExceptT act) (runExceptT . onError)
-	block = ExceptT . block . runExceptT
-	unblock = ExceptT . unblock . runExceptT
+type UpdateMonad m = (CommandMonad m, MonadReader UpdateOptions m, MonadWriter [ModuleLocation] m)
 
-instance MonadCatchIO m => Log.MonadLog (UpdateDB m) where
-	askLog = liftM settingsLogger ask
+newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateOptions (WriterT [ModuleLocation] (ClientM m)) a }
+	deriving (Applicative, Monad, MonadIO, MonadCatchIO, Functor, MonadReader UpdateOptions, MonadWriter [ModuleLocation])
 
-instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where
-	askLog = lift Log.askLog
+instance MonadTrans UpdateM where
+	lift = UpdateM . lift . lift . lift
 
-instance MonadBase b m => MonadBase b (UpdateDB m) where
-	liftBase = UpdateDB . liftBase
+instance MonadCatchIO m => Log.MonadLog (UpdateM m) where
+	askLog = UpdateM $ lift $ lift Log.askLog
 
-instance MonadBaseControl b m => MonadBaseControl b (UpdateDB m) where
-	type StM (UpdateDB m) a = StM (ReaderT Settings (WriterT [ModuleLocation] m)) a
-	liftBaseWith f = UpdateDB $ liftBaseWith (\f' -> f (f' . runUpdateDB))
-	restoreM = UpdateDB . restoreM
+instance ServerMonadBase m => SessionMonad (UpdateM m) where
+	getSession = UpdateM $ lift $ lift getSession
+
+instance ServerMonadBase m => CommandMonad (UpdateM m) where
+	getOptions = UpdateM $ lift $ lift getOptions
+
+instance Monad m => MonadError CommandError (UpdateM m) where
+	throwError = UpdateM . lift . lift . throwError
+	catchError act handler = UpdateM $ catchError (runUpdateM act) (runUpdateM . handler)
+
+instance Monad m => Alternative (UpdateM m) where
+	empty = UpdateM empty
+	x <|> y = UpdateM $ runUpdateM x <|> runUpdateM y
+
+instance Monad m => MonadPlus (UpdateM m) where
+	mzero = UpdateM mzero
+	mplus l r = UpdateM $ runUpdateM l `mplus` runUpdateM r
+
+instance MonadBase b m => MonadBase b (UpdateM m) where
+	liftBase = UpdateM . liftBase
+
+instance MonadBaseControl b m => MonadBaseControl b (UpdateM m) where
+	type StM (UpdateM m) a = StM (ReaderT UpdateOptions (WriterT [ModuleLocation] (ClientM m))) a
+	liftBaseWith f = UpdateM $ liftBaseWith (\f' -> f (f' . runUpdateM))
+	restoreM = UpdateM . restoreM

@@ -15,12 +15,15 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
+import Data.Default
 import qualified Data.Map as M
 import Data.Maybe
+import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T (pack, unpack)
 import System.Log.Simple hiding (Level(..), Message(..), Command(..))
 import qualified System.Log.Simple.Base as Log
+import qualified System.Log.Simple as Log
 
 import qualified Control.Concurrent.FiniteChan as F
 import System.Directory.Paths (canonicalize)
@@ -46,9 +49,8 @@ import System.Posix.IO
 #endif
 
-
 -- | Inits log chan and returns functions (print message, wait channel)
-initLog :: ServerOpts -> IO (Log, Log.Level -> String -> IO (), ([String] -> IO ()) -> IO (), IO ())
+initLog :: ServerOpts -> IO (Log, Log.Level -> String -> IO (), IO [String], IO ())
 initLog sopts = do
 	msgs <- F.newChan
 	l <- newLog (constant [rule']) $ concat [
@@ -57,9 +59,7 @@ 		maybeToList $ (logger text . file) <$> serverLog sopts]
 	Log.writeLog l Log.Info ("Log politics: low = {}, high = {}" ~~ logLow ~~ logHigh)
 	let
-		listenLog f = logException "listen log" (F.putChan msgs) $ do
-			msgs' <- F.dupChan msgs
-			F.readChan msgs' >>= f
+		listenLog = F.dupChan msgs >>= F.readChan
 	return (l, \lev -> writeLog l lev . T.pack, listenLog, stopLog l)
 	where
 		rule' :: Log.Rule
@@ -69,8 +69,9 @@ instance FormatBuild Log.Level where
 
 -- | Run server
-runServer :: ServerOpts -> (CommandOptions -> IO ()) -> IO ()
+runServer :: ServerOpts -> ServerM IO () -> IO ()
 runServer sopts act = bracket (initLog sopts) (\(_, _, _, x) -> x) $ \(logger', outputStr, listenLog, waitOutput) -> Log.scopeLog logger' (T.pack "hsdev") $ Watcher.withWatcher $ \watcher -> do
+	waitSem <- newQSem 0
 	db <- DB.newAsync
 	when (serverLoad sopts) $ withCache sopts () $ \cdir -> do
 		outputStr Log.Info $ "Loading cache from " ++ cdir
@@ -86,11 +87,10 @@ 	ghcmodw <- ghcModMultiWorker
 	defs <- getDefines
 	let
-		copts = CommandOptions
+		session = Session
 			db
-			(writeCache sopts outputStr)
-			(readCache sopts outputStr)
-			"."
+			(writeCache sopts)
+			(readCache sopts)
 			outputStr
 			logger'
 			listenLog
@@ -102,55 +102,61 @@ 			ghcw
 			ghciw
 			ghcmodw
-			(const $ return ())
-			(return ())
-			(return ())
-			(return ())
+			(do
+				outputStr Log.Trace "stopping server"
+				signalQSem waitSem)
+			(waitQSem waitSem)
 			defs
-	_ <- forkIO $ Update.onEvent watcher (Update.processEvent $ Update.settings copts [] False False)
-	act copts
+	_ <- forkIO $ Update.onEvent watcher $ \w e -> withSession session $
+		void $ Client.runClient def $ Update.processEvent def w e
+	runReaderT (runServerM act) session
 
-type Server = Worker (ReaderT CommandOptions IO)
+type Server = Worker (ServerM IO)
 
 startServer :: ServerOpts -> IO Server
-startServer sopts = startWorker (runServer sopts . runReaderT) id id
+startServer sopts = startWorker (runServer sopts) id id
 
-inServer :: Server -> Command -> IO Result
-inServer srv c = do
+inServer :: Server -> CommandOptions -> Command -> IO Result
+inServer srv copts c = do
 	c' <- canonicalize c
-	inWorker srv (ReaderT (`Client.runCommand` c'))
+	inWorker srv (Client.runClient copts $ Client.runCommand c')
 
 chaner :: F.Chan String -> Consumer Text
 chaner ch = Consumer withChan where
 	withChan f = f (F.putChan ch . T.unpack)
 
 -- | Perform action on cache
-withCache :: ServerOpts -> a -> (FilePath -> IO a) -> IO a
+withCache :: Monad m => ServerOpts -> a -> (FilePath -> m a) -> m a
 withCache sopts v onCache = case serverCache sopts of
 	Nothing -> return v
 	Just cdir -> onCache cdir
 
-writeCache :: ServerOpts -> (Log.Level -> String -> IO ()) -> Database -> IO ()
-writeCache sopts logMsg' d = withCache sopts () $ \cdir -> do
-	logMsg' Log.Info $ "writing cache to " ++ cdir
-	logIO "cache writing exception: " (logMsg' Log.Error) $ do
+writeCache :: SessionMonad m => ServerOpts -> Database -> m ()
+writeCache sopts db = withCache sopts () $ \cdir -> do
+	Log.log Log.Info $ "writing cache to {}" ~~ cdir
+	logIO "cache writing exception: " (Log.log Log.Error . fromString) $ do
 		let
-			sd = structurize d
-		SC.dump cdir sd
-		forM_ (M.keys (structuredCabals sd)) $ \c -> logMsg' Log.Debug ("cache write: cabal " ++ show c)
-		forM_ (M.keys (structuredProjects sd)) $ \p -> logMsg' Log.Debug ("cache write: project " ++ p)
+			sd = structurize db
+		liftIO $ SC.dump cdir sd
+		forM_ (M.keys (structuredCabals sd)) $ \c -> Log.log Log.Debug ("cache write: cabal {}" ~~ show c)
+		forM_ (M.keys (structuredProjects sd)) $ \p -> Log.log Log.Debug ("cache write: project {}" ~~ p)
 		case allModules (structuredFiles sd) of
 			[] -> return ()
-			ms -> logMsg' Log.Debug $ "cache write: " ++ show (length ms) ++ " files"
-	logMsg' Log.Info $ "cache saved to " ++ cdir
+			ms -> Log.log Log.Debug $ "cache write: {} files" ~~ length ms
+	Log.log Log.Info $ "cache saved to {}" ~~ cdir
 
-readCache :: ServerOpts -> (Log.Level -> String -> IO ()) -> (FilePath -> ExceptT String IO Structured) -> IO (Maybe Database)
-readCache sopts logMsg' act = withCache sopts Nothing $ join . liftM (either cacheErr cacheOk) . runExceptT . act where
-	cacheErr e = logMsg' Log.Error ("Error reading cache: " ++ e) >> return Nothing
-	cacheOk s = do
-		forM_ (M.keys (structuredCabals s)) $ \c -> logMsg' Log.Debug ("cache read: cabal " ++ show c)
-		forM_ (M.keys (structuredProjects s)) $ \p -> logMsg' Log.Debug ("cache read: project " ++ p)
-		case allModules (structuredFiles s) of
-			[] -> return ()
-			ms -> logMsg' Log.Debug $ "cache read: " ++ show (length ms) ++ " files"
-		return $ Just $ merge s
+readCache :: SessionMonad m => ServerOpts -> (FilePath -> ExceptT String IO Structured) -> m (Maybe Database)
+readCache sopts act = do
+	s <- getSession
+	liftIO $ withSession s $ withCache sopts Nothing $ \fpath -> do
+		res <- liftIO $ runExceptT $ act fpath
+		either cacheErr cacheOk res
+	where
+		cacheErr e = Log.log Log.Error ("Error reading cache: {}" ~~ e) >> return Nothing
+		cacheOk s = do
+			forM_ (M.keys (structuredCabals s)) $ \c -> Log.log Log.Debug ("cache read: cabal {}" ~~ show c)
+			forM_ (M.keys (structuredProjects s)) $ \p -> Log.log Log.Debug ("cache read: project {}" ~~ p)
+			case allModules (structuredFiles s) of
+				[] -> return ()
+				ms -> Log.log Log.Debug $ "cache read: {} files" ~~ length ms
+			return $ Just $ merge s

@@ -4,16 +4,20 @@ module HsDev.Server.Commands (
 	ServerCommand(..), ServerOpts(..), ClientOpts(..),
 	Request(..),
+	Msg, isLisp, msg, jsonMsg, lispMsg, encodeMessage, decodeMessage,
 	sendCommand, runServerCommand,
 	findPath,
 	processRequest, processClient, processClientSocket,
 	module HsDev.Server.Types
 	) where
 
+import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.Async
-import Control.Exception
+import Control.Exception (SomeException, handle)
+import Control.Lens (set, traverseOf, view, over, Lens', Lens, _1, _2, _Left)
 import Control.Monad
+import Control.Monad.CatchIO
 import Control.Monad.Except
 import Data.Aeson hiding (Result, Error)
 import Data.Aeson.Encode.Pretty
@@ -22,8 +26,8 @@ import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
 import Data.Maybe
+import Data.String (fromString)
 import qualified Data.Text as T (pack)
-import Data.Traversable (for)
 import Network.Socket hiding (connect)
 import qualified Network.Socket as Net hiding (send)
 import qualified Network.Socket.ByteString as Net (send)
@@ -32,10 +36,11 @@ import System.Exit
 import System.FilePath
 import System.IO
-import qualified System.Log.Simple.Base as Log
+import qualified System.Log.Simple as Log
 
 import Control.Concurrent.Util
 import qualified Control.Concurrent.FiniteChan as F
+import Data.Lisp
 import Text.Format ((~~))
 import System.Directory.Paths
 
@@ -71,8 +76,8 @@ 		sendReceive = do
 			curDir <- getCurrentDirectory
 			input <- if clientStdin copts
-				then liftM Just L.getContents
-				else return $ fmap toUtf8 $ Nothing -- arg "data" copts
+				then Just <$> L.getContents
+				else return $ toUtf8 <$> Nothing -- arg "data" copts
 			let
 				parseData :: L.ByteString -> IO Value
 				parseData cts = case eitherDecode cts of
@@ -80,7 +85,7 @@ 					Right v -> return v
 			_ <- traverse parseData input -- FIXME: Not used!
 
-			s <- socket AF_INET Stream defaultProtocol
+			s <- makeSocket
 			addr' <- inet_addr "127.0.0.1"
 			Net.connect s (SockAddrInet (fromIntegral $ clientPort copts) addr')
 			bracket (socketToHandle s ReadWriteMode) hClose $ \h -> do
@@ -148,84 +153,70 @@ 
 	handle forkError $ do
 		_ <- forkProcess proxy
-		putStrLn $ "Server started at port " ++ show (serverPort sopts)
+		putStrLn $ "Server started at port {}" ~~ serverPort sopts
 #endif
-runServerCommand (Run sopts) = runServer sopts $ \copts -> do
-	commandLog copts Log.Info $ "Server started at port " ++ show (serverPort sopts)
-	clientChan <- F.newChan
-	listenerSem <- newQSem 0
-	_ <- async $ Log.scopeLog (commandLogger copts) "listener" $ flip finally (signalQSem listenerSem) $ do
-		let
-			serverStop :: IO ()
-			serverStop = void $ do
-				commandLog copts Log.Trace "stopping server"
-				-- NOTE: killing listener doesn't work on Windows, because accept blocks async exceptions
-				signalQSem listenerSem
-
-		bracket (socket AF_INET Stream defaultProtocol) close $ \s -> do
-			setSocketOption s ReuseAddr 1
-			bind s $ SockAddrInet (fromIntegral $ serverPort sopts) iNADDR_ANY
-			listen s maxListenQueue
-			forever $ logAsync (commandLog copts Log.Fatal) $ logIO "exception: " (commandLog copts Log.Error) $ do
-				commandLog copts Log.Trace "accepting connection"
-				s' <- fst <$> accept s
-				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
+runServerCommand (Run sopts) = runServer sopts $ do
+	Log.log Log.Info $ "Server started at port {}" ~~ serverPort sopts
+	clientChan <- liftIO F.newChan
+	session <- getSession
+	_ <- liftIO $ async $ withSession session $ Log.scope "listener" $ flip finally serverExit $
+		bracket (liftIO makeSocket) (liftIO . close) $ \s -> do
+			liftIO $ do
+				setSocketOption s ReuseAddr 1
+				bind s $ SockAddrInet (fromIntegral $ serverPort sopts) iNADDR_ANY
+				listen s maxListenQueue
+			forever $ logAsync (Log.log Log.Fatal . fromString) $ logIO "exception: " (Log.log Log.Error . fromString) $ do
+				Log.log Log.Trace "accepting connection"
+				s' <- liftIO $ fst <$> accept s
+				Log.log Log.Trace $ "accepted {}" ~~ show s'
+				void $ liftIO $ forkIO $ withSession session $ Log.scope (T.pack $ show s') $
+					logAsync (Log.log Log.Fatal . fromString) $ logIO "exception: " (Log.log Log.Error . fromString) $
+						flip finally (liftIO $ close s') $
+							bracket (liftIO newEmptyMVar) (liftIO . (`putMVar` ())) $ \done -> do
+								me <- liftIO myThreadId
 								let
-									timeoutWait = do
-										notDone <- isEmptyMVar done
+									timeoutWait = withSession session $ do
+										notDone <- liftIO $ isEmptyMVar done
 										when notDone $ do
-											commandLog copts Log.Trace $ "waiting for " ++ show s' ++ " to complete"
-											waitAsync <- async $ do
+											Log.log Log.Trace $ "waiting for {} to complete" ~~ show s'
+											waitAsync <- liftIO $ async $ do
 												threadDelay 1000000
 												killThread me
-											void $ waitCatch waitAsync
-								F.putChan clientChan timeoutWait
-								processClientSocket s' (copts {
-									commandExit = serverStop })
+											liftIO $ void $ waitCatch waitAsync
+								liftIO $ F.putChan clientChan timeoutWait
+								processClientSocket s'
 
-	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"
+	Log.log Log.Trace "waiting for accept thread"
+	serverWait
+	Log.log Log.Trace "accept thread stopped"
+	askSession sessionDatabase >>= liftIO . DB.readAsync >>= writeCache sopts
+	Log.log Log.Trace "waiting for clients"
+	liftIO (F.stopChan clientChan) >>= sequence_
+	Log.log Log.Info "server stopped"
 runServerCommand (Stop copts) = runServerCommand (Remote copts False Exit)
 runServerCommand (Connect copts) = do
 	curDir <- getCurrentDirectory
-	s <- socket AF_INET Stream defaultProtocol
+	s <- makeSocket
 	addr' <- inet_addr "127.0.0.1"
 	Net.connect s (SockAddrInet (fromIntegral $ clientPort copts) addr')
 	bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do
 		input' <- hGetLineBS stdin
-		case eitherDecode input' of
-			Left _ -> L.putStrLn $ encodeValue $ object ["error" .= ("invalid command" :: String)]
-			Right req' -> do
-				L.hPutStrLn h $ encode $ Message (Just $ show i) $ Request req' curDir True (clientTimeout copts) False
+		case decodeMsg input' of
+			Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError "invalid command" []) em
+			Right m -> do
+				L.hPutStrLn h $ encodeMessage $ set msg (Message (Just $ show i) $ Request (view msg m) curDir True (clientTimeout copts) False) m
 				waitResp h
 	where
-		pretty = clientPretty copts
-
-		encodeValue :: ToJSON a => a -> L.ByteString
-		encodeValue
-			| pretty = encodePretty
-			| otherwise = encode
-
 		waitResp h = do
 			resp <- hGetLineBS h
 			parseResp h resp
 
-		parseResp h str = case eitherDecode str of
-			Left e -> putStrLn $ "Can't decode response: " ++ e
-			Right (Message i r) -> do
-				Response r' <- unMmap r
-				putStrLn $ fromMaybe "_" i ++ ":" ++ fromUtf8 (encodeValue r')
-				case unResponse r of
+		parseResp h str = case decodeMessage str of
+			Left em -> putStrLn $ "Can't decode response: {}" ~~ view msg em
+			Right m -> do
+				Response r' <- unMmap $ view (msg . message) m
+				putStrLn $ "{}: {}" ~~ fromMaybe "_" (view (msg . messageId) m) ~~ fromUtf8 (encodeMsg $ set msg (Response r') m)
+				case unResponse (view (msg . message) m) of
 					Left _ -> waitResp h
 					_ -> return ()
 runServerCommand (Remote copts noFile c) = sendCommand copts noFile c printValue >>= printResult where
@@ -240,93 +231,135 @@ findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath
 findPath copts f = liftIO $ canonicalizePath (normalise f') where
 	f'
-		| isRelative f = commandRoot copts </> f
+		| isRelative f = commandOptionsRoot copts </> f
 		| otherwise = f
 
+type Msg a = (Bool, a)
+
+isLisp :: Lens' (Msg a) Bool
+isLisp = _1
+
+msg :: Lens (Msg a) (Msg b) a b
+msg = _2
+
+jsonMsg :: a -> Msg a
+jsonMsg = (,) False
+
+lispMsg :: a -> Msg a
+lispMsg = (,) True
+
+-- | Decode lisp or json
+decodeMsg :: FromJSON a => ByteString -> Either (Msg String) (Msg a)
+decodeMsg bstr = over _Left decodeType' decodeMsg' where
+	decodeType'
+		| isLisp' = lispMsg
+		| otherwise = jsonMsg
+	decodeMsg' = (lispMsg <$> decodeLisp bstr) <|> (jsonMsg <$> eitherDecode bstr)
+	isLisp' = fromMaybe False $ mplus (try' eitherDecode False) (try' decodeLisp True)
+	try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool
+	try' f l = either (const Nothing) (const $ Just l) $ f bstr
+
+-- | Encode lisp or json
+encodeMsg :: ToJSON a => Msg a -> ByteString
+encodeMsg m
+	| view isLisp m = encodeLisp $ view msg m
+	| otherwise = encode $ view msg m
+
+-- | Decode lisp or json request
+decodeMessage :: FromJSON a => ByteString -> Either (Msg String) (Msg (Message a))
+decodeMessage = decodeMsg
+
+encodeMessage :: ToJSON a => Msg (Message a) -> ByteString
+encodeMessage = encodeMsg
+
 -- | Process request, notifications can be sent during processing
-processRequest :: CommandOptions -> (Notification -> IO ()) -> Command -> IO Result
-processRequest copts onNotify c = paths (findPath copts) c >>= Client.runCommand (copts { commandNotify = onNotify })
+processRequest :: SessionMonad m => CommandOptions -> Command -> m Result
+processRequest copts c = do
+	c' <- paths (findPath copts) c
+	s <- getSession
+	withSession s $ Client.runClient copts $ Client.runCommand c'
 
 -- | Process client, listen for requests and process them
-processClient :: String -> IO ByteString -> (ByteString -> IO ()) -> CommandOptions -> IO ()
-processClient name receive send' copts = do
-	commandLog copts Log.Info $ name ++ " connected"
-	respChan <- newChan
-	void $ forkIO $ getChanContents respChan >>= mapM_ (send' . encode)
-	linkVar <- newMVar $ return ()
+processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m ()
+processClient name rchan send' = do
+	Log.log Log.Info $ "{} connected" ~~ name
+	respChan <- liftIO newChan
+	liftIO $ void $ forkIO $ getChanContents respChan >>= mapM_ (send' . encodeMessage)
+	linkVar <- liftIO $ newMVar $ return ()
+	s <- getSession
+	exit <- askSession sessionExit
 	let
-		answer :: Message Response -> IO ()
-		answer m@(Message _ r) = do
-			unless (isNotification r) $
-				commandLog copts Log.Trace $ " << " ++ ellipsis (fromUtf8 (encode r))
-			writeChan respChan m
+		answer :: SessionMonad m => Msg (Message Response) -> m ()
+		answer m = do
+			unless (isNotification $ view (msg . message) m) $
+				Log.log Log.Trace $ " << {}" ~~ ellipsis (fromUtf8 (encode $ view (msg . message) m))
+			liftIO $ writeChan respChan m
 			where
 				ellipsis :: String -> String
-				ellipsis s
-					| length s < 100 = s
-					| otherwise = take 100 s ++ "..."
+				ellipsis str
+					| length str < 100 = str
+					| otherwise = take 100 str ++ "..."
 	-- 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
-			Left _ -> do
-				commandLog copts Log.Warning $ "Invalid request: " ++ fromUtf8 req'
-				answer $ Message Nothing $ responseError "Invalid request" [
-					"request" .= fromUtf8 req']
-			Right m -> Log.scopeLog (commandLogger copts) (T.pack $ fromMaybe "_" (messageId m)) $ do
-				resp' <- for m $ \(Request c cdir noFile tm silent) -> do
-					let
-						onNotify n
-							| silent = return ()
-							| otherwise = traverse (const $ mmap' noFile (Response $ Left n)) m >>= answer
-					commandLog copts Log.Trace $ name ++ " >> " ++ fromUtf8 (encode c)
-					resp <- fmap (Response . Right) $ handleTimeout tm $ handleError $
-						processRequest
-							(copts {
-								commandRoot = cdir,
-								commandLink = void (swapMVar linkVar $ commandExit copts) })
-							onNotify
-							c
-					mmap' noFile resp
-				answer resp'
+	reqs <- liftIO $ F.readChan rchan
+	flip finally (disconnected linkVar) $ Log.scope (T.pack name) $
+		forM_ reqs $ \req' -> do
+			Log.log Log.Trace $ " => {}" ~~ fromUtf8 req'
+			case decodeMessage req' of
+				Left em -> do
+					Log.log Log.Warning $ "Invalid request {}" ~~ fromUtf8 req'
+					answer $ set msg (Message Nothing $ responseError "Invalid request" ["request" .= fromUtf8 req']) em
+				Right m -> Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do
+					resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do
+						let
+							onNotify n
+								| silent = return ()
+								| otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer
+						Log.log Log.Trace $ "{} >> {}" ~~ name ~~ fromUtf8 (encode c)
+						resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ handleError $ withSession s $
+							processRequest
+								CommandOptions {
+									commandOptionsRoot = cdir,
+									commandOptionsNotify = withSession s . onNotify,
+									commandOptionsLink = void (swapMVar linkVar exit),
+									commandOptionsHold = forever (F.getChan rchan) }
+								c
+						mmap' noFile resp
+					answer resp'
 	where
 		handleTimeout :: Int -> IO Result -> IO Result
 		handleTimeout 0 = id
 		handleTimeout tm = fmap (fromMaybe $ Error "Timeout" M.empty) . timeout tm
 
 		handleError :: IO Result -> IO Result
-		handleError = handle onErr where
+		handleError = flip catch onErr where
 			onErr :: SomeException -> IO Result
 			onErr e = return $ Error "Exception" $ M.fromList [("what", toJSON $ show e)]
 
-		mmap' :: Bool -> Response -> IO Response
+		mmap' :: SessionMonad m => Bool -> Response -> m Response
 #if mingw32_HOST_OS
-		mmap' False
-			| Just pool <- commandMmapPool copts = mmap pool
+		mmap' False r = do
+			mpool <- askSession sessionMmapPool
+			case mpool of
+				Just pool -> liftIO $ mmap pool r
+				Nothing -> return r
 #endif
-		mmap' _ = return
+		mmap' _ r = return r
 
 		-- Call on disconnected, either no action or exit command
-		disconnected :: MVar (IO ()) -> IO ()
+		disconnected :: SessionMonad m => MVar (IO ()) -> m ()
 		disconnected var = do
-			commandLog copts Log.Info $ name ++ " disconnected"
-			join $ takeMVar var
+			Log.log Log.Info $ "{} disconnected" ~~ name
+			liftIO $ join $ takeMVar var
 
 -- | Process client by socket
-processClientSocket :: Socket -> CommandOptions -> IO ()
-processClientSocket s copts = do
-	recvChan <- F.newChan
-	void $ forkIO $ finally
+processClientSocket :: SessionMonad m => Socket -> m ()
+processClientSocket s = do
+	recvChan <- liftIO F.newChan
+	liftIO $ void $ forkIO $ finally
 		(Net.getContents s >>= mapM_ (F.putChan recvChan) . L.lines)
 		(F.closeChan recvChan)
-	processClient (show s) (getChan_ recvChan) (sendLine s) (copts {
-		commandHold = forever (getChan_ recvChan) })
+	processClient (show s) recvChan (sendLine s)
 	where
-		getChan_ :: F.Chan a -> IO a
-		getChan_ = F.getChan >=> maybe noData return
-		noData :: IO a
-		noData = throwIO $ userError "Receive chan closed"
 		-- NOTE: Network version of `sendAll` goes to infinite loop on client socket close
 		-- when server's send is blocked, see https://github.com/haskell/network/issues/155
 		-- After that issue fixed we may revert to `processClientHandle`
@@ -351,18 +384,18 @@ -- | Push message to mmap and return response which points to this mmap
 mmap :: Pool -> Response -> IO Response
 mmap mmapPool r
-	| L.length msg <= 1024 = return r
+	| L.length msg' <= 1024 = return r
 	| otherwise = do
 		rvar <- newEmptyMVar
-		_ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ flip catchError
-			(\_ -> liftIO $ void $ tryPutMVar rvar r)
-			(withMapFile mmapName (L.toStrict msg) $ liftIO $ do
+		_ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ catchError
+			(withMapFile mmapName (L.toStrict msg') $ liftIO $ do
 				_ <- tryPutMVar rvar $ result $ MmapFile mmapName
 				-- give 10 seconds for client to read data
 				threadDelay 10000000)
+			(\_ -> liftIO $ void $ tryPutMVar rvar r)
 		takeMVar rvar
 	where
-		msg = encode r
+		msg' = encode r
 #endif
 
 -- | If response points to mmap, get its contents and parse
@@ -378,3 +411,6 @@ 				Right r'' -> return r''
 #endif
 unMmap r = return r
+
+makeSocket :: IO Socket
+makeSocket = socket AF_INET Stream defaultProtocol

@@ -1,7 +1,7 @@-{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-}
 
 module HsDev.Server.Message (
-	Message(..),
+	Message(..), messageId, message,
 	messagesById,
 	Notification(..), Result(..), ResultPart(..),
 	Response(..), isNotification, notification, result, responseError, resultPart,
@@ -10,6 +10,7 @@ 
 import Control.Arrow (first)
 import Control.Applicative
+import Control.Lens (makeLenses)
 import Control.Monad (join)
 import Data.Aeson hiding (Error, Result)
 import Data.Aeson.Types (Pair)
@@ -23,10 +24,12 @@ 
 -- | Message with id to link request and response
 data Message a = Message {
-	messageId :: Maybe String,
-	message :: a }
-		deriving (Eq, Ord, Functor)
+	_messageId :: Maybe String,
+	_message :: a }
+		deriving (Eq, Ord, Show, Functor)
 
+makeLenses ''Message
+
 instance ToJSON a => ToJSON (Message a) where
 	toJSON (Message i m) = object ["id" .= i] `objectUnion` toJSON m
 
@@ -42,10 +45,10 @@ 
 -- | Get messages by id
 messagesById :: Maybe String -> [Message a] -> [a]
-messagesById i = map message . filter ((== i) . messageId)
+messagesById i = map _message . filter ((== i) . _messageId)
 
 -- | Notification from server
-data Notification = Notification Value
+data Notification = Notification Value deriving (Eq, Show)
 
 instance ToJSON Notification where
 	toJSON (Notification v) = object ["notify" .= v]
@@ -59,6 +62,7 @@ 	-- ^ Result
 	Error String (Map String Value)
 	-- ^ Error
+		deriving (Show)
 
 instance ToJSON Result where
 	toJSON (Result r) = object ["result" .= r]
@@ -80,7 +84,7 @@ instance FromJSON ResultPart where
 	parseJSON = withObject "result-part" $ \v -> ResultPart <$> v .:: "result-part"
 
-newtype Response = Response { unResponse :: Either Notification Result }
+newtype Response = Response { unResponse :: Either Notification Result } deriving (Show)
 
 isNotification :: Response -> Bool
 isNotification = either (const True) (const False) . unResponse

@@ -1,8 +1,11 @@-{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds, TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module HsDev.Server.Types (
-	CommandOptions(..), CommandError(..), commandError_, commandError,
-	CommandM,
+	ServerMonadBase,
+	Session(..), SessionMonad(..), askSession, ServerM(..),
+	CommandOptions(..), CommandError(..), commandErrorMsg, commandErrorDetails, commandError, commandError_, CommandMonad(..), askOptions, ClientM(..),
+	withSession, serverListen, serverWait, serverUpdateDB, serverWriteCache, serverReadCache, serverExit, commandRoot, commandNotify, commandLink, commandHold,
 	ServerCommand(..), ServerOpts(..), ClientOpts(..), serverOptsArgs, Request(..),
 
 	Command(..), AddedContents(..),
@@ -13,9 +16,13 @@ 	) where
 
 import Control.Applicative
-import Control.Lens (each)
+import Control.Lens (each, makeLenses)
+import Control.Monad.Base
+import Control.Monad.Catch
+import Control.Monad.CatchIO
 import Control.Monad.Except
 import Control.Monad.Reader
+import Control.Monad.Trans.Control
 import Data.Aeson hiding (Result(..), Error)
 import qualified Data.Aeson.Types as A
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -42,42 +49,161 @@ import System.Win32.FileMapping.NamePool (Pool)
 #endif
 
-data CommandOptions = CommandOptions {
-	commandDatabase :: DB.Async Database,
-	commandWriteCache :: Database -> IO (),
-	commandReadCache :: (FilePath -> ExceptT String IO Structured) -> IO (Maybe Database),
-	commandRoot :: FilePath,
-	commandLog :: Level -> String -> IO (),
-	commandLogger :: Log,
-	commandListenLog :: ([String] -> IO ()) -> IO (),
-	commandLogWait :: IO (),
-	commandWatcher :: Watcher,
+type ServerMonadBase m = (MonadCatchIO m, MonadBaseControl IO m)
+
+data Session = Session {
+	sessionDatabase :: DB.Async Database,
+	sessionWriteCache :: Database -> ServerM IO (),
+	sessionReadCache :: (FilePath -> ExceptT String IO Structured) -> ServerM IO (Maybe Database),
+	sessionLog :: Level -> String -> IO (),
+	sessionLogger :: Log,
+	sessionListenLog :: IO [String],
+	sessionLogWait :: IO (),
+	sessionWatcher :: Watcher,
 #if mingw32_HOST_OS
-	commandMmapPool :: Maybe Pool,
+	sessionMmapPool :: Maybe Pool,
 #endif
-	commandGhc :: Worker Ghc,
-	commandGhci :: Worker Ghc,
-	commandGhcMod :: Worker (ReaderT WorkerMap IO),
-	commandNotify :: Notification -> IO (),
-	commandLink :: IO (),
-	commandHold :: IO (),
-	commandExit :: IO (),
-	commandDefines :: [(String, String)] }
+	sessionGhc :: Worker Ghc,
+	sessionGhci :: Worker Ghc,
+	sessionGhcMod :: Worker (ReaderT WorkerMap IO),
+	sessionExit :: IO (),
+	sessionWait :: IO (),
+	sessionDefines :: [(String, String)] }
 
-data CommandError = CommandError String [A.Pair]
+class (ServerMonadBase m, MonadLog m) => SessionMonad m where
+	getSession :: m Session
 
+askSession :: SessionMonad m => (Session -> a) -> m a
+askSession f = liftM f getSession
+
+newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a } deriving (Functor, Applicative, Monad, MonadReader Session, MonadIO, MonadTrans, MonadCatchIO, MonadThrow, MonadCatch)
+
+instance MonadCatchIO m => MonadLog (ServerM m) where
+	askLog = ServerM $ asks sessionLogger
+
+instance ServerMonadBase m => SessionMonad (ServerM m) where
+	getSession = ask
+
+instance MonadBase b m => MonadBase b (ServerM m) where
+	liftBase = ServerM . liftBase
+
+instance MonadBaseControl b m => MonadBaseControl b (ServerM m) where
+	type StM (ServerM m) a = StM (ReaderT Session m) a
+	liftBaseWith f = ServerM $ liftBaseWith (\f' -> f (f' . runServerM))
+	restoreM = ServerM . restoreM
+
+data CommandOptions = CommandOptions {
+	commandOptionsRoot :: FilePath,
+	commandOptionsNotify :: Notification -> IO (),
+	commandOptionsLink :: IO (),
+	commandOptionsHold :: IO () }
+
+instance Default CommandOptions where
+	def = CommandOptions "." (const $ return ()) (return ()) (return ())
+
+data CommandError = CommandError {
+	_commandErrorMsg :: String,
+	_commandErrorDetails :: [A.Pair] }
+
+makeLenses ''CommandError
+
 instance Monoid CommandError where
 	mempty = CommandError "" []
 	mappend (CommandError lmsg lp) (CommandError rmsg rp) = CommandError (lmsg ++ ", " ++ rmsg) (lp ++ rp)
 
-commandError_ :: String -> ExceptT CommandError IO a
+class (SessionMonad m, MonadError CommandError m, MonadPlus m) => CommandMonad m where
+	getOptions :: m CommandOptions
+
+commandError :: CommandMonad m => String -> [A.Pair] -> m a
+commandError m ds = throwError $ CommandError m ds
+
+commandError_ :: CommandMonad m => String -> m a
 commandError_ m = commandError m []
 
-commandError :: String -> [A.Pair] -> ExceptT CommandError IO a
-commandError m ps = throwError $ CommandError m ps
+askOptions :: CommandMonad m => (CommandOptions -> a) -> m a
+askOptions f = liftM f getOptions
 
-type CommandM a = ExceptT CommandError IO a
+newtype ClientM m a = ClientM { runClientM :: ServerM (ExceptT CommandError (ReaderT CommandOptions m)) a }
+	deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO, MonadThrow, MonadCatch)
 
+instance MonadTrans ClientM where
+	lift = ClientM . lift . lift . lift
+
+instance MonadCatchIO m => MonadLog (ClientM m) where
+	askLog = ClientM askLog
+
+instance Monad m => MonadError CommandError (ClientM m) where
+	throwError = ClientM . lift . throwError
+	catchError act handler = ClientM $ ServerM $ catchError (runServerM $ runClientM act) (runServerM . runClientM . handler)
+
+instance Monad m => Alternative (ClientM m) where
+	empty = ClientM $ ServerM empty
+	x <|> y = ClientM $ ServerM $ runServerM (runClientM x) <|> runServerM (runClientM y)
+
+instance Monad m => MonadPlus (ClientM m) where
+	mzero = ClientM $ ServerM mzero
+	mplus l r = ClientM $ ServerM $ runServerM (runClientM l) `mplus` runServerM (runClientM r)
+
+instance ServerMonadBase m => SessionMonad (ClientM m) where
+	getSession = ClientM getSession
+
+instance ServerMonadBase m => CommandMonad (ClientM m) where
+	getOptions = ClientM $ lift $ lift ask
+
+instance MonadBase b m => MonadBase b (ClientM m) where
+	liftBase = ClientM . liftBase
+
+instance MonadBaseControl b m => MonadBaseControl b (ClientM m) where
+	type StM (ClientM m) a = StM (ServerM (ExceptT CommandError (ReaderT CommandOptions m))) a
+	liftBaseWith f = ClientM $ liftBaseWith (\f' -> f (f' . runClientM))
+	restoreM = ClientM . restoreM
+
+-- | Run action on session
+withSession :: Session -> ServerM m a -> m a
+withSession s act = runReaderT (runServerM act) s
+
+-- | Listen server's log
+serverListen :: SessionMonad m => m [String]
+serverListen = join . liftM liftIO $ askSession sessionListenLog
+
+-- | Wait for server
+serverWait :: SessionMonad m => m ()
+serverWait = join . liftM liftIO $ askSession sessionWait
+
+-- | Update database
+serverUpdateDB :: SessionMonad m => Database -> m ()
+serverUpdateDB db = askSession sessionDatabase >>= (`DB.update` return db)
+
+-- | Server write cache
+serverWriteCache :: SessionMonad m => Database -> m ()
+serverWriteCache db = do
+	s <- getSession
+	write' <- askSession sessionWriteCache
+	liftIO $ withSession s $ write' db
+
+-- | Server read cache
+serverReadCache :: SessionMonad m => (FilePath -> ExceptT String IO Structured) -> m (Maybe Database)
+serverReadCache act = do
+	s <- getSession
+	read' <- askSession sessionReadCache
+	liftIO $ withSession s $ read' act
+
+-- | Exit session
+serverExit :: SessionMonad m => m ()
+serverExit = join . liftM liftIO $ askSession sessionExit
+
+commandRoot :: CommandMonad m => m FilePath
+commandRoot = askOptions commandOptionsRoot
+
+commandNotify :: CommandMonad m => Notification -> m ()
+commandNotify n = join . liftM liftIO $ askOptions commandOptionsNotify <*> pure n
+
+commandLink :: CommandMonad m => m ()
+commandLink = join . liftM liftIO $ askOptions commandOptionsLink
+
+commandHold :: CommandMonad m => m ()
+commandHold = join . liftM liftIO $ askOptions commandOptionsHold
+
 -- | Server control command
 data ServerCommand =
 	Version |
@@ -181,6 +307,7 @@ 	requestNoFile :: Bool,
 	requestTimeout :: Int,
 	requestSilent :: Bool }
+		deriving (Show)
 
 instance ToJSON Request where
 	toJSON (Request c dir f tm s) = object ["current-directory" .= dir, "no-file" .= f, "timeout" .= tm, "silent" .= s] `objectUnion` toJSON c
@@ -375,7 +502,7 @@ 		cmd "module" "get module info" (InfoModule <$> cmdP <*> many cmdP),
 		cmd "resolve" "resolve module scope (or exports)" (InfoResolve <$> fileArg <*> exportsFlag),
 		cmd "project" "get project info" (InfoProject <$> ((Left <$> projectArg) <|> (Right <$> pathArg idm))),
-		cmd "sandbox" "get sandbox info" (InfoSandbox <$> (pathArg $ help "locate sandbox in parent of this path")),
+		cmd "sandbox" "get sandbox info" (InfoSandbox <$> pathArg (help "locate sandbox in parent of this path")),
 		cmd "lookup" "lookup for symbol" (Lookup <$> strArgument idm <*> ctx),
 		cmd "whois" "get info for symbol" (Whois <$> strArgument idm <*> ctx),
 		cmd "scope" "get declarations accessible from module or within a project" (
@@ -418,12 +545,12 @@ 	cmdP = asum [TargetProject <$> projectArg, TargetFile <$> fileArg, TargetModule <$> moduleArg, TargetDepsOf <$> depsArg, TargetCabal <$> cabalArg, TargetPackage <$> packageArg, flag' TargetSourced (long "src"), flag' TargetStandalone (long "stand")]
 
 instance FromCmd SearchQuery where
-	cmdP = SearchQuery <$> (strArgument idm <|> pure "") <*> (asum [
+	cmdP = SearchQuery <$> (strArgument idm <|> pure "") <*> asum [
 		flag' SearchExact (long "exact"),
 		flag' SearchRegex (long "regex"),
 		flag' SearchInfix (long "infix"),
 		flag' SearchSuffix (long "suffix"),
-		pure SearchPrefix <* switch (long "prefix")])
+		pure SearchPrefix <* switch (long "prefix")]
 
 readJSON :: FromJSON a => ReadM a
 readJSON = str >>= maybe (readerError "Can't parse JSON argument") return . decode . L.pack
@@ -520,45 +647,45 @@ 		guardCmd "listen" v *> pure Listen,
 		guardCmd "add" v *> (AddData <$> v .:: "data"),
 		guardCmd "scan" v *> (Scan <$>
-			v .:: "projects" <*>
-			v .:: "sandboxes" <*>
-			v .:: "files" <*>
-			v .:: "paths" <*>
-			v .:: "contents" <*>
-			v .:: "ghc-opts" <*>
-			v .:: "docs" <*>
-			v .:: "infer"),
-		guardCmd "docs" v *> (RefineDocs <$> v .:: "projects" <*> v .:: "files" <*> v .:: "modules"),
-		guardCmd "infer" v *> (InferTypes <$> v .:: "projects" <*> v .:: "files" <*> v .:: "modules"),
+			v .::?! "projects" <*>
+			v .::?! "sandboxes" <*>
+			v .::?! "files" <*>
+			v .::?! "paths" <*>
+			v .::?! "contents" <*>
+			v .::?! "ghc-opts" <*>
+			(v .:: "docs" <|> pure False) <*>
+			(v .:: "infer" <|> pure False)),
+		guardCmd "docs" v *> (RefineDocs <$> v .::?! "projects" <*> v .::?! "files" <*> v .::?! "modules"),
+		guardCmd "infer" v *> (InferTypes <$> v .::?! "projects" <*> v .::?! "files" <*> v .::?! "modules"),
 		guardCmd "remove" v *> (Remove <$>
-			v .:: "projects" <*>
-			v .:: "packages" <*>
-			v .:: "sandboxes" <*>
-			v .:: "files"),
-		guardCmd "modules" v *> (InfoModules <$> v .:: "filters"),
+			v .::?! "projects" <*>
+			v .::?! "packages" <*>
+			v .::?! "sandboxes" <*>
+			v .::?! "files"),
+		guardCmd "modules" v *> (InfoModules <$> v .::?! "filters"),
 		guardCmd "packages" v *> pure InfoPackages,
 		guardCmd "projects" v *> pure InfoProjects,
 		guardCmd "sandboxes" v *> pure InfoSandboxes,
-		guardCmd "symbol" v *> (InfoSymbol <$> v .:: "query" <*> v .:: "filters" <*> v .:: "locals"),
-		guardCmd "module" v *> (InfoModule <$> v .:: "query" <*> v .:: "filters"),
-		guardCmd "resolve" v *> (InfoResolve <$> v .:: "file" <*> v .:: "exports"),
+		guardCmd "symbol" v *> (InfoSymbol <$> v .:: "query" <*> v .::?! "filters" <*> (v .:: "locals" <|> pure False)),
+		guardCmd "module" v *> (InfoModule <$> v .:: "query" <*> v .::?! "filters"),
+		guardCmd "resolve" v *> (InfoResolve <$> v .:: "file" <*> (v .:: "exports" <|> pure False)),
 		guardCmd "project" v *> (InfoProject <$> asum [Left <$> v .:: "name", Right <$> v .:: "path"]),
 		guardCmd "sandbox" v *> (InfoSandbox <$> v .:: "path"),
 		guardCmd "lookup" v *> (Lookup <$> v .:: "name" <*> v .:: "file"),
 		guardCmd "whois" v *> (Whois <$> v .:: "name" <*> v .:: "file"),
 		guardCmd "scope modules" v *> (ResolveScopeModules <$> v .:: "query" <*> v .:: "file"),
-		guardCmd "scope" v *> (ResolveScope <$> v .:: "query" <*> v .:: "global" <*> v .:: "file"),
-		guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> v .:: "wide" <*> v .:: "file"),
-		guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> v .:: "page" <*> v .:: "pages"),
-		guardCmd "cabal list" v *> (CabalList <$> v .:: "packages"),
-		guardCmd "lint" v *> (Lint <$> v .:: "files" <*> v .:: "contents"),
-		guardCmd "check" v *> (Check <$> v .:: "files" <*> v .:: "contents" <*> v .:: "ghc-opts"),
-		guardCmd "check-lint" v *> (CheckLint <$> v .:: "files" <*> v .:: "contents" <*> v .:: "ghc-opts"),
-		guardCmd "types" v *> (Types <$> v .:: "files" <*> v .:: "contents" <*> v .:: "ghc-opts"),
+		guardCmd "scope" v *> (ResolveScope <$> v .:: "query" <*> (v .:: "global" <|> pure False) <*> v .:: "file"),
+		guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> (v .:: "wide" <|> pure False) <*> v .:: "file"),
+		guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> (v .:: "page" <|> pure 0) <*> (v .:: "pages" <|> pure 1)),
+		guardCmd "cabal list" v *> (CabalList <$> v .::?! "packages"),
+		guardCmd "lint" v *> (Lint <$> v .::?! "files" <*> v .::?! "contents"),
+		guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "contents" <*> v .::?! "ghc-opts"),
+		guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "contents" <*> v .::?! "ghc-opts"),
+		guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "contents" <*> v .::?! "ghc-opts"),
 		GhcMod <$> parseJSON (Object v),
 		AutoFix <$> parseJSON (Object v),
-		guardCmd "ghc eval" v *> (GhcEval <$> v .:: "exprs"),
-		guardCmd "link" v *> (Link <$> v .:: "hold"),
+		guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs"),
+		guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)),
 		guardCmd "exit" v *> pure Exit]
 
 instance ToJSON AddedContents where
@@ -584,10 +711,10 @@ 	parseJSON = withObject "ghc-mod-command" $ \v -> asum [
 		guardCmd "ghc-mod lang" v *> pure GhcModLang,
 		guardCmd "ghc-mod flags" v *> pure GhcModFlags,
-		guardCmd "ghc-mod type" v *> (GhcModType <$> v .:: "position" <*> v .:: "file" <*> v .:: "ghc-opts"),
-		guardCmd "ghc-mod lint" v *> (GhcModLint <$> v .:: "files" <*> v .:: "hlint-opts"),
-		guardCmd "ghc-mod check" v *> (GhcModCheck <$> v .:: "files" <*> v .:: "ghc-opts"),
-		guardCmd "ghc-mod check-lint" v *> (GhcModCheckLint <$> v .:: "files" <*> v .:: "ghc-opts" <*> v .:: "hlint-opts")]
+		guardCmd "ghc-mod type" v *> (GhcModType <$> v .:: "position" <*> v .:: "file" <*> v .::?! "ghc-opts"),
+		guardCmd "ghc-mod lint" v *> (GhcModLint <$> v .:: "files" <*> v .::?! "hlint-opts"),
+		guardCmd "ghc-mod check" v *> (GhcModCheck <$> v .:: "files" <*> v .::?! "ghc-opts"),
+		guardCmd "ghc-mod check-lint" v *> (GhcModCheckLint <$> v .:: "files" <*> v .::?! "ghc-opts" <*> v .::?! "hlint-opts")]
 
 instance ToJSON AutoFixCommand where
 	toJSON (AutoFixShow ns) = cmdJson "autofix show" ["messages" .= ns]
@@ -596,7 +723,7 @@ instance FromJSON AutoFixCommand where
 	parseJSON = withObject "auto-fix-command" $ \v -> asum [
 		guardCmd "autofix show" v *> (AutoFixShow <$> v .:: "messages"),
-		guardCmd "autofix fix" v *> (AutoFixFix <$> v .:: "messages" <*> v .:: "rest" <*> v .:: "pure")]
+		guardCmd "autofix fix" v *> (AutoFixFix <$> v .:: "messages" <*> v .::?! "rest" <*> (v .:: "pure" <|> pure True))]
 
 instance ToJSON FileContents where
 	toJSON (FileContents fpath cts) = object ["file" .= fpath, "contents" .= cts]
@@ -634,7 +761,7 @@ 	toJSON (SearchQuery q st) = object ["input" .= q, "type" .= st]
 
 instance FromJSON SearchQuery where
-	parseJSON = withObject "search-query" $ \v -> SearchQuery <$> v .:: "input" <*> v .:: "type"
+	parseJSON = withObject "search-query" $ \v -> SearchQuery <$> (v .:: "input" <|> pure "") <*> (v .:: "type" <|> pure SearchPrefix)
 
 instance ToJSON SearchType where
 	toJSON SearchExact = toJSON ("exact" :: String)

@@ -8,6 +8,8 @@ 	module HsDev.Symbols.Types,
 	Cabal(..), Project(..),
 
+	recalcNotesTabs,
+
 	module Control.Monad.Except
 	) where
 

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module HsDev.Util (
 	withCurrentDirectory,
@@ -38,6 +39,7 @@ import Control.Monad
 import Control.Monad.Except
 import qualified Control.Monad.Catch as C
+import qualified Control.Monad.CatchIO as CatchIO
 import Data.Aeson hiding (Result(..), Error)
 import qualified Data.Aeson.Types as A
 import Data.Char (isSpace)
@@ -56,6 +58,7 @@ import System.Directory
 import System.FilePath
 import System.IO
+import qualified System.Log.Simple as Log
 
 import Control.Concurrent.Async
 
@@ -231,15 +234,15 @@ 	onErr :: SomeException -> IO ()
 	onErr e = out $ pre ++ displayException e
 
-logIO :: String -> (String -> IO ()) -> IO () -> IO ()
-logIO pre out = handle onIO where
-	onIO :: IOException -> IO ()
-	onIO e = out $ pre ++ displayException e
+logIO :: CatchIO.MonadCatchIO m => String -> (String -> m ()) -> m () -> m ()
+logIO pre out = flip CatchIO.catch (onIO out) where
+	onIO :: CatchIO.MonadCatchIO m => (String -> m ()) -> IOException -> m ()
+	onIO out' e = out' $ pre ++ displayException e
 
-logAsync :: (String -> IO ()) -> IO () -> IO ()
-logAsync out = handle onAsync where
-	onAsync :: AsyncException -> IO ()
-	onAsync e = out (displayException e) >> throwIO e
+logAsync :: CatchIO.MonadCatchIO m => (String -> m ()) -> m () -> m ()
+logAsync out = flip CatchIO.catch (onAsync out) where
+	onAsync :: CatchIO.MonadCatchIO m => (String -> m ()) -> AsyncException -> m ()
+	onAsync out' e = out' (displayException e) >> CatchIO.throw e
 
 ignoreIO :: IO () -> IO ()
 ignoreIO = handle (const (return ()) :: IOException -> IO ())
@@ -277,3 +280,11 @@ 	handle' (Success r) = Right r
 	handle' (Failure f) = Left $ fst $ renderFailure f nm
 	handle' _ = Left "error: completion invoked result"
+
+instance CatchIO.MonadCatchIO m => CatchIO.MonadCatchIO (ExceptT e m) where
+	catch act onError = ExceptT $ CatchIO.catch (runExceptT act) (runExceptT . onError)
+	block = ExceptT . CatchIO.block . runExceptT
+	unblock = ExceptT . CatchIO.unblock . runExceptT
+
+instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where
+	askLog = lift Log.askLog