hsdev 0.1.0.0 → 0.1.0.1

raw patch · 10 files changed

+746/−506 lines, 10 filesdep ~ghc-mod

Dependency ranges changed: ghc-mod

Files

• hsdev.cabal +25/−10
• src/HsDev/Tools/GhcMod.hs +32/−32
• src/HsDev/Util.hs +9/−1
• tools/Commands.hs +453/−361
• tools/System/Command.hs +108/−49
• tools/Tool.hs +6/−6
• tools/Types.hs +68/−18
• tools/Update.hs +37/−21
• tools/hsclearimports.hs +7/−7
• tools/hsinspect.hs +1/−1

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.0.0
+version:             0.1.0.1
 synopsis:            Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc.
 -- description:
 homepage:            https://github.com/mvoidex/hsdev
@@ -19,6 +19,8 @@   hs-source-dirs: src
   ghc-options: -threaded
   exposed-modules:
+    Data.Group
+    Data.Async
     HsDev
     HsDev.Cabal
     HsDev.Cache
@@ -48,10 +50,6 @@     exposed-modules:
       System.Win32.PowerShell
 
-  other-modules:
-    Data.Group
-    Data.Async
-
   build-depends:
     base >= 4.7 && < 5,
     aeson >= 0.7.0,
@@ -63,7 +61,7 @@     directory >= 1.2.0,
     filepath >= 1.3.0,
     ghc >= 7.8.1,
-    ghc-mod >= 4.0.0,
+    ghc-mod >= 4.1.0 && < 4.2.0,
     ghc-paths >= 0.1.0,
     haddock >= 2.14.0,
     haskell-src-exts >= 1.14.0,
@@ -113,6 +111,7 @@     mtl >= 2.1.0,
     network >= 2.4.0,
     process >= 1.2.0,
+    unordered-containers >= 0.2.0,
     text >= 1.1.0,
     transformers >= 0.3.0,
     unordered-containers >= 0.2.0,
@@ -136,19 +135,29 @@     bytestring >= 0.10.0,
     containers >= 0.5.0,
     mtl >= 2.1.0,
-    transformers >= 0.3.0
+    text >= 1.1.0,
+    transformers >= 0.3.0,
+    unordered-containers >= 0.2.0,
+    vector >= 0.10.0
 
 executable hsclearimports
   main-is: hsclearimports.hs
   hs-source-dirs: tools
+  other-modules:
+    System.Command
   build-depends:
     base >= 4.7 && < 5,
     hsdev,
+    aeson >= 0.7.0,
+    aeson-pretty >= 0.7.0,
     directory >= 1.2.0,
     ghc >= 7.8.1,
     haskell-src-exts >= 1.14.0,
     containers >= 0.5.0,
-    mtl >= 2.1.0
+    mtl >= 2.1.0,
+    text >= 1.1.0,
+    unordered-containers >= 0.2.0,
+    vector >= 0.10.0
 
 executable hscabal
   main-is: hscabal.hs
@@ -163,7 +172,10 @@     aeson-pretty >= 0.7.0,
     bytestring >= 0.10.0,
     containers >= 0.5.0,
-    mtl >= 2.1.0
+    mtl >= 2.1.0,
+    text >= 1.1.0,
+    unordered-containers >= 0.2.0,
+    vector >= 0.10.0
 
 executable hshayoo
   main-is: hshayoo.hs
@@ -178,7 +190,10 @@     aeson-pretty >= 0.7.0,
     bytestring >= 0.10.0,
     containers >= 0.5.0,
-    mtl >= 2.1.0
+    mtl >= 2.1.0,
+    text >= 1.1.0,
+    unordered-containers >= 0.2.0,
+    vector >= 0.10.0
 
 test-suite test
   main-is: Test.hs

@@ -31,18 +31,28 @@ import HsDev.Symbols
 import HsDev.Symbols.Location
 import HsDev.Tools.Base
-import HsDev.Util ((.::))
+import HsDev.Util ((.::), liftException)
 
 list :: [String] -> Cabal -> ErrorT String IO [ModuleLocation]
-list opts cabal = do
-	cradle <- liftIO $ cradle cabal Nothing
-	ms <- tryGhc $ GhcMod.listMods (GhcMod.defaultOptions { GhcMod.ghcOpts = opts }) cradle
+list opts cabal = liftException $ do
+	cradle <- cradle cabal Nothing
+	ms <- (map splitPackage . lines) <$> GhcMod.listModules
+		(GhcMod.defaultOptions { GhcMod.ghcOpts = opts })
+		cradle
 	return [CabalModule cabal (readMaybe p) m | (m, p) <- ms]
+	where
+		splitPackage :: String -> (String, String)
+		splitPackage = second (drop 1) . break isSpace
 
 browse :: [String] -> Cabal -> String -> Maybe ModulePackage -> ErrorT String IO InspectedModule
-browse opts cabal mname mpackage = inspect mloc (return $ browseInspection opts) $ do
-	cradle <- liftIO $ cradle cabal Nothing
-	ts <- tryGhc $ GhcMod.browse (GhcMod.defaultOptions { GhcMod.detailed = True, GhcMod.ghcOpts = packageOpt mpackage ++ opts, GhcMod.packageId = mpackagename }) cradle mname
+browse opts cabal mname mpackage = inspect mloc (return $ browseInspection opts) $ liftException $ do
+	cradle <- cradle cabal Nothing
+	ts <- lines <$> GhcMod.browseModule
+		(GhcMod.defaultOptions {
+			GhcMod.detailed = True,
+			GhcMod.ghcOpts = packageOpt mpackage ++ opts })
+		cradle
+		mpkgname
 	return $ Module {
 		moduleName = mname,
 		moduleDocs = Nothing,
@@ -51,7 +61,7 @@ 		moduleImports = [],
 		moduleDeclarations = decls ts }
 	where
-		mpackagename = fmap packageName mpackage
+		mpkgname = maybe mname (\p -> packageName p ++ ":" ++ mname) mpackage
 		mloc = CabalModule cabal mpackage mname
 		decls rs = M.fromList $ map (declarationName &&& id) $ mapMaybe parseDecl rs
 		parseFunction s = do
@@ -69,8 +79,9 @@ 
 info :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> String -> ErrorT String IO Declaration
 info opts cabal file mproj mname sname = do
-	cradle <- liftIO $ cradle cabal mproj
-	rs <- tryGhc $ GhcMod.info (GhcMod.defaultOptions { GhcMod.ghcOpts = cabalOpt cabal ++ opts }) cradle file mname sname
+	rs <- liftException $ do
+		cradle <- cradle cabal mproj
+		GhcMod.infoExpr (GhcMod.defaultOptions { GhcMod.ghcOpts = cabalOpt cabal ++ opts }) cradle file sname
 	toDecl rs
 	where
 		toDecl s = maybe (throwError $ "Can't parse info: '" ++ s ++ "'") return $ parseData s `mplus` parseFunction s
@@ -109,10 +120,15 @@ 		v .:: "type"
 
 typeOf :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> Int -> Int -> ErrorT String IO [TypedRegion]
-typeOf opts cabal file mproj mname line col = do
-	fileCts <- liftIO $ readFile file
-	cradle <- liftIO $ cradle cabal mproj
-	ts <- fmap lines $ tryGhc $ GhcMod.typeOf (GhcMod.defaultOptions { GhcMod.ghcOpts = cabalOpt cabal ++ opts }) cradle file mname line col
+typeOf opts cabal file mproj mname line col = liftException $ do
+	fileCts <- readFile file
+	cradle <- cradle cabal mproj
+	ts <- lines <$> GhcMod.typeExpr
+		(GhcMod.defaultOptions { GhcMod.ghcOpts = cabalOpt cabal ++ opts })
+		cradle
+		file
+		line
+		col
 	return $ mapMaybe (toRegionType fileCts) ts
 	where
 		toRegionType :: String -> String -> Maybe TypedRegion
@@ -124,30 +140,14 @@ 		parsePosition :: ReadM Position
 		parsePosition = Position <$> readParse <*> readParse
 
-tryGhc :: Ghc a -> ErrorT String IO a
-tryGhc act = ErrorT $ ghandle rethrow $ liftM Right $ runGhc (Just libdir) $ do
-	dflags <- getSessionDynFlags
-	defaultCleanupHandler dflags act
-	where
-		rethrow :: SomeException -> IO (Either String a)
-		rethrow = return . Left . show
-
 cradle :: Cabal -> Maybe Project -> IO GhcMod.Cradle
 cradle cabal Nothing = do
 	dir <- getCurrentDirectory
-	return $ GhcMod.Cradle dir dir Nothing (sandbox cabal) []
+	return $ GhcMod.Cradle dir dir Nothing []
 cradle cabal (Just proj) = do
 	dir <- getCurrentDirectory
 	return $ GhcMod.Cradle
 		dir
 		(projectPath proj)
 		(Just $ projectCabal proj)
-		(sandbox cabal)
-		(zip deps (repeat Nothing))
-	where
-		deps = fromMaybe [] $ do
-			desc <- projectDescription proj
-			return $ nub $ sort $ concatMap infoDepends $ concat [
-					map buildInfo (maybeToList (projectLibrary desc)),
-					map buildInfo (projectExecutables desc),
-					map buildInfo (projectTests desc)]
+		[]

@@ -7,9 +7,10 @@ 	-- * String utils
 	tab, tabs, trim, split,
 	-- * Helper
-	(.::),
+	(.::), (.::?),
 	-- * Exceptions
 	liftException, liftExceptionM, liftIOErrors,
+	eitherT,
 	-- * UTF-8
 	fromUtf8, toUtf8
 	) where
@@ -28,6 +29,7 @@ import Data.Text (Text)
 import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.Encoding as T
+import Data.Traversable (traverse)
 import System.Directory
 import System.FilePath
 
@@ -89,6 +91,9 @@ (.::) :: FromJSON a => HM.HashMap Text Value -> Text -> Parser a
 v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v
 
+(.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> Parser (Maybe a)
+v .::? name = traverse parseJSON $ lookup name $ HM.toList v
+
 -- | Lift IO exception to ErrorT
 liftException :: C.MonadCatchIO m => m a -> ErrorT String m a
 liftException act = ErrorT $ C.catch (liftM Right act) onError where
@@ -102,6 +107,9 @@ -- | Lift IO exceptions to ErrorT
 liftIOErrors :: C.MonadCatchIO m => ErrorT String m a -> ErrorT String m a
 liftIOErrors act = liftException (runErrorT act) >>= either throwError return
+
+eitherT :: (Monad m, Error e, MonadError e m) => Either String a -> m a
+eitherT = either (throwError . strMsg) return
 
 fromUtf8 :: ByteString -> String
 fromUtf8 = T.unpack . T.decodeUtf8

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, CPP #-}
+{-# LANGUAGE OverloadedStrings, CPP, TupleSections #-}
 
 module Commands (
 	mainCommands, commands
@@ -13,6 +13,7 @@ import Control.Concurrent
 import Data.Aeson
 import Data.Aeson.Encode.Pretty
+import Data.Aeson.Types
 import Data.Char
 import Data.Either
 import Data.List
@@ -83,19 +84,13 @@ mainCommands :: [Command (IO ())]
 mainCommands = addHelp "hsdev" id $ srvCmds ++ map wrapCmd commands where
 	wrapCmd :: Command CommandAction -> Command (IO ())
-	wrapCmd = fmap sendCmd . addClientOpts . fmap withOptsArgs
+	wrapCmd = fmap sendCmd . addClientOpts . fmap withOptsCommand
 	srvCmds = [
-		cmd_ ["run"] [] "run interactive" runi',
 		cmd ["server", "start"] [] "start remote server" serverOpts start',
 		cmd ["server", "run"] [] "start server" serverOpts run',
-		cmd ["server", "stop"] [] "stop remote server" clientOpts stop']
+		cmd ["server", "stop"] [] "stop remote server" clientOpts stop',
+		cmd ["connect"] [] "connect to send commands directly" clientOpts connect']
 
-	runi' _ = do
-		dir <- getCurrentDirectory
-		db <- DB.newAsync
-		forever $ do
-			s <- getLine
-			processCmd (CommandOptions db (const $ return ()) (const $ return Nothing) dir putStrLn getLine (error "Not supported") exitSuccess) 1000 s (L.putStrLn . encode)
 	start' sopts _ = do
 #if mingw32_HOST_OS
 		let
@@ -135,101 +130,37 @@ 			forkProcess proxy
 			putStrLn $ "Server started at port " ++ show (fromJust $ getFirst $ serverPort sopts)
 #endif
-	run' sopts _ = do
-		msgs <- F.newChan
-		outputDone <- newEmptyMVar
-		forkIO $ finally
-			(F.readChan msgs >>= mapM_ (logMsg sopts))
-			(putMVar outputDone ())
-
-		let
-			outputStr = F.putChan msgs
-			waitOutput = F.closeChan msgs >> takeMVar outputDone
-			withCache :: a -> (FilePath -> IO a) -> IO a
-			withCache v onCache = case getFirst (serverCache sopts) of
-				Nothing -> return v
-				Just cdir -> onCache cdir
-			writeCache :: Database -> IO ()
-			writeCache d = withCache () $ \cdir -> do
-				outputStr "writing cache"
-				SC.dump cdir (structurize d)
-			readCache :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database)
-			readCache act = withCache Nothing $ join . liftM (either cacheErr cacheOk) . runErrorT . act where
-				cacheErr e = outputStr ("Unable read cache: " ++ e) >> return Nothing
-				cacheOk s = do
-					forM_ (M.keys (structuredCabals s)) $ \c -> outputStr ("cache read: cabal " ++ show c)
-					forM_ (M.keys (structuredProjects s)) $ \p -> outputStr ("cache read: project " ++ p)
-					case allModules (structuredFiles s) of
-						[] -> return ()
-						ms -> outputStr $ "cache read: " ++ show (length ms) ++ " files"
-					return $ Just $ merge s
-
-		outputStr $ "Server started at port " ++ show (fromJust $ getFirst $ serverPort sopts)
-
-		logIO "server exception: " outputStr $ flip finally waitOutput $ do
-			db <- DB.newAsync
-
-			when (getAny $ serverLoadCache sopts) $ withCache () $ \cdir -> do
-				outputStr $ "Loading cache from " ++ cdir
-				dbCache <- liftA merge <$> SC.load cdir
-				case dbCache of
-					Left err -> outputStr $ "Failed to load cache: " ++ err
-					Right dbCache' -> DB.update db (return dbCache')
+	run' sopts _
+		| getAny (serverAsClient sopts) = runServer sopts $ \copts -> do
+			commandLog copts $ "Server started as client connecting at port " ++ show (fromJust $ getFirst $ serverPort sopts)
+			me <- myThreadId
+			s <- socket AF_INET Stream defaultProtocol
+			addr' <- inet_addr "127.0.0.1"
+			connect s $ SockAddrInet (fromIntegral $ fromJust $ getFirst $ serverPort sopts) addr'
+			bracket (socketToHandle s ReadWriteMode) hClose $ \h ->
+				processClient (show s) (hGetLine' h) (L.hPutStrLn h) sopts (copts {
+					commandExit = killThread me })
+		| otherwise = runServer sopts $ \copts -> do
+			commandLog copts $ "Server started at port " ++ show (fromJust $ getFirst $ serverPort sopts)
 
 			waitListen <- newEmptyMVar
 			clientChan <- F.newChan
 
-			linkChan <- F.newChan
-			let
-				linkToSrv :: IO ()
-				linkToSrv = do
-					v <- newEmptyMVar
-					F.putChan linkChan (putMVar v ())
-					takeMVar v
-
-#if mingw32_HOST_OS
-			mmapPool <- createPool "hsdev"
-			let
-				-- | Send response as is or via memory mapped file
-				sendResponse :: Handle -> Response -> IO ()
-				sendResponse h r@(ResponseMapFile _) = L.hPutStrLn h $ encode r
-				sendResponse h r
-					| L.length msg <= 1024 = L.hPutStrLn h msg
-					| otherwise = do
-						sync <- newEmptyMVar
-						forkIO $ void $ withName mmapPool $ \mmapName -> do
-							runErrorT $ flip catchError
-								(\e -> liftIO $ do
-									sendResponse h $ Response $ object ["error" .= e]
-									putMVar sync ())
-								(withMapFile mmapName (L.toStrict msg) $ liftIO $ do
-									sendResponse h $ ResponseMapFile mmapName
-									putMVar sync ()
-									-- Dirty: give 10 seconds for client to read it
-									threadDelay 10000000)
-						takeMVar sync
-					where
-						msg = encode r
-#else
-			let
-				sendResponse h = L.hPutStrLn h . encode
-#endif
-
 			forkIO $ do
 				accepter <- myThreadId
 
 				let
+					serverStop :: IO ()
 					serverStop = void $ forkIO $ do
 						void $ tryPutMVar waitListen ()
 						killThread accepter
 
 				s <- socket AF_INET Stream defaultProtocol
-				bind s (SockAddrInet (fromIntegral $ fromJust $ getFirst $ serverPort sopts) iNADDR_ANY)
+				bind s $ SockAddrInet (fromIntegral $ fromJust $ getFirst $ serverPort sopts) iNADDR_ANY
 				listen s maxListenQueue
-				forever $ logIO "accept client exception: " outputStr $ do
-					s' <- fmap fst $ accept s
-					outputStr $ show s' ++ " connected"
-					void $ forkIO $ logIO (show s' ++ " exception: ") outputStr $
+				forever $ logIO "accept client exception: " (commandLog copts) $ do
+					s' <- fst <$> accept s
+					void $ forkIO $ logIO (show s' ++ " exception: ") (commandLog copts) $
 						bracket (socketToHandle s' ReadWriteMode) hClose $ \h -> do
 							bracket newEmptyMVar (`putMVar` ()) $ \done -> do
 								me <- myThreadId
@@ -238,79 +169,87 @@ 										notDone <- isEmptyMVar done
 										when notDone $ do
 											void $ forkIO $ do
-												threadDelay 10000000
+												threadDelay 1000000
 												tryPutMVar done ()
 												killThread me
-											void $ takeMVar done
+											takeMVar done
+									waitForever = forever $ hGetLine' h
 								F.putChan clientChan timeoutWait
-								req <- hGetLine' h
-								outputStr $ show s' ++ ": " ++ fromUtf8 req
-								case fmap extractCurrentDir $ eitherDecode req of
-									Left reqErr -> sendResponse h $ Response $ object [
-										"error" .= ("Invalid request" :: String),
-										"request" .= fromUtf8 req,
-										"what" .= reqErr]
-									Right (clientDir, reqArgs) -> processCmdArgs
-										(CommandOptions
-											db
-											writeCache
-											readCache
-											clientDir
-											outputStr
-											(fromUtf8 <$> hGetLine' h)
-											linkToSrv
-											serverStop)
-										(fromJust $ getFirst $ serverTimeout sopts) reqArgs (sendResponse h)
-								-- Send 'end' message and wait client
-								L.hPutStrLn h L.empty
-								outputStr $ "waiting " ++ show s'
-								ignoreIO $ void $ timeout 10000000 $ hGetLine' h
-								outputStr $ show s' ++ " disconnected"
+								processClient (show s') (hGetLine' h) (L.hPutStrLn h) sopts (copts {
+									commandHold = waitForever,
+									commandExit = serverStop })
 
 			takeMVar waitListen
-			withCache () $ \cdir -> do
-				outputStr $ "saving cache to " ++ cdir
-				logIO "cache saving exception: " outputStr $ do
-					dbval <- DB.readAsync db
-					SC.dump cdir $ structurize dbval
-				outputStr "cache saved"
-			outputStr "closing links"
-			F.stopChan linkChan >>= sequence_
-			outputStr "waiting for clients"
+			DB.readAsync (commandDatabase copts) >>= writeCache sopts (commandLog copts)
 			F.stopChan clientChan >>= sequence_
-			outputStr "server shutdown"
+			commandLog copts "server stopped"
+
 	stop' copts _ = run (map wrapCmd' commands) onDef onError ["exit"] where
 		onDef = putStrLn "Command 'exit' not found"
 		onError es = putStrLn $ "Failed to stop server: " ++ intercalate ", " es
-		wrapCmd' = fmap (sendCmd . fmap ((,) copts) . withOptsArgs)
+		wrapCmd' = fmap (sendCmd . (copts,) . withOptsCommand)
 
-	logIO :: String -> (String -> IO ()) -> IO () -> IO ()
-	logIO pre out act = handle onIO act where
-		onIO :: IOException -> IO ()
-		onIO e = out $ pre ++ show e
+	connect' copts _ = do
+		curDir <- getCurrentDirectory
+		s <- socket AF_INET Stream defaultProtocol
+		addr' <- inet_addr "127.0.0.1"
+		connect s (SockAddrInet (fromIntegral $ fromJust $ getFirst $ clientPort copts) addr')
+		bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forever $ ignoreIO $ do
+			cmd <- hGetLine' stdin
+			case eitherDecode cmd of
+				Left e -> L.putStrLn $ encodeValue $ object ["error" .= ("invalid command" :: String)]
+				Right cmd' -> do
+					L.hPutStrLn h $ encode $ cmd' `addCallOpts` ["current-directory" %-- curDir]
+					waitResp h
+		where
+			pretty = getAny $ clientPretty copts
+			encodeValue :: ToJSON a => a -> L.ByteString
+			encodeValue
+				| pretty = encodePretty
+				| otherwise = encode
 
-	ignoreIO :: IO () -> IO ()
-	ignoreIO = handle (const (return ()) :: IOException -> IO ())
+			waitResp h = do
+				resp <- hGetLine' h
+				parseResp h resp
 
-	logMsg :: ServerOpts -> String -> IO ()
-	logMsg sopts s = ignoreIO $ do
-		putStrLn s
-		case getFirst (serverLog sopts) of
-			Nothing -> return ()
-			Just f -> withFile f AppendMode (`hPutStrLn` s)
+			parseResp h str = void $ runErrorT $ flip catchError (liftIO . putStrLn) $ do
+				v <- ErrorT (return $ eitherDecode str) `orFail` ("Can't decode response", ["response" .= fromUtf8 str])
+				case v of
+					ResponseStatus s -> liftIO $ do
+						L.putStrLn $ encodeValue s
+						liftIO $ waitResp h
+#if mingw32_HOST_OS
+					ResponseMapFile viewFile -> do
+						str <- fmap L.fromStrict (readMapFile viewFile) `orFail`
+							("Can't read map view of file", ["file" .= viewFile])
+						lift $ parseResp h str
+#else
+					ResponseMapFile viewFile -> throwError $ fromUtf8 $ encodeValue $
+						object ["error" .= ("Not supported" :: String)]
+#endif
+					Response r -> liftIO $ L.putStrLn $ encodeValue r
+				where
+					orFail :: (Monad m, Functor m) => ErrorT String m a -> (String, [Pair]) -> ErrorT String m a
+					orFail act (msg, fs) = act <|> (throwError $ fromUtf8 $ encodeValue $ object (
+						("error" .= msg) : fs))
 
 	-- Send command to server
-	sendCmd :: IO (ClientOpts, [String]) -> IO ()
-	sendCmd get' = do
+	sendCmd :: (ClientOpts, CommandCall) -> IO ()
+	sendCmd (p, cmdCall) = do
 		svar <- newEmptyMVar
 		race [takeMVar svar, waitResponse >> putMVar svar ()]
 		where
+			pretty = getAny $ clientPretty p
+			encodeValue :: ToJSON a => a -> L.ByteString
+			encodeValue
+				| pretty = encodePretty
+				| otherwise = encode
+
 			waitResponse = do
 				curDir <- getCurrentDirectory
-				(p, as) <- get'
 				stdinData <- if getAny (clientData p)
 					then do
-						cdata <- liftM eitherDecode L.getContents
+						cdata <- liftM (eitherDecode :: L.ByteString -> Either String Value) L.getContents
 						case cdata of
 							Left cdataErr -> do
 								putStrLn $ "Invalid data: " ++ cdataErr
@@ -322,49 +261,169 @@ 				addr' <- inet_addr "127.0.0.1"
 				connect s (SockAddrInet (fromIntegral $ fromJust $ getFirst $ clientPort p) addr')
 				h <- socketToHandle s ReadWriteMode
-				L.hPutStrLn h $ encode $ ["--current-directory=" ++ curDir] ++ setData stdinData as
-				responses <- liftM (takeWhile (not . L.null) . L.lines) $ L.hGetContents h
-				forM_ responses $
-					parseResponse >=>
-					(L.putStrLn . encodeValue (getAny $ clientPretty p))
+				L.hPutStrLn h $ encode $ cmdCall `addCallOpts` [
+					"current-directory" %-- curDir,
+					case stdinData of
+						Nothing -> mempty
+						Just d -> "data" %-- (fromUtf8 $ encode d)]
+				peekResponse h
 
-			setData :: Maybe ResultValue -> [String] -> [String]
-			setData Nothing = id
-			setData (Just d) = (++ ["--data=" ++ (fromUtf8 $ encode d)])
+			peekResponse h = do
+				resp <- hGetLine' h
+				parseResponse h resp
 
-			parseResponse r = fmap (either err' id) $ runErrorT $ do
-				v <- errT (eitherDecode r) `orFail` (\e -> "Can't decode response")
+			parseResponse h str = void $ runErrorT $ flip catchError (liftIO . putStrLn) $ do
+				v <- ErrorT (return $ eitherDecode str) `orFail` ("Can't decode response", ["response" .= fromUtf8 str])
 				case v of
-					Response rv -> return rv
-					ResponseStatus sv -> return sv
+					ResponseStatus s -> liftIO $ do
+						L.putStrLn $ encodeValue s
+						peekResponse h
 #if mingw32_HOST_OS
 					ResponseMapFile viewFile -> do
 						str <- fmap L.fromStrict (readMapFile viewFile) `orFail`
-							(\e -> "Can't read map view of file")
-						lift $ parseResponse str
+							("Can't read map view of file", ["file" .= viewFile])
+						lift $ parseResponse h str
 #else
-					ResponseMapFile viewFile -> return $ err' ("Not supported" :: String)
+					ResponseMapFile viewFile -> throwError $ fromUtf8 $ encodeValue $
+						object ["error" .= ("Not supported" :: String)]
 #endif
+					Response r -> liftIO $ L.putStrLn $ encodeValue r
 				where
-					errT act = ErrorT $ return act
-					orFail act msg = act `catchError` (throwError . msg)
-					err' msg = object ["error" .= msg]
-
-			encodeValue True = encodePretty
-			encodeValue False = encode
+					orFail :: (Monad m, Functor m) => ErrorT String m a -> (String, [Pair]) -> ErrorT String m a
+					orFail act (msg, fs) = act <|> (throwError $ fromUtf8 $ encodeValue $ object (
+						("error" .= msg) : fs))
 
 	-- Add parsing 'ClieptOpts'
-	addClientOpts :: Command (IO [String]) -> Command (IO (ClientOpts, [String]))
+	addClientOpts :: Command CommandCall -> Command (ClientOpts, CommandCall)
 	addClientOpts c = c { commandRun = run' } where
-		run' args = fmap (fmap (fmap $ (,) p)) $ commandRun c args' where
+		run' args = fmap (fmap (p,)) $ commandRun c args' where
 			(ps, args', _) = getOpt RequireOrder clientOpts args
 			p = mconcat ps `mappend` defaultConfig
 
-	extractCurrentDir :: [String] -> (FilePath, [String])
-	extractCurrentDir as = (head $ cur ++ ["."], as') where
-		(cur, as', _) = getOpt RequireOrder curDirOpts as
-		curDirOpts = [Option [] ["current-directory"] (ReqArg id "path") "current directory"]
+-- | Inits log chan and returns functions (print message, wait channel)
+initLog :: ServerOpts -> IO (String -> IO (), IO ())
+initLog sopts = do
+	msgs <- F.newChan
+	outputDone <- newEmptyMVar
+	forkIO $ finally
+		(F.readChan msgs >>= mapM_ (logMsg sopts))
+		(putMVar outputDone ())
+	return (F.putChan msgs, F.closeChan msgs >> takeMVar outputDone)
 
+-- | Run server
+runServer :: ServerOpts -> (CommandOptions -> IO ()) -> IO ()
+runServer sopts act = bracket (initLog sopts) snd $ \(outputStr, waitOutput) -> do
+	db <- DB.newAsync
+	when (getAny $ serverLoadCache sopts) $ withCache sopts () $ \cdir -> do
+		outputStr $ "Loading cache from " ++ cdir
+		dbCache <- liftA merge <$> SC.load cdir
+		case dbCache of
+			Left err -> outputStr $ "Failed to load cache: " ++ err
+			Right dbCache' -> DB.update db (return dbCache')
+#if mingw32_HOST_OS
+	mmapPool <- Just <$> createPool "hsdev"
+#endif
+	act $ CommandOptions
+		db
+		(writeCache sopts outputStr)
+		(readCache sopts outputStr)
+		"."
+		outputStr
+		waitOutput
+#if mingw32_HOST_OS
+		mmapPool
+#endif
+		(return ())
+		(return ())
+		(return ())
+
+withCache :: ServerOpts -> a -> (FilePath -> IO a) -> IO a
+withCache sopts v onCache = case getFirst (serverCache sopts) of
+	Nothing -> return v
+	Just cdir -> onCache cdir
+
+writeCache :: ServerOpts -> (String -> IO ()) -> Database -> IO ()
+writeCache sopts logMsg d = withCache sopts () $ \cdir -> do
+	logMsg $ "writing cache to " ++ cdir
+	logIO "cache writing exception: " logMsg $ do
+		SC.dump cdir $ structurize d
+	logMsg $ "cache saved to " ++ cdir
+
+readCache :: ServerOpts -> (String -> IO ()) -> (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database)
+readCache sopts logMsg act = withCache sopts Nothing $ join . liftM (either cacheErr cacheOk) . runErrorT . act where
+	cacheErr e = logMsg ("Error reading cache: " ++ e) >> return Nothing
+	cacheOk s = do
+		forM_ (M.keys (structuredCabals s)) $ \c -> logMsg ("cache read: cabal " ++ show c)
+		forM_ (M.keys (structuredProjects s)) $ \p -> logMsg ("cache read: project " ++ p)
+		case allModules (structuredFiles s) of
+			[] -> return ()
+			ms -> logMsg $ "cache read: " ++ show (length ms) ++ " files"
+		return $ Just $ merge s
+
+#if mingw32_HOST_OS
+sendResponseMmap :: Pool -> (ByteString -> IO ()) -> Response -> IO ()
+sendResponseMmap mmapPool send r@(ResponseMapFile _) = send $ encode r
+sendResponseMmap mmapPool send r
+	| L.length msg <= 1024 = send msg
+	| otherwise = do
+		sync <- newEmptyMVar
+		forkIO $ void $ withName mmapPool $ \mmapName -> do
+			runErrorT $ flip catchError
+				(\e -> liftIO $ do
+					sendResponseMmap mmapPool send $ Response $ object ["error" .= e]
+					putMVar sync ())
+				(withMapFile mmapName (L.toStrict msg) $ liftIO $ do
+					sendResponseMmap mmapPool send $ ResponseMapFile mmapName
+					putMVar sync ()
+					-- give 10 seconds for client to read data
+					threadDelay 10000000)
+		takeMVar sync
+	where
+		msg = encode r
+#endif
+
+sendResponse :: (ByteString -> IO ()) -> Response -> IO ()
+sendResponse = (. encode)
+
+processClient :: String -> IO ByteString -> (ByteString -> IO ()) -> ServerOpts -> CommandOptions -> IO ()
+processClient name receive send sopts copts = do
+	commandLog copts $ name ++ " connected"
+	linkVar <- newMVar $ return ()
+	flip finally (disconnected linkVar) $ forever $ do
+		req <- receive
+		commandLog copts $ name ++ " >> " ++ fromUtf8 req
+		case extractMeta <$> eitherDecode req of
+			Left err -> answer True $ Response $ object [
+				"error" .= ("Invalid request" :: String),
+				"request" .= fromUtf8 req,
+				"what" .= err]
+			Right (cdir, noFile, reqArgs) -> processCmdArgs
+				(copts { commandLink = void (swapMVar linkVar $ commandExit copts), commandRoot = cdir })
+				(fromJust $ getFirst $ serverTimeout sopts)
+				(callArgs reqArgs)
+				(answer noFile)
+	where
+		answer :: Bool -> Response -> IO ()
+		answer noFile' r = do
+			commandLog copts $ name ++ " << " ++ fromUtf8 (encode r)
+#if mingw32_HOST_OS
+			case noFile' of
+				True -> sendResponse send r
+				False -> maybe (sendResponse send) (`sendResponseMmap` send) (commandMmapPool copts) r
+#else
+			sendResponse send r
+#endif
+
+		extractMeta :: CommandCall -> (FilePath, Bool, CommandCall)
+		extractMeta c = (fpath, noFile, c `removeCallOpts` ["current-directory", "no-file"]) where
+			fpath = fromMaybe (commandRoot copts) $ arg "current-directory" $ commandCallOpts c
+			noFile = flag "no-file" $ commandCallOpts c
+
+		disconnected :: MVar (IO ()) -> IO ()
+		disconnected var = do
+			commandLog copts $ name ++ " disconnected"
+			join $ takeMVar var
+
 commands :: [Command CommandAction]
 commands = map wrapErrors $ map (fmap (fmap timeout')) cmds ++ map (fmap (fmap noTimeout)) linkCmd where
 	timeout' :: (CommandOptions -> IO CommandResult) -> (Int -> CommandOptions -> IO CommandResult)
@@ -385,9 +444,9 @@ 		cmd_' ["ping"] [] "ping server" ping',
 		-- Database commands
 		cmd' ["add"] [] "add info to database" [dataArg] add',
-		cmd' ["scan", "cabal"] [] "scan modules installed in cabal" [
-			sandbox, ghcOpts, wait, status] scanCabal',
-		cmd' ["scan", "module"] ["module name"] "scan module in cabal" [sandbox, ghcOpts] scanModule',
+		cmd' ["scan", "cabal"] [] "scan modules installed in cabal" (sandboxes ++ [
+			ghcOpts, wait, status]) scanCabal',
+		cmd' ["scan", "module"] ["module name"] "scan module in cabal" (sandboxes ++ [ghcOpts]) scanModule',
 		cmd' ["scan"] [] "scan sources" [
 			projectArg "project path or .cabal",
 			fileArg "source file",
@@ -398,33 +457,32 @@ 			fileArg "source file",
 			pathArg "path to rescan",
 			ghcOpts, wait, status] rescan',
-		cmd' ["remove"] [] "remove modules info" [
-			sandbox,
+		cmd' ["remove"] [] "remove modules info" (sandboxes ++ [
 			projectArg "module project",
 			fileArg "module source file",
 			moduleArg,
 			packageArg, noLastArg, packageVersionArg,
-			allFlag] remove',
+			allFlag]) remove',
 		-- | Context free commands
-		cmd' ["list", "modules"] [] "list modules" [
-			projectArg "project to list modules from",
+		cmd' ["list", "modules"] [] "list modules" (sandboxes ++ [
+			projectArg "projects to list modules from",
 			noLastArg,
 			packageArg,
-			sandbox, sourced, standaloned] listModules',
+			sourced, standaloned]) listModules',
 		cmd_' ["list", "packages"] [] "list packages" listPackages',
 		cmd_' ["list", "projects"] [] "list projects" listProjects',
-		cmd' ["symbol"] ["name"] "get symbol info" (matches ++ [
+		cmd' ["symbol"] ["name"] "get symbol info" (matches ++ sandboxes ++ [
 			projectArg "related project",
 			fileArg "source file",
 			moduleArg, localsArg,
 			packageArg, noLastArg, packageVersionArg,
-			sandbox, sourced, standaloned]) symbol',
-		cmd' ["module"] [] "get module info" [
+			sourced, standaloned]) symbol',
+		cmd' ["module"] [] "get module info" (sandboxes ++ [
 			moduleArg, localsArg,
 			packageArg, noLastArg, packageVersionArg,
 			projectArg "module project",
 			fileArg "module source file",
-			sandbox, sourced] modul',
+			sourced]) modul',
 		cmd' ["project"] [] "get project info" [
 			projectArg "project path or name"] project',
 		-- Context commands
@@ -438,17 +496,17 @@ 		cmd' ["cabal", "list"] ["packages..."] "list cabal packages" [] cabalList',
 		cmd' ["ghc-mod", "type"] ["line", "column"] "infer type with 'ghc-mod type'" ctx ghcmodType',
 		-- Dump/load commands
-		cmd' ["dump", "cabal"] [] "dump cabal modules" [sandbox, cacheDir, cacheFile] dumpCabal',
+		cmd' ["dump", "cabal"] [] "dump cabal modules" (sandboxes ++ [cacheDir, cacheFile]) dumpCabal',
 		cmd' ["dump", "projects"] [] "dump projects" [projectArg "project", cacheDir, cacheFile] dumpProjects',
 		cmd' ["dump", "files"] [] "dump standalone files" [cacheDir, cacheFile] dumpFiles',
 		cmd' ["dump"] [] "dump whole database" [cacheDir, cacheFile] dump',
 		cmd' ["load"] [] "load data" [cacheDir, cacheFile, dataArg, wait] load',
 		-- Exit
 		cmd_' ["exit"] [] "exit" exit']
-	linkCmd = [cmd' ["link"] [] "link to server" [] link']
+	linkCmd = [cmd' ["link"] [] "link to server" [holdArg] link']
 
 	-- Command arguments and flags
-	allFlag = option_ ['a'] "all" flag "remove all"
+	allFlag = option_ ['a'] "all" no "remove all"
 	cacheDir = pathArg "cache path"
 	cacheFile = fileArg "cache file"
 	ctx = [fileArg "source file", sandbox]
@@ -456,9 +514,10 @@ 	fileArg = option_ ['f'] "file" (req "file")
 	findArg = option_ [] "find" (req "find") "infix match"
 	ghcOpts = option_ ['g'] "ghc" (req "ghc options") "options to pass to GHC"
-	globalArg = option_ [] "global" flag "scope of project"
-	localsArg = option_ ['l'] "locals" flag "look in local declarations"
-	noLastArg = option_ [] "no-last" flag "don't select last package version"
+	globalArg = option_ [] "global" no "scope of project"
+	holdArg = option_ ['h'] "hold" no "don't return any response"
+	localsArg = option_ ['l'] "locals" no "look in local declarations"
+	noLastArg = option_ [] "no-last" no "don't select last package version"
 	matches = [prefixArg, findArg]
 	moduleArg = option_ ['m'] "module" (req "module name") "module name"
 	packageArg = option_ [] "package" (req "package") "module package"
@@ -466,19 +525,22 @@ 	prefixArg = option_ [] "prefix" (req "prefix") "prefix match"
 	projectArg = option [] "project" ["proj"] (req "project")
 	packageVersionArg = option_ ['v'] "version" (req "version") "package version"
-	sandbox = option_ [] "sandbox" (noreq "path") "path to cabal sandbox"
-	sourced = option_ [] "src" flag "source files"
-	standaloned = option_ [] "stand" flag "standalone files"
-	status = option_ ['s'] "status" flag "show status of operation, works only with --wait"
-	wait = option_ ['w'] "wait" flag "wait for operation to complete"
+	sandbox = option_ [] "sandbox" (req "path") "path to cabal sandbox"
+	sandboxes = [
+		option_ [] "cabal" no "cabal",
+		sandbox]
+	sourced = option_ [] "src" no "source files"
+	standaloned = option_ [] "stand" no "standalone files"
+	status = option_ ['s'] "status" no "show status of operation, works only with --wait"
+	wait = option_ ['w'] "wait" no "wait for operation to complete"
 
 	-- ping server
-	ping' _ copts = return $ ResultOk $ ResultString "pong"
+	ping' _ copts = return $ ResultOk $ ResultMap $ M.singleton "message" (ResultString "pong")
 	-- add data
 	add' as _ copts = do
 		dbval <- getDb copts
 		res <- runErrorT $ do
-			jsonData <- maybe (throwError $ err "Specify --data") return $ askOpt "data" as
+			jsonData <- maybe (throwError $ err "Specify --data") return $ arg "data" as
 			decodedData <- either
 				(\err -> throwError (errArgs "Unable to decode data" [
 					("why", ResultString err),
@@ -512,20 +574,20 @@ 		return $ either id (const (ResultOk ResultNone)) res
 	-- scan
 	scan' as _ copts = updateProcess copts as $
-		mapM_ (\(n, f) -> forM_ (askOpts n as) (canonicalizePath' copts >=> f (getGhcOpts as))) [
+		mapM_ (\(n, f) -> forM_ (list n as) (findPath copts >=> f (list "ghc" as))) [
 			("project", Update.scanProject),
 			("file", Update.scanFile),
 			("path", Update.scanDirectory)]
 	-- scan cabal
 	scanCabal' as _ copts = error_ $ do
-		cabal <- getCabal copts as
-		lift $ updateProcess copts as $ Update.scanCabal (getGhcOpts as) cabal
+		cabals <- getSandboxes copts as
+		lift $ updateProcess copts as $ mapM_ (Update.scanCabal $ list "ghc" as) cabals
 	-- scan cabal module
 	scanModule' as [] copts = return $ err "Module name not specified"
 	scanModule' as ms copts = error_ $ do
 		cabal <- getCabal copts as
 		lift $ updateProcess copts as $
-			forM_ ms (Update.scanModule (getGhcOpts as) . CabalModule cabal Nothing)
+			forM_ ms (Update.scanModule (list "ghc" as) . CabalModule cabal Nothing)
 	-- rescan
 	rescan' as _ copts = do
 		dbval <- getDb copts
@@ -534,21 +596,22 @@ 				selectModules (byFile . moduleId) dbval
 
 		(errors, filteredMods) <- liftM partitionEithers $ mapM runErrorT $ concat [
-			do
-				p <- askOpts "project" as
-				return $ do
-					p' <- getProject copts p
-					return $ M.fromList $ mapMaybe toPair $
-						selectModules (inProject p' . moduleId) dbval,
-			do
-				f <- askOpts "file" as
-				return $ maybe
-					(throwError $ "Unknown file: " ++ f)
-					(return . M.singleton f)
-					(lookupFile f dbval),
-			do
-				d <- askOpts "path" as
-				return $ return $ M.filterWithKey (\f _ -> isParent d f) fileMap]
+			[do
+				p' <- findProject copts p
+				return $ M.fromList $ mapMaybe toPair $
+					selectModules (inProject p' . moduleId) dbval |
+				p <- list "project" as],
+			[do
+				f' <- findPath copts f
+				maybe
+					(throwError $ "Unknown file: " ++ f')
+					(return . M.singleton f')
+					(lookupFile f' dbval) |
+				f <- list "file" as],
+			[do
+				d' <- findPath copts d
+				return $ M.filterWithKey (\f _ -> isParent d' f) fileMap |
+				d <- list "path" as]]
 		let
 			rescanMods = map (getInspected dbval) $
 				M.elems $ if null filteredMods then fileMap else M.unions filteredMods
@@ -556,22 +619,22 @@ 		if not (null errors)
 			then return $ err $ intercalate ", " errors
 			else updateProcess copts as $ Update.runTask (toJSON $ ("rescanning modules" :: String)) $ do
-				needRescan <- Update.liftErrorT $ filterM (changedModule dbval (getGhcOpts as) . inspectedId) rescanMods
-				Update.scanModules (getGhcOpts as) (map (inspectedId &&& inspectionOpts . inspection) needRescan)
+				needRescan <- Update.liftErrorT $ filterM (changedModule dbval (list "ghc" as) . inspectedId) rescanMods
+				Update.scanModules (list "ghc" as) (map (inspectedId &&& inspectionOpts . inspection) needRescan)
 	-- remove
 	remove' as _ copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		cabal <- askCabal copts as
-		proj <- askProject copts as
-		file <- traverse (canonicalizePath' copts) $ askOpt "file" as
+		dbval <- getDb copts
+		cabal <- getCabal_ copts as
+		proj <- traverse (findProject copts) $ arg "project" as
+		file <- traverse (findPath copts) $ arg "file" as
 		let
-			cleanAll = hasOpt "all" as
+			cleanAll = flag "all" as
 			filters = catMaybes [
 				fmap inProject proj,
 				fmap inFile file,
-				fmap inModule (askOpt "module" as),
-				fmap inPackage (askOpt "package" as),
-				fmap inVersion (askOpt "version" as),
+				fmap inModule (arg "module" as),
+				fmap inPackage (arg "package" as),
+				fmap inVersion (arg "version" as),
 				fmap inCabal cabal]
 			toClean = newest as $ filter (allOf filters . moduleId) (allModules dbval)
 			action
@@ -586,16 +649,20 @@ 		action
 	-- list modules
 	listModules' as _ copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		proj <- askProject copts as
-		cabal <- askCabal copts as
+		dbval <- getDb copts
+		projs <- traverse (findProject copts) $ list "project" as
+		cabals <- getSandboxes copts as
 		let
+			packages = list "package" as
+			hasFilters = not $ null projs && null packages && null cabals
 			filters = allOf $ catMaybes [
-				fmap inProject proj,
-				fmap inPackage (askOpt "package" as),
-				fmap inCabal cabal,
-				if hasOpt "src" as then Just byFile else Nothing,
-				if hasOpt "stand" as then Just standalone else Nothing]
+				if hasFilters
+					then Just $ anyOf [
+						\m -> any (`inProject` m) projs,
+						\m -> any (`inPackage` m) packages && any (`inCabal` m) cabals]
+					else Nothing,
+				if flag "src" as then Just byFile else Nothing,
+				if flag "stand" as then Just standalone else Nothing]
 		return $ ResultList $ map (ResultModuleId . moduleId) $ newest as $ selectModules (filters . moduleId) dbval
 	-- list packages
 	listPackages' _ copts = do
@@ -610,20 +677,20 @@ 		return $ ResultOk $ ResultList $ map ResultProject $ M.elems $ databaseProjects dbval
 	-- get symbol info
 	symbol' as ns copts = errorT $ do
-		dbval <- liftM (localsDatabase as) $ liftIO $ getDb copts
-		proj <- askProject copts as
-		file <- traverse (canonicalizePath' copts) $ askOpt "file" as
-		cabal <- askCabal copts as
+		dbval <- liftM (localsDatabase as) $ getDb copts
+		proj <- traverse (findProject copts) $ arg "project" as
+		file <- traverse (findPath copts) $ arg "file" as
+		cabal <- getCabal_ copts as
 		let
 			filters = checkModule $ allOf $ catMaybes [
 				fmap inProject proj,
 				fmap inFile file,
-				fmap inModule (askOpt "module" as),
-				fmap inPackage (askOpt "package" as),
-				fmap inVersion (askOpt "version" as),
+				fmap inModule (arg "module" as),
+				fmap inPackage (arg "package" as),
+				fmap inVersion (arg "version" as),
 				fmap inCabal cabal,
-				if hasOpt "src" as then Just byFile else Nothing,
-				if hasOpt "stand" as then Just standalone else Nothing]
+				if flag "src" as then Just byFile else Nothing,
+				if flag "stand" as then Just standalone else Nothing]
 			toResult = ResultList . map ResultModuleDeclaration . newest as . filterMatch as . filter filters
 		case ns of
 			[] -> return $ toResult $ allDeclarations dbval
@@ -632,62 +699,61 @@ 			_ -> throwError "Too much arguments"
 	-- get module info
 	modul' as _ copts = errorT' $ do
-		dbval <- liftM (localsDatabase as) $ liftIO $ getDb copts
-		proj <- mapErrorT (fmap $ strMsg +++ id) $ askProject copts as
-		cabal <- mapErrorT (fmap $ strMsg +++ id) $ askCabal copts as
-		file' <- traverse (canonicalizePath' copts) $ askOpt "file" as
+		dbval <- liftM (localsDatabase as) $ getDb copts
+		proj <- mapErrorT (fmap $ strMsg +++ id) $ traverse (findProject copts) $ arg "project" as
+		cabal <- mapErrorT (fmap $ strMsg +++ id) $ getCabal_ copts as
+		file' <- mapErrorT (fmap $ strMsg +++ id) $ traverse (findPath copts) $ arg "file" as
 		let
 			filters = allOf $ catMaybes [
 				fmap inProject proj,
 				fmap inCabal cabal,
 				fmap inFile file',
-				fmap inModule (askOpt "module" as),
-				fmap inPackage (askOpt "package" as),
-				fmap inVersion (askOpt "version" as),
-				if hasOpt "src" as then Just byFile else Nothing]
+				fmap inModule (arg "module" as),
+				fmap inPackage (arg "package" as),
+				fmap inVersion (arg "version" as),
+				if flag "src" as then Just byFile else Nothing]
 		rs <- mapErrorT (fmap $ strMsg +++ id) $
 			(newest as . filter (filters . moduleId)) <$> maybe
 				(return $ allModules dbval)
 				(findModule dbval)
-				(askOpt "module" as)
+				(arg "module" as)
 		case rs of
 			[] -> throwError $ err "Module not found"
 			[m] -> return $ ResultModule m
 			ms' -> throwError $ errArgs "Ambiguous modules" [("modules", ResultList $ map (ResultModuleId . moduleId) ms')]
 	-- get project info
 	project' as _ copts = errorT $ do
-		proj <- askProject copts as
-		proj' <- maybe (throwError "Specify project name of .cabal file") return proj
-		return $ ResultProject proj'
+		proj <- maybe (throwError "Specify project name or .cabal file") (findProject copts) $ arg "project" as
+		return $ ResultProject proj
 	-- lookup info about symbol
 	lookup' as [nm] copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		(srcFile, cabal) <- askCtx copts as
+		dbval <- getDb copts
+		(srcFile, cabal) <- getCtx copts as
 		liftM (ResultList . map ResultModuleDeclaration) $ lookupSymbol dbval cabal srcFile nm
 	lookup' as _ copts = return $ err "Invalid arguments"
 	-- get detailed info about symbol in source file
 	whois' as [nm] copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		(srcFile, cabal) <- askCtx copts as
+		dbval <- getDb copts
+		(srcFile, cabal) <- getCtx copts as
 		liftM (ResultList . map ResultModuleDeclaration) $ whois dbval cabal srcFile nm
 	whois' as _ copts = return $ err "Invalid arguments"
 	-- get modules accessible from module
 	scopeModules' as [] copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		(srcFile, cabal) <- askCtx copts as
+		dbval <- getDb copts
+		(srcFile, cabal) <- getCtx copts as
 		liftM (ResultList . map (ResultModuleId . moduleId)) $ scopeModules dbval cabal srcFile
 	scopeModules' as _ copts = return $ err "Invalid arguments"
 	-- get declarations accessible from module
 	scope' as [] copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		(srcFile, cabal) <- askCtx copts as
-		liftM (ResultList . map ResultModuleDeclaration . filterMatch as) $ scope dbval cabal srcFile (hasOpt "global" as)
+		dbval <- getDb copts
+		(srcFile, cabal) <- getCtx copts as
+		liftM (ResultList . map ResultModuleDeclaration . filterMatch as) $ scope dbval cabal srcFile (flag "global" as)
 	scope' as _ copts = return $ err "Invalid arguments"
 	-- completion
 	complete' as [] copts = complete' as [""] copts
 	complete' as [input] copts = errorT $ do
 		dbval <- getDb copts
-		(srcFile, cabal) <- askCtx copts as
+		(srcFile, cabal) <- getCtx copts as
 		liftM (ResultList . map ResultModuleDeclaration) $ completions dbval cabal srcFile input
 	complete' as _ copts = return $ err "Invalid arguments"
 	-- hayoo
@@ -706,82 +772,84 @@ 	ghcmodType' as [line, column] copts = errorT $ do
 		line' <- maybe (throwError "line must be a number") return $ readMaybe line
 		column' <- maybe (throwError "column must be a number") return $ readMaybe column
-		dbval <- liftIO $ getDb copts
-		(srcFile, cabal) <- askCtx copts as
+		dbval <- getDb copts
+		(srcFile, cabal) <- getCtx copts as
 		(srcFile', m, mproj) <- fileCtx dbval srcFile
-		tr <- GhcMod.typeOf (getGhcOpts as) cabal srcFile' mproj (moduleName m) line' column'
+		tr <- GhcMod.typeOf (list "ghc" as) cabal srcFile' mproj (moduleName m) line' column'
 		return $ ResultList $ map ResultTyped tr
 	ghcmodType' as [] copts = return $ err "Specify line"
 	ghcmodType' as _ copts = return $ err "Too much arguments"
 	-- dump cabal modules
 	dumpCabal' as _ copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		cabal <- getCabal copts as
+		dbval <- getDb copts
+		cabals <- getSandboxes copts as
 		let
-			dat = cabalDB cabal dbval
-		liftM (fromMaybe (ResultDatabase dat)) $ runMaybeT $ msum [
-			maybeOpt "path" as $ canonicalizePath' copts >=> \p ->
-				fork (dump (p </> cabalCache cabal) dat),
-			maybeOpt "file" as $ canonicalizePath' copts >=> \f ->
-				fork (dump f dat)]
+			dats = map (id &&& flip cabalDB dbval) cabals
+		liftM (fromMaybe (ResultList $ map (ResultDatabase . snd) dats)) $
+			runMaybeT $ msum [
+				maybeOpt "path" as $ (lift . findPath copts) >=> \p ->
+					fork (forM_ dats $ \(cabal, dat) -> (dump (p </> cabalCache cabal) dat)),
+				maybeOpt "file" as $ (lift . findPath copts) >=> \f ->
+					fork (dump f $ mconcat $ map snd dats)]
 	-- dump projects
 	dumpProjects' as [] copts = errorT $ do
-		dbval <- liftIO $ getDb copts
-		ps' <- traverse (getProject copts) $ askOpts "project" as
+		dbval <- getDb copts
+		ps' <- traverse (findProject copts) $ list "project" as
 		let
 			ps = if null ps' then M.elems (databaseProjects dbval) else ps'
 			dats = map (id &&& flip projectDB dbval) ps
 		liftM (fromMaybe (ResultList $ map (ResultDatabase . snd) dats)) $
 			runMaybeT $ msum [
-				maybeOpt "path" as $ canonicalizePath' copts >=> \p ->
+				maybeOpt "path" as $ (lift . findPath copts) >=> \p ->
 					fork (forM_ dats $ \(proj, dat) -> (dump (p </> projectCache proj) dat)),
-				maybeOpt "file" as $ canonicalizePath' copts >=> \f ->
+				maybeOpt "file" as $ (lift . findPath copts) >=> \f ->
 					fork (dump f (mconcat $ map snd dats))]
 	dumpProjects' as _ copts = return $ err "Invalid arguments"
 	-- dump files
-	dumpFiles' as [] copts = do
+	dumpFiles' as [] copts = errorT $ do
 		dbval <- getDb copts
 		let
 			dat = standaloneDB dbval
-		liftM (ResultOk . fromMaybe (ResultDatabase dat)) $ runMaybeT $ msum [
-			maybeOpt "path" as $ canonicalizePath' copts >=> \p ->
+		liftM (fromMaybe $ ResultDatabase dat) $ runMaybeT $ msum [
+			maybeOpt "path" as $ (lift . findPath copts) >=> \p ->
 				fork (dump (p </> standaloneCache) dat),
-			maybeOpt "file" as $ canonicalizePath' copts >=> \f ->
+			maybeOpt "file" as $ (lift . findPath copts) >=> \f ->
 				fork (dump f dat)]
 	dumpFiles' as _ copts = return $ err "Invalid arguments"
 	-- dump database
-	dump' as _ copts = do
+	dump' as _ copts = errorT $ do
 		dbval <- getDb copts
-		liftM (fromMaybe (ResultOk $ ResultDatabase dbval)) $ runMaybeT $ msum [
+		liftM (fromMaybe $ ResultDatabase dbval) $ runMaybeT $ msum [
 			do
-				p <- MaybeT $ traverse (canonicalizePath' copts) $ askOpt "path" as
+				p <- MaybeT $ traverse (findPath copts) $ arg "path" as
 				fork $ SC.dump p $ structurize dbval
-				return ok,
+				return ResultNone,
 			do
-				f <- MaybeT $ traverse (canonicalizePath' copts) $ askOpt "file" as
+				f <- MaybeT $ traverse (findPath copts) $ arg "file" as
 				fork $ dump f dbval
-				return ok]
+				return ResultNone]
 	-- load database
 	load' as _ copts = do
 		res <- liftM (fromMaybe (err "Specify one of: --path, --file or --data")) $ runMaybeT $ msum [
 			do
-				p <- MaybeT $ return $ askOpt "path" as
+				p <- MaybeT $ return $ arg "path" as
 				forkOrWait as $ cacheLoad copts (liftA merge <$> SC.load p)
 				return ok,
 			do
-				f <- MaybeT $ return $ askOpt "file" as
+				f <- MaybeT $ return $ arg "file" as
 				e <- liftIO $ doesFileExist f
 				forkOrWait as $ when e $ cacheLoad copts (load f)
 				return ok,
 			do
-				dat <- MaybeT $ return $ askOpt "data" as
+				dat <- MaybeT $ return $ arg "data" as
 				forkOrWait as $ cacheLoad copts (return $ eitherDecode (toUtf8 dat))
 				return ok]
 		waitDb copts as
 		return res
 	-- link to server
 	link' as _ copts = do
-		race [void (commandWaitInput copts) `finally` commandExit copts, commandLink copts]
+		commandLink copts
+		when (flag "hold" as) $ commandHold copts
 		return ok
 	-- exit
 	exit' _ copts = do
@@ -789,18 +857,63 @@ 		return ok
 
 	-- Helper functions
-	cmd' :: [String] -> [String] -> String -> [OptDescr Opts] -> (Opts -> [String] -> a) -> Command (WithOpts a)
+	cmd' :: [String] -> [String] -> String -> [OptDescr (Opts String)] -> (Opts String -> [String] -> a) -> Command (WithOpts a)
 	cmd' name posArgs descr as act = cmd name posArgs descr as act' where
-		act' os args = WithOpts (act os args) $
-			return $ name ++ args ++ optsToArgs os
+		act' os args = WithOpts (act os args) $ CommandCall name args os
 
 	cmd_' :: [String] -> [String] -> String -> ([String] -> a) -> Command (WithOpts a)
 	cmd_' name posArgs descr act = cmd_ name posArgs descr act' where
-		act' args = WithOpts (act args) $
-			return $ name ++ args ++ optsToArgs defaultConfig
+		act' args = WithOpts (act args) $ CommandCall name args defaultConfig
 
-	getGhcOpts = askOpts "ghc"
+	findSandbox :: MonadIO m => CommandOptions -> Maybe FilePath -> ErrorT String m Cabal
+	findSandbox copts = maybe
+		(return Cabal)
+		(findPath copts >=> mapErrorT liftIO . locateSandbox)
 
+	findPath :: MonadIO m => CommandOptions -> FilePath -> ErrorT String m FilePath
+	findPath copts f = liftIO $ canonicalizePath (normalise f') where
+		f'
+			| isRelative f = commandRoot copts </> f
+			| otherwise = f
+
+	getCtx :: (MonadIO m, Functor m) => CommandOptions -> Opts String -> ErrorT String m (FilePath, Cabal)
+	getCtx copts as = liftM2 (,)
+		(forceJust "No file specified" $ traverse (findPath copts) $ arg "file" as)
+		(getCabal copts as)
+
+	getCabal :: MonadIO m => CommandOptions -> Opts String -> ErrorT String m Cabal
+	getCabal copts as
+		| flag "cabal" as = findSandbox copts Nothing
+		| otherwise  = findSandbox copts $ arg "sandbox" as
+
+	getCabal_ :: (MonadIO m, Functor m) => CommandOptions -> Opts String -> ErrorT String m (Maybe Cabal)
+	getCabal_ copts as
+		| flag "cabal" as = Just <$> findSandbox copts Nothing
+		| otherwise = case arg "sandbox" as of
+			Just f -> Just <$> findSandbox copts (Just f)
+			Nothing -> return Nothing
+
+	getSandboxes :: (MonadIO m, Functor m) => CommandOptions -> Opts String -> ErrorT String m [Cabal]
+	getSandboxes copts as = traverse (findSandbox copts) paths where
+		paths
+			| flag "cabal" as = Nothing : sboxes
+			| otherwise = sboxes
+		sboxes = map Just $ list "sandbox" as
+
+	findProject :: MonadIO m => CommandOptions -> String -> ErrorT String m Project
+	findProject copts proj = do
+		db' <- getDb copts
+		proj' <- liftM addCabal $ findPath copts proj
+		let
+			result =
+				M.lookup proj' (databaseProjects db') <|>
+				find ((== proj) . projectName) (M.elems $ databaseProjects db')
+		maybe (throwError $ "Projects " ++ proj ++ " not found") return result
+		where
+			addCabal p
+				| takeExtension p == ".cabal" = p
+				| otherwise = p </> (takeBaseName p <.> "cabal")
+
 	toPair :: Module -> Maybe (FilePath, Module)
 	toPair m = case moduleLocation m of
 		FileModule f _ -> Just (f, m)
@@ -811,13 +924,13 @@ 		CabalModule c _ _ -> Just c
 		_ -> Nothing
 
-	waitDb copts as = when (hasOpt "wait" as) $ do
+	waitDb copts as = when (flag "wait" as) $ do
 		commandLog copts "wait for db"
 		DB.wait (dbVar copts)
 		commandLog copts "db done"
 
 	forkOrWait as act
-		| hasOpt "wait" as = liftIO act
+		| flag "wait" as = liftIO act
 		| otherwise = liftIO $ void $ forkIO act
 
 	cacheLoad copts act = do
@@ -826,76 +939,33 @@ 			Left e -> commandLog copts e
 			Right database -> DB.update (dbVar copts) (return database)
 
-	asCabal :: CommandOptions -> Maybe FilePath -> ErrorT String IO Cabal
-	asCabal copts = maybe
-		(return Cabal)
-		(canonicalizePath' copts >=> locateSandbox)
-
-	askCabal :: CommandOptions -> Opts -> ErrorT String IO (Maybe Cabal)
-	askCabal copts as = traverse (asCabal copts) $ askOptDef "sandbox" as
-
-	getCabal :: CommandOptions -> Opts -> ErrorT String IO Cabal
-	getCabal copts as = asCabal copts $ askOpt "sandbox" as
-
-	getProject :: CommandOptions -> String -> ErrorT String IO Project
-	getProject copts proj = do
-		db' <- getDb copts
-		proj' <- liftM addCabal $ canonicalizePath' copts proj
-		let
-			result =
-				M.lookup proj' (databaseProjects db') <|>
-				find ((== proj) . projectName) (M.elems $ databaseProjects db')
-		maybe (throwError $ "Project " ++ proj ++ " not found") return result
-		where
-			addCabal p
-				| takeExtension p == ".cabal" = p
-				| otherwise = p </> (takeBaseName p <.> "cabal")
-
-	localsDatabase :: Opts -> Database -> Database
+	localsDatabase :: Opts String -> Database -> Database
 	localsDatabase as
-		| hasOpt "locals" as = databaseLocals
+		| flag "locals" as = databaseLocals
 		| otherwise = id
 
-	newest :: Symbol a => Opts -> [a] -> [a]
+	newest :: Symbol a => Opts String -> [a] -> [a]
 	newest as
-		| hasOpt "no-last" as = id
+		| flag "no-last" as = id
 		| otherwise = newestPackage
 
-	askProject :: CommandOptions -> Opts -> ErrorT String IO (Maybe Project)
-	askProject copts = traverse (getProject copts) . askOpt "project"
-
-	askFile :: CommandOptions -> Opts -> ErrorT String IO (Maybe FilePath)
-	askFile copts = traverse (canonicalizePath' copts) . askOpt "file"
-
-	forceJust :: String -> ErrorT String IO (Maybe a) -> ErrorT String IO a
+	forceJust :: MonadIO m => String -> ErrorT String m (Maybe a) -> ErrorT String m a
 	forceJust msg act = act >>= maybe (throwError msg) return
 
-	askCtx :: CommandOptions -> Opts -> ErrorT String IO (FilePath, Cabal)
-	askCtx copts as = liftM2 (,)
-		(forceJust "No file specified" $ askFile copts as)
-		(getCabal copts as)
-
 	getDb :: (MonadIO m) => CommandOptions -> m Database
 	getDb = liftIO . DB.readAsync . commandDatabase
 
 	dbVar :: CommandOptions -> DB.Async Database
 	dbVar = commandDatabase
 
-	canonicalizePath' :: MonadIO m => CommandOptions -> FilePath -> m FilePath
-	canonicalizePath' copts f = liftIO $ canonicalizePath (normalise f') where
-		f'
-			| isRelative f = commandRoot copts </> f
-			| otherwise = f
-
-	startProcess :: Opts -> ((Value -> IO ()) -> IO ()) -> IO CommandResult
+	startProcess :: Opts String -> ((Update.Status -> IO ()) -> IO ()) -> IO CommandResult
 	startProcess as f
-		| hasOpt "wait" as = return $ ResultProcess (f . onMsg)
+		| flag "wait" as = return $ ResultProcess (f . onMsg)
 		| otherwise = forkIO (f $ const $ return ()) >> return ok
 		where
 			onMsg showMsg
-				| hasOpt "status" as = showMsg
+				| flag "status" as = showMsg
 				| otherwise = const $ return ()
-
 	error_ :: ErrorT String IO CommandResult -> IO CommandResult
 	error_ = liftM (either err id) . runErrorT
 
@@ -905,8 +975,15 @@ 	errorT' :: ErrorT CommandResult IO ResultValue -> IO CommandResult
 	errorT' = liftM (either id ResultOk) . runErrorT
 
-	updateProcess :: CommandOptions -> Opts -> ErrorT String (Update.UpdateDB IO) () -> IO CommandResult
-	updateProcess opts as act = startProcess as $ \onStatus -> Update.updateDB (Update.Settings (commandDatabase opts) (commandReadCache opts) onStatus (getGhcOpts as)) act
+	updateProcess :: CommandOptions -> Opts String -> ErrorT String (Update.UpdateDB IO) () -> IO CommandResult
+	updateProcess opts as act = startProcess as $ \onStatus ->
+		Update.updateDB
+			(Update.Settings
+				(commandDatabase opts)
+				(commandReadCache opts)
+				onStatus
+				(list "ghc" as))
+			act
 
 	fork :: MonadIO m => IO () -> m ()
 	fork = voidm . liftIO . forkIO
@@ -914,24 +991,24 @@ 	voidm :: Monad m => m a -> m ()
 	voidm act = act >> return ()
 
-	maybeOpt :: Monad m => String -> Opts -> (String -> MaybeT m a) -> MaybeT m ResultValue
+	maybeOpt :: Monad m => String -> Opts String -> (String -> MaybeT m a) -> MaybeT m ResultValue
 	maybeOpt n as act = do
-		p <- MaybeT $ return $ askOpt n as
+		p <- MaybeT $ return $ arg n as
 		act p
 		return ResultNone
 
-	filterMatch :: Opts -> [ModuleDeclaration] -> [ModuleDeclaration]
+	filterMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration]
 	filterMatch as = findMatch as . prefMatch as
 
-	findMatch :: Opts -> [ModuleDeclaration] -> [ModuleDeclaration]
-	findMatch as = case askOpt "find" as of
+	findMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration]
+	findMatch as = case arg "find" as of
 		Nothing -> id
 		Just str -> filter (match' str)
 		where
 			match' str m = str `isInfixOf` declarationName (moduleDeclaration m)
 
-	prefMatch :: Opts -> [ModuleDeclaration] -> [ModuleDeclaration]
-	prefMatch as = case fmap splitIdentifier (askOpt "prefix" as) of
+	prefMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration]
+	prefMatch as = case fmap splitIdentifier (arg "prefix" as) of
 		Nothing -> id
 		Just (qname, pref) -> filter (match' qname pref)
 		where
@@ -979,3 +1056,18 @@ 	where
 		ignoreError :: SomeException -> IO ()
 		ignoreError _ = return ()
+
+logIO :: String -> (String -> IO ()) -> IO () -> IO ()
+logIO pre out act = handle onIO act where
+	onIO :: IOException -> IO ()
+	onIO e = out $ pre ++ show e
+
+ignoreIO :: IO () -> IO ()
+ignoreIO = handle (const (return ()) :: IOException -> IO ())
+
+logMsg :: ServerOpts -> String -> IO ()
+logMsg sopts s = ignoreIO $ do
+	putStrLn s
+	case getFirst (serverLog sopts) of
+		Nothing -> return ()
+		Just f -> withFile f AppendMode (`hPutStrLn` s)

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, DefaultSignatures, FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, DefaultSignatures, FlexibleInstances, TupleSections #-}
 
 module System.Command (
 	Command(..),
@@ -7,26 +7,38 @@ 	Help(..), addHelpCommand, addHelp,
 	brief, help,
 	run, runCmd,
+	OptionValue(..),
 	Opts(..),
-	mapOpts, traverseOpts,
-	option, option_, req, noreq, flag,
-	opt, optMaybe, hasOpt, askOpt, askOptDef, askOpts,
-	optsToArgs,
+	(%--), hoist,
+	option, option_,
+	has,
+	req, noreq, no,
+	arg, opt, def, list, flag,
+	toArgs,
 	splitArgs, unsplitArgs
 	) where
 
 import Control.Arrow
 import Control.Applicative
-import Control.Monad (join)
+import Control.Monad (join, (>=>))
+import Data.Aeson
 import Data.Char
+import qualified Data.HashMap.Strict as HM (HashMap, toList)
+import Data.String
 import Data.List (stripPrefix, unfoldr, isPrefixOf)
-import Data.Maybe (fromMaybe, mapMaybe, listToMaybe, maybeToList)
+import Data.Maybe (fromMaybe, mapMaybe, listToMaybe, maybeToList, isJust)
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Monoid
-import Data.Traversable (traverse)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Foldable (Foldable(foldMap))
+import Data.Traversable (Traversable(traverse))
+import qualified Data.Vector as V
 import System.Console.GetOpt
 
+import Data.Group
+
 -- | Command
 data Command a = Command {
 	commandName :: [String],
@@ -116,67 +128,114 @@ 	toMaybe :: Either b c -> Maybe c
 	toMaybe = either (const Nothing) Just
 
+-- | Convertible to option value
+class OptionValue a where
+	toOption :: a -> String
+	default toOption :: Show a => a -> String
+	toOption = show
+
+instance OptionValue String where
+	toOption = id
+
+instance OptionValue Int
+instance OptionValue Integer
+instance OptionValue Float
+instance OptionValue Double
+instance OptionValue Bool
+
 -- | Options holder
-newtype Opts = Opts { getOpts :: Map String [String] }
+newtype Opts a = Opts { getOpts :: Map String [a] }
 
-instance Monoid Opts where
+instance Eq a => Eq (Opts a) where
+	Opts l == Opts r = l == r
+
+instance Functor Opts where
+	fmap f (Opts opts) = Opts $ fmap (fmap f) opts
+
+instance Foldable Opts where
+	foldMap f (Opts opts) = foldMap (foldMap f) opts
+
+instance Traversable Opts where
+	traverse f (Opts opts) = Opts <$> traverse (traverse f) opts
+
+instance Monoid (Opts a) where
 	mempty = Opts mempty
-	(Opts l) `mappend` (Opts r) = Opts $ M.unionWith (++) l r
+	(Opts l) `mappend` (Opts r) = Opts $ M.unionWith mappend l r
 
-instance DefaultConfig Opts
+instance Eq a => Group (Opts a) where
+	add = mappend
+	(Opts l) `sub` (Opts r) = Opts $ l `sub` r
+	zero = mempty
 
--- | Map 'Opts'
-mapOpts :: (String -> String) -> Opts -> Opts
-mapOpts f = Opts . M.mapKeys f . getOpts
+instance DefaultConfig (Opts a)
 
--- | Traverse 'Opts'
-traverseOpts :: Applicative f => (String -> String -> f String) -> Opts -> f Opts
-traverseOpts f = fmap Opts . M.traverseWithKey (traverse . f) . getOpts
+instance ToJSON a => ToJSON (Opts a) where
+	toJSON (Opts opts) = object $ map toPair $ M.toList opts where
+		toPair (n, []) = fromString n .= Null
+		toPair (n, [v]) = fromString n .= v
+		toPair (n, vs) = fromString n .= vs
 
-option :: [Char] -> String -> [String] -> (String -> ArgDescr Opts) -> String -> OptDescr Opts
-option fs name names onOption d = Option fs (name:names) (onOption name) d
+instance FromJSON a => FromJSON (Opts a) where
+	parseJSON = withObject "options" $ fmap (Opts . M.fromList) . mapM fromPair . HM.toList where
+		fromPair (n, v) = (T.unpack n,) <$> case v of
+			Null -> return []
+			_ -> (return <$> parseJSON v) <|> parseJSON v
 
-option_ :: [Char] -> String -> (String -> ArgDescr Opts) -> String -> OptDescr Opts
+-- | Make 'Opts' with one argument
+(%--) :: OptionValue a => String -> a -> Opts String
+n %-- v = Opts $ M.singleton n [toOption v]
+
+-- | Make 'Opts' with flag enabled
+hoist :: String -> Opts a
+hoist n = Opts $ M.singleton n []
+
+option :: [Char] -> String -> [String] -> (String -> ArgDescr (Opts a)) -> String -> OptDescr (Opts a)
+option fs name names onOpt d = Option fs (name:names) (onOpt name) d
+
+option_ :: [Char] -> String -> (String -> ArgDescr (Opts a)) -> String -> OptDescr (Opts a)
 option_ fs name = option fs name []
 
--- | Required option
-req :: String -> String -> ArgDescr Opts
-req nm n = ReqArg (opt n) nm
+has :: String -> Opts a -> Bool
+has n = M.member n . getOpts
 
--- | Optional option
-noreq :: String -> String -> ArgDescr Opts
-noreq nm n = OptArg (optMaybe n) nm
+-- | Required option
+req :: String -> String -> ArgDescr (Opts String)
+req nm n = ReqArg (n %--) nm
 
--- | Flag option
-flag :: String -> ArgDescr Opts
-flag n = NoArg flag' where
-	flag' :: Opts
-	flag' = Opts $ M.singleton n []
+-- | Not required option
+noreq :: String -> String -> ArgDescr (Opts String)
+noreq nm n = OptArg (maybe (hoist n) (n %--)) nm
 
-opt :: String -> String -> Opts
-opt n v = Opts $ M.singleton n [v]
+-- | No option
+no :: String -> ArgDescr (Opts String)
+no = NoArg . hoist
 
-optMaybe :: String -> Maybe String -> Opts
-optMaybe n = Opts . M.singleton n . maybeToList
+-- | Get argument
+arg :: String -> Opts a -> Maybe a
+arg n = M.lookup n . getOpts >=> listToMaybe
 
-hasOpt :: String -> Opts -> Bool
-hasOpt n = M.member n . getOpts
+-- | Get optional argument
+opt :: String -> Opts a -> Maybe (Maybe a)
+opt n = fmap listToMaybe . M.lookup n . getOpts
 
-askOpt :: String -> Opts -> Maybe String
-askOpt n = listToMaybe . askOpts n
+-- | Get argument with default
+def :: a -> String -> Opts a -> Maybe a
+def d n = fmap (fromMaybe d . listToMaybe) . M.lookup n . getOpts
 
-askOptDef :: String -> Opts -> Maybe (Maybe String)
-askOptDef n = fmap listToMaybe . M.lookup n . getOpts
+-- | Get list arguments
+list :: String -> Opts a -> [a]
+list n = fromMaybe [] . M.lookup n . getOpts
 
-askOpts :: String -> Opts -> [String]
-askOpts n = fromMaybe [] . M.lookup n . getOpts
+-- | Get flag
+flag :: String -> Opts a -> Bool
+flag n = isJust . M.lookup n . getOpts
 
 -- | Print 'Opts' as args
-optsToArgs :: Opts -> [String]
-optsToArgs = concatMap optToArgs . M.toList . getOpts where
-	optToArgs :: (String, [String]) -> [String]
-	optToArgs (n, []) = ["--" ++ n]
-	optToArgs (n, vs) = ["--"++ n ++ "=" ++ v | v <- vs]
+toArgs :: Opts String -> [String]
+toArgs = concatMap toArgs' . M.toList . getOpts where
+	toArgs' :: (String, [String]) -> [String]
+	toArgs' (n, []) = ["--" ++ n]
+	toArgs' (n, vs) = [concat ["--", n, "=", v] | v <- vs]
 
 -- | Split string to words
 splitArgs :: String -> [String]

@@ -48,12 +48,12 @@ usage toolName = mapM_ (putStrLn . ('\t':) . ((toolName ++ " ") ++) . brief)
 
 -- | Command with JSONable result
-jsonCmd :: ToJSON a => [String] -> [String] -> String -> [OptDescr Opts] -> (Opts -> [String] -> ToolM a) -> Command (IO ())
+jsonCmd :: ToJSON a => [String] -> [String] -> String -> [OptDescr (Opts String)] -> (Opts String -> [String] -> ToolM a) -> Command (IO ())
 jsonCmd name posArgs descr as act = cmd name posArgs descr (prettyOpt : as) $ \opts as -> do
 	r <- runErrorT $ act opts as
 	L.putStrLn $ either (toStr opts . errorStr) (toStr opts) r
 	where
-		toStr :: ToJSON a => Opts -> a -> L.ByteString
+		toStr :: ToJSON a => Opts String -> a -> L.ByteString
 		toStr opts
 			| isPretty opts = encodePretty
 			| otherwise = encode
@@ -69,8 +69,8 @@ toolError :: String -> ToolM a
 toolError = throwError
 
-prettyOpt :: OptDescr Opts
-prettyOpt = option_ [] "pretty" flag "pretty JSON output"
+prettyOpt :: OptDescr (Opts String)
+prettyOpt = option_ [] "pretty" no "pretty JSON output"
 
-isPretty :: Opts -> Bool
-isPretty = hasOpt "pretty"
+isPretty :: Opts String -> Bool
+isPretty = flag "pretty"

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, CPP #-}
 
 module Types (
 	-- * Server options
@@ -8,7 +8,7 @@ 	-- * Messages and results
 	ResultValue(..), Response(..),
 	CommandResult(..), ok, err, errArgs, details,
-	WithOpts(..),
+	CommandCall(..), callArgs, addCallOpts, removeCallOpts, WithOpts(..),
 	CommandOptions(..), CommandAction
 	) where
 
@@ -16,6 +16,7 @@ import Control.Monad.Error
 import Data.Aeson
 import Data.Map (Map)
+import Data.Maybe (fromMaybe)
 import Data.Monoid
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map as M
@@ -27,16 +28,23 @@ import HsDev.Symbols
 import HsDev.Tools.GhcMod (TypedRegion)
 import qualified HsDev.Database.Async as DB
+import HsDev.Util ((.::), (.::?))
 
 import System.Command
+import Update
 
+#if mingw32_HOST_OS
+import System.Win32.FileMapping.NamePool (Pool)
+#endif
+
 -- | Server options
 data ServerOpts = ServerOpts {
 	serverPort :: First Int,
 	serverTimeout :: First Int,
 	serverLog :: First String,
 	serverCache :: First FilePath,
-	serverLoadCache :: Any }
+	serverLoadCache :: Any,
+	serverAsClient :: Any }
 
 instance DefaultConfig ServerOpts where
 	defaultConfig = ServerOpts
@@ -45,15 +53,17 @@ 		(First Nothing)
 		(First Nothing)
 		mempty
+		mempty
 
 instance Monoid ServerOpts where
-	mempty = ServerOpts mempty mempty mempty mempty mempty
+	mempty = ServerOpts mempty mempty mempty mempty mempty mempty
 	l `mappend` r = ServerOpts
 		(serverPort l `mappend` serverPort r)
 		(serverTimeout l `mappend` serverTimeout r)
 		(serverLog l `mappend` serverLog r)
 		(serverCache l `mappend` serverCache r)
 		(serverLoadCache l `mappend` serverLoadCache r)
+		(serverAsClient l `mappend` serverAsClient r)
 
 -- | Server options command opts
 serverOpts :: [OptDescr ServerOpts]
@@ -62,7 +72,8 @@ 	Option [] ["timeout"] (ReqArg (\t -> mempty { serverTimeout = First (readMaybe t) }) "msec") "query timeout",
 	Option ['l'] ["log"] (ReqArg (\l -> mempty { serverLog = First (Just l) }) "file") "log file",
 	Option [] ["cache"] (ReqArg (\p -> mempty { serverCache = First (Just p) }) "path") "cache directory",
-	Option [] ["load"] (NoArg (mempty { serverLoadCache = Any True })) "force load all data from cache on startup"]
+	Option [] ["load"] (NoArg (mempty { serverLoadCache = Any True })) "force load all data from cache on startup",
+	Option ['c'] ["as-client"] (NoArg (mempty { serverAsClient = Any True })) "make server be client and connect to port specified"]
 
 -- | Convert 'ServerOpts' to args
 serverOptsToArgs :: ServerOpts -> [String]
@@ -71,7 +82,8 @@ 	arg' "timeout" show $ serverTimeout sopts,
 	arg' "log" id $ serverLog sopts,
 	arg' "cache" id $ serverCache sopts,
-	if getAny (serverLoadCache sopts) then ["--load"] else []]
+	if getAny (serverLoadCache sopts) then ["--load"] else [],
+	if getAny (serverAsClient sopts) then ["--as-client"] else []]
 	where
 		arg' :: String -> (a -> String) -> First a -> [String]
 		arg' name str = maybe [] (\v -> ["--" ++ name, str v]) . getFirst
@@ -151,25 +163,25 @@ 		ResultString <$> parseJSON v]
 
 data Response =
-	Response Value |
-	ResponseStatus Value |
-	ResponseMapFile String
+	ResponseStatus Status |
+	ResponseMapFile String |
+	Response Value
 
 instance ToJSON Response where
-	toJSON (Response v) = object ["result" .= v]
-	toJSON (ResponseStatus v) = object ["status" .= v]
+	toJSON (ResponseStatus s) = toJSON s
 	toJSON (ResponseMapFile s) = object ["file" .= s]
+	toJSON (Response v) = v
 
 instance FromJSON Response where
-	parseJSON = withObject "response" (\v ->
-		(Response <$> (v .: "result")) <|>
-		(ResponseStatus <$> (v .: "status")) <|>
-		(ResponseMapFile <$> (v .: "file")))
+	parseJSON v = foldr1 (<|>) [
+		ResponseStatus <$> parseJSON v,
+		withObject "response" (\f -> (ResponseMapFile <$> (f .:: "file"))) v,
+		pure $ Response v]
 
 data CommandResult =
 	ResultOk ResultValue |
 	ResultError String (Map String ResultValue) |
-	ResultProcess ((Value -> IO ()) -> IO ())
+	ResultProcess ((Status -> IO ()) -> IO ())
 
 instance Error CommandResult where
 	noMsg = ResultError noMsg mempty
@@ -189,9 +201,43 @@ details as (ResultError s cs) = ResultError s (M.union (M.fromList as) cs)
 details _ r = r
 
+data CommandCall = CommandCall {
+	commandCallName :: [String],
+	commandCallPosArgs :: [String],
+	commandCallOpts :: Opts String }
+
+instance ToJSON CommandCall where
+	toJSON (CommandCall n ps opts) = object [
+		"command" .= n,
+		"args" .= ps,
+		"opts" .= opts]
+
+instance FromJSON CommandCall where
+	parseJSON = withObject "command call" $ \v -> CommandCall <$>
+		(v .:: "command") <*>
+		(fromMaybe [] <$> (v .::? "args")) <*>
+		(fromMaybe mempty <$> (v .::? "opts"))
+
+callArgs :: CommandCall -> [String]
+callArgs (CommandCall n ps opts) = n ++ ps ++ toArgs opts
+
+-- | Add options
+--
+-- >cmdCall `addCallOpts` ["foo" %-- 15]
+addCallOpts :: CommandCall -> [Opts String] -> CommandCall
+addCallOpts cmdCall os = cmdCall {
+	commandCallOpts = mconcat (commandCallOpts cmdCall : os) }
+
+-- | Remove specified call options
+--
+-- >cmdCall `removeCallOpts` ["foo"]
+removeCallOpts :: CommandCall -> [String] -> CommandCall
+removeCallOpts cmdCall os = cmdCall {
+	commandCallOpts = Opts $ foldr (.) id (map M.delete os) $ getOpts (commandCallOpts cmdCall) }
+
 data WithOpts a = WithOpts {
 	withOptsAct :: a,
-	withOptsArgs :: IO [String] }
+	withOptsCommand :: CommandCall }
 
 instance Functor WithOpts where
 	fmap f (WithOpts x as) = WithOpts (f x) as
@@ -202,8 +248,12 @@ 	commandReadCache :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database),
 	commandRoot :: FilePath,
 	commandLog :: String -> IO (),
-	commandWaitInput :: IO String,
+	commandLogWait :: IO (),
+#if mingw32_HOST_OS
+	commandMmapPool :: Maybe Pool,
+#endif
 	commandLink :: IO (),
+	commandHold :: IO (),
 	commandExit :: IO () }
 
 type CommandAction = WithOpts (Int -> CommandOptions -> IO CommandResult)

@@ -1,13 +1,14 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings, MultiParamTypeClasses #-}
 
 module Update (
+	Status(..), isStatus,
 	Settings(..),
 
 	UpdateDB,
 	updateDB,
 
-	setStatus, waiter, updater, loadCache, runTask, runTasks,
-	status, readDB,
+	setStatus, postStatus, waiter, updater, loadCache, runTask, runTasks,
+	readDB,
 
 	scanModule, scanModules, scanFile, scanCabal, scanProject, scanDirectory,
 
@@ -15,15 +16,16 @@ 	liftErrorT
 	) where
 
-import Control.Applicative (Applicative(..))
+import Control.Applicative
 import Control.Monad.CatchIO
 import Control.Monad.Error
 import Control.Monad.Reader
 import Data.Aeson
+import Data.Aeson.Types
 import qualified Data.HashMap.Strict as HM
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, isJust)
 import Data.Monoid
 import Data.Traversable (traverse)
 import System.Directory (canonicalizePath)
@@ -36,11 +38,25 @@ import HsDev.Tools.HDocs
 import qualified HsDev.Scan as S
 import HsDev.Scan.Browse
+import HsDev.Util ((.::))
 
+data Status = Status {
+	status :: Value,
+	statusDetails :: [Pair] }
+
+instance ToJSON Status where
+	toJSON (Status s ds) = object $ ("status" .= s) : ds
+
+instance FromJSON Status where
+	parseJSON = withObject "status" $ \v -> Status <$> (v .:: "status") <*> pure (HM.toList $ HM.delete "status" v)
+
+isStatus :: Value -> Bool
+isStatus = isJust . parseMaybe (parseJSON :: Value -> Parser Status)
+
 data Settings = Settings {
 	database :: Async Database,
 	databaseCacheReader :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database),
-	onStatus :: Value -> IO (),
+	onStatus :: Status -> IO (),
 	ghcOptions :: [String] }
 
 newtype UpdateDB m a = UpdateDB { runUpdateDB :: ReaderT Settings m a }
@@ -50,12 +66,18 @@ updateDB :: Monad m => Settings -> ErrorT String (UpdateDB m) () -> m ()
 updateDB sets act = runUpdateDB (runErrorT act >> return ()) `runReaderT` sets
 
--- | Set partial status
-setStatus :: MonadReader Settings m => Value -> m a -> m a
-setStatus v act = local alter act where
-	alter s = s {
-		onStatus = \st -> onStatus s (v `union` st) }
+-- | Set status details
+setStatus :: MonadReader Settings m => [Pair] -> m a -> m a
+setStatus ps act = local alter act where
+	alter st = st {
+		onStatus = \(Status s ds) -> onStatus st (Status s (ds ++ ps)) }
 
+-- | Post status
+postStatus :: (MonadIO m, MonadReader Settings m) => Value -> m ()
+postStatus s = do
+	on' <- asks onStatus
+	liftIO $ on' $ Status s []
+
 -- | Wait DB to complete actions
 waiter :: (MonadIO m, MonadReader Settings m) => m () -> m ()
 waiter act = do
@@ -80,15 +102,15 @@ 
 -- | Run one task
 runTask :: MonadIO m => Value -> ErrorT String (UpdateDB m) a -> ErrorT String (UpdateDB m) a
-runTask v act = object ["task" .= v] `setStatus` wrapAct act where
+runTask v act = ["task" .= v] `setStatus` wrapAct act where
 	wrapAct :: MonadIO m => ErrorT String (UpdateDB m) a -> ErrorT String (UpdateDB m) a
 	wrapAct a = do
-		status $ object ["status" .= toJSON ("working" :: String)]
+		postStatus $ toJSON ("working" :: String)
 		x <- a
-		status $ object ["status" .= taskOk]
+		postStatus taskOk
 		return x
 		`catchError`
-		(\e -> status (object ["status" .= taskErr e]) >> throwError e)
+		(\e -> postStatus (taskErr e) >> throwError e)
 	taskOk = toJSON ("ok" :: String)
 	taskErr e = object ["error" .= e]
 
@@ -97,15 +119,9 @@ runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where
 	total = length ts
 	taskNum n t = progress `setStatus` t where
-		progress = object ["progress" .= object [
+		progress = ["progress" .= object [
 			"current" .= (n :: Integer), "total" .= total]]
 	noErr v = v `mplus` return ()
-
--- | Post status
-status :: (MonadIO m, MonadReader Settings m) => Value -> m ()
-status msg = do
-	on' <- asks onStatus
-	liftIO $ on' msg
 
 -- | Get database value
 readDB :: (MonadIO m, MonadReader Settings m) => m Database

@@ -15,17 +15,17 @@ 
 import System.Command
 
-opts :: [OptDescr Opts]
+opts :: [OptDescr (Opts String)]
 opts = [
 	option_ ['g'] "ghc" (req "ghc options") "options for GHC",
-	option_ [] "hide-import-list" flag "hide import list",
+	option_ [] "hide-import-list" no "hide import list",
 	option_ [] "max-import-list" (req "max import list length") "hide long import lists"]
 
 cmds :: [Command (IO ())]
 cmds = addHelp "hsclearimports" id [
 	cmd [] ["file"] "clear imports in haskell source" opts clear]
 	where
-		clear :: Opts -> [String] -> IO ()
+		clear :: Opts String -> [String] -> IO ()
 		clear as [f] = do
 			file <- canonicalizePath f
 			mroot <- locateSourceDir file
@@ -33,14 +33,14 @@ 			flip finally (setCurrentDirectory cur) $ do
 				maybe (return ()) setCurrentDirectory mroot
 				void $ runErrorT $ catchError
-					(clearImports (askOpts "ghc" as) file >>= mapM_ (liftIO . putStrLn . format as))
+					(clearImports (list "ghc" as) file >>= mapM_ (liftIO . putStrLn . format as))
 					(\e -> liftIO (putStrLn $ "Error: " ++ e))
 		clear _ _ = putStrLn "Invalid arguments"
 		
-		format :: Opts -> (String, String) -> String
+		format :: Opts String -> (String, String) -> String
 		format as (imp, lst)
-			| hasOpt "hide-import-list" as = imp
-			| maybe False (length lst >) (askOpt "max-import-list" as >>= readMaybe) = imp
+			| flag "hide-import-list" as = imp
+			| maybe False (length lst >) (arg "max-import-list" as >>= readMaybe) = imp
 			| otherwise = imp ++ " (" ++ lst ++ ")"
 
 main :: IO ()

@@ -17,7 +17,7 @@ 	jsonCmd_ ["cabal"] ["project file"] "inspect .cabal file" inspectCabal']
 	where
 		ghcOpts = option_ ['g'] "ghc" (req "ghc options") "options to pass to GHC"
-		ghcs = askOpts "ghc"
+		ghcs = list "ghc"
 
 		inspectModule' opts [mname] = scanModule (ghcs opts) (CabalModule Cabal Nothing mname)
 		inspectModule' _ _ = toolError "Specify module name"