packages feed

hsdev 0.1.0.1 → 0.1.1.0

raw patch · 38 files changed

+2718/−2058 lines, 38 filesdep +regex-posixdep +template-haskelldep ~monad-loops

Dependencies added: regex-posix, template-haskell

Dependency ranges changed: monad-loops

Files

hsdev.cabal view
@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.0.1
+version:             0.1.1.0
 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
@@ -17,21 +17,31 @@ 
 library
   hs-source-dirs: src
-  ghc-options: -threaded
+  ghc-options: -threaded -Wall
   exposed-modules:
-    Data.Group
+    Control.Apply.Util
+    Control.Concurrent.FiniteChan
+    Control.Concurrent.Util
     Data.Async
+    Data.Group
+    Data.Help
     HsDev
     HsDev.Cabal
     HsDev.Cache
     HsDev.Cache.Structured
+    HsDev.Client.Commands
     HsDev.Commands
     HsDev.Database
     HsDev.Database.Async
+    HsDev.Database.Update
+    HsDev.Display
     HsDev.Inspect
     HsDev.Project
     HsDev.Scan
     HsDev.Scan.Browse
+    HsDev.Server.Commands
+    HsDev.Server.Message
+    HsDev.Server.Types
     HsDev.Symbols
     HsDev.Symbols.Class
     HsDev.Symbols.Location
@@ -45,11 +55,23 @@     HsDev.Tools.Hayoo
     HsDev.Tools.HDocs
     HsDev.Util
+    HsDev.Version
+    System.Console.Args
+    System.Console.Cmd
+    Text.Format
 
   if os(windows)
+    build-depends:
+      Win32 >= 2.3.0
     exposed-modules:
       System.Win32.PowerShell
+      System.Win32.FileMapping.NamePool
+      System.Win32.FileMapping.Memory
+  else
+    build-depends:
+      unix >= 2.7.0
 
+
   build-depends:
     base >= 4.7 && < 5,
     aeson >= 0.7.0,
@@ -68,33 +90,24 @@     hdocs >= 0.4.0,
     HTTP >= 4000.2.0,
     MonadCatchIO-transformers >= 0.3.0,
+    monad-loops >= 0.4,
     mtl >= 2.1.0,
+    network >= 2.4.0,
     transformers >= 0.3.0,
     process >= 1.2.0,
     regexpr >= 0.5.0,
+    regex-posix >= 0.95,
     time >= 1.4.0,
     attoparsec >= 0.11.0,
+    template-haskell,
     unordered-containers >= 0.2.0,
+    vector >= 0.10.0,
     text >= 1.1.0
 
 executable hsdev
   main-is: hsdev.hs
   hs-source-dirs: tools
-  ghc-options: -threaded
-  other-modules:
-    Control.Concurrent.FiniteChan
-    Commands
-    System.Command
-    Types
-    Update
-
-  if os(windows)
-    other-modules:
-      System.Win32.FileMapping.Memory
-      System.Win32.FileMapping.NamePool
-  else
-    build-depends:
-      unix >= 2.7.0
+  ghc-options: -threaded -Wall
 
   build-depends:
     base >= 4.7 && < 5,
@@ -114,18 +127,13 @@     unordered-containers >= 0.2.0,
     text >= 1.1.0,
     transformers >= 0.3.0,
-    unordered-containers >= 0.2.0,
-    vector >= 0.10.0
-
-  if os(windows)
-    build-depends:
-      Win32 >= 2.3.0
+    unordered-containers >= 0.2.0
 
 executable hsinspect
   main-is: hsinspect.hs
   hs-source-dirs: tools
+  ghc-options: -Wall
   other-modules:
-    System.Command
     Tool
   build-depends:
     base >= 4.7 && < 5,
@@ -143,8 +151,8 @@ executable hsclearimports
   main-is: hsclearimports.hs
   hs-source-dirs: tools
+  ghc-options: -Wall
   other-modules:
-    System.Command
   build-depends:
     base >= 4.7 && < 5,
     hsdev,
@@ -156,14 +164,13 @@     containers >= 0.5.0,
     mtl >= 2.1.0,
     text >= 1.1.0,
-    unordered-containers >= 0.2.0,
-    vector >= 0.10.0
+    unordered-containers >= 0.2.0
 
 executable hscabal
   main-is: hscabal.hs
   hs-source-dirs: tools
+  ghc-options: -Wall
   other-modules:
-    System.Command
     Tool
   build-depends:
     base >= 4.7 && < 5,
@@ -174,14 +181,13 @@     containers >= 0.5.0,
     mtl >= 2.1.0,
     text >= 1.1.0,
-    unordered-containers >= 0.2.0,
-    vector >= 0.10.0
+    unordered-containers >= 0.2.0
 
 executable hshayoo
   main-is: hshayoo.hs
   hs-source-dirs: tools
+  ghc-options: -Wall
   other-modules:
-    System.Command
     Tool
   build-depends:
     base >= 4.7 && < 5,
@@ -192,12 +198,12 @@     containers >= 0.5.0,
     mtl >= 2.1.0,
     text >= 1.1.0,
-    unordered-containers >= 0.2.0,
-    vector >= 0.10.0
+    unordered-containers >= 0.2.0
 
 test-suite test
   main-is: Test.hs
   hs-source-dirs: tests
+  ghc-options: -Wall
   type: exitcode-stdio-1.0
   build-depends:
     base >= 4.7 && < 5
+ src/Control/Apply/Util.hs view
@@ -0,0 +1,17 @@+module Control.Apply.Util (
+	(&), chain, with
+	) where
+
+import Data.List (foldr)
+
+(&) :: a -> (a -> b) -> b
+(&) = flip ($)
+
+chain :: [a -> a] -> a -> a
+chain = foldr (.) id
+
+-- | Flipped version of 'chain', which can be used like this:
+--
+-- >foo `with` [f, g, h]
+with :: a -> [a -> a] -> a
+with = flip chain
+ src/Control/Concurrent/FiniteChan.hs view
@@ -0,0 +1,38 @@+module Control.Concurrent.FiniteChan (
+	Chan,
+	newChan, dupChan, putChan, getChan, readChan, closeChan, stopChan
+	) where
+
+import qualified Control.Concurrent.Chan as C
+import Data.Maybe
+
+-- | 'Chan' is stoppable channel unline 'Control.Concurrent.Chan'
+newtype Chan a = Chan (C.Chan (Maybe a))
+
+-- | Create channel
+newChan :: IO (Chan a)
+newChan = fmap Chan C.newChan
+
+-- | Duplicate channel
+dupChan :: Chan a -> IO (Chan a)
+dupChan (Chan ch) = fmap Chan $ C.dupChan ch
+
+-- | Write data to channel
+putChan :: Chan a -> a -> IO ()
+putChan (Chan ch) = C.writeChan ch . Just
+
+-- | Get data from channel
+getChan :: Chan a -> IO (Maybe a)
+getChan (Chan ch) = C.readChan ch
+
+-- | Read channel contents
+readChan :: Chan a -> IO [a]
+readChan (Chan ch) = fmap (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
+
+-- | Stop channel and return all data
+stopChan :: Chan a -> IO [a]
+stopChan ch = closeChan ch >> readChan ch
+ src/Control/Concurrent/Util.hs view
@@ -0,0 +1,37 @@+module Control.Concurrent.Util (
+	fork, race, timeout, withSync, withSync_
+	) where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+
+fork :: (MonadIO m, Functor m) => IO () -> m ()
+fork = liftIO . void . forkIO
+
+race :: [IO a] -> IO a
+race acts = do
+	var <- newEmptyMVar
+	ids <- forM acts $ \a -> forkIO ((a >>= putMVar var) `catch` ignoreError)
+	r <- takeMVar var
+	forM_ ids killThread
+	return r
+	where
+		ignoreError :: SomeException -> IO ()
+		ignoreError _ = return ()
+
+timeout :: Int -> IO a -> IO (Maybe a)
+timeout 0 act = fmap Just act
+timeout tm act = race [
+	fmap Just act,
+	threadDelay tm >> return Nothing]
+
+withSync :: a -> ((a -> IO ()) -> IO b) -> IO a
+withSync v act = do
+	sync <- newEmptyMVar
+	void $ forkIO $ void $ act (putMVar sync) `onException` (putMVar sync v)
+	takeMVar sync
+
+withSync_ :: (IO () -> IO a) -> IO ()
+withSync_ act = withSync () $ \sync -> act (sync ())
+ src/Data/Help.hs view
@@ -0,0 +1,21 @@+module Data.Help (
+	Help(..),
+	indent, indentHelp, detailed, indented
+	) where
+
+class Help a where
+	brief :: a -> String
+	help :: a -> [String]
+
+indent :: String -> String
+indent = ('\t':)
+
+indentHelp :: [String] -> [String]
+indentHelp [] = []
+indentHelp (h:hs) = h : map indent hs
+
+detailed :: Help a => a -> [String]
+detailed v = brief v : help v
+
+indented :: Help a => a -> [String]
+indented = indentHelp . detailed
+ src/HsDev/Client/Commands.hs view
@@ -0,0 +1,676 @@+{-# LANGUAGE OverloadedStrings #-}
+
+module HsDev.Client.Commands (
+	commands
+	) where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Control.Monad.Error
+import Control.Monad.Trans.Maybe
+import Control.Exception
+import Control.Concurrent
+import Data.Aeson hiding (Result, Error)
+import Data.Aeson.Encode.Pretty
+import Data.Aeson.Types hiding (Result, Error)
+import Data.Char
+import Data.Either
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (unpack)
+import Data.Traversable (traverse)
+import Network.Socket
+import System.Directory
+import System.Environment
+import System.Exit
+import System.IO
+import System.Process
+import System.Console.GetOpt
+import System.FilePath
+import Text.Read (readMaybe)
+
+import Control.Apply.Util
+import qualified HsDev.Database.Async as DB
+import HsDev.Commands
+import HsDev.Database
+import HsDev.Project
+import HsDev.Symbols
+import HsDev.Symbols.Util
+import HsDev.Util
+import HsDev.Scan
+import HsDev.Server.Message as M
+import HsDev.Server.Types
+import qualified HsDev.Tools.Cabal as Cabal
+import qualified HsDev.Tools.GhcMod as GhcMod
+import qualified HsDev.Tools.Hayoo as Hayoo
+import qualified HsDev.Cache.Structured as SC
+import HsDev.Cache
+
+import qualified Control.Concurrent.FiniteChan as F
+import Control.Concurrent.Util
+import System.Console.Cmd
+
+import qualified HsDev.Database.Update as Update
+
+-- | Client commands
+commands :: [Cmd CommandAction]
+commands = [
+	-- Ping command
+	cmd' "ping" [] [] "ping server" ping',
+	-- Database commands
+	cmd' "add" [] [dataArg] "add info to database" add',
+	cmd' "scan" [] (sandboxes ++ [
+		projectArg `desc` "project path or .cabal",
+		fileArg `desc` "source file",
+		pathArg `desc` "directory to scan for files and projects",
+		ghcOpts])
+		"scan sources"
+		scan',
+	cmd' "rescan" [] (sandboxes ++ [
+		projectArg `desc` "project path or .cabal",
+		fileArg `desc` "source file",
+		pathArg `desc` "path to rescan",
+		ghcOpts])
+		"rescan sources"
+		rescan',
+	cmd' "remove" [] (sandboxes ++ [
+		projectArg `desc` "module project",
+		fileArg `desc` "module source file",
+		moduleArg,
+		packageArg, noLastArg, packageVersionArg,
+		allFlag "remove all"])
+		"remove modules info"
+		remove',
+	-- Context free commands
+	cmd' "modules" [] (sandboxes ++ [
+		projectArg `desc` "projects to list modules from",
+		noLastArg,
+		packageArg,
+		sourced, standaloned])
+		"list modules"
+		listModules',
+	cmd' "packages" [] [] "list packages" listPackages',
+	cmd' "projects" [] [] "list projects" listProjects',
+	cmd' "symbol" ["name"] (matches ++ sandboxes ++ [
+		projectArg `desc` "related project",
+		fileArg `desc` "source file",
+		moduleArg, localsArg,
+		packageArg, noLastArg, packageVersionArg,
+		sourced, standaloned])
+		"get symbol info"
+		symbol',
+	cmd' "module" [] (sandboxes ++ [
+		moduleArg, localsArg,
+		packageArg, noLastArg, packageVersionArg,
+		projectArg `desc` "module project",
+		fileArg `desc` "module source file",
+		sourced])
+		"get module info"
+		modul',
+	cmd' "project" [] [
+		projectArg `desc` "project path or name"]
+		"get project info"
+		project',
+	-- Context commands
+	cmd' "lookup" ["symbol"] ctx "lookup for symbol" lookup',
+	cmd' "whois" ["symbol"] ctx "get info for symbol" whois',
+	cmd' "scope modules" [] ctx "get modules accessible from module or within a project" scopeModules',
+	cmd' "scope" [] (ctx ++ matches ++ [globalArg]) "get declarations accessible from module or within a project" scope',
+	cmd' "complete" ["input"] ctx "show completions for input" complete',
+	-- Tool commands
+	cmd' "hayoo" ["query"] [] "find declarations online via Hayoo" hayoo',
+	cmd' "cabal list" ["packages..."] [] "list cabal packages" cabalList',
+	cmd' "ghc-mod type" ["line", "column"] (ctx ++ [ghcOpts]) "infer type with 'ghc-mod type'" ghcmodType',
+	cmd' "ghc-mod check" ["files"] [fileArg `desc` "source files", sandbox, ghcOpts] "check source files" ghcmodCheck',
+	cmd' "ghc-mod lint" ["file"] [fileArg `desc` "source file", hlintOpts] "lint source file" ghcmodLint',
+	-- Dump/load commands
+	cmd' "dump" [] (sandboxes ++ [
+		cacheDir, cacheFile,
+		projectArg `desc` "project",
+		fileArg `desc` "file",
+		standaloned,
+		allFlag "dump all"])
+		"dump database info" dump',
+	cmd' "load" [] [cacheDir, cacheFile, dataArg] "load data" load',
+	-- Link
+	cmd' "link" [] [holdArg] "link to server" link',
+	-- Exit
+	cmd' "exit" [] [] "exit" exit']
+	where
+		cmd' :: ToJSON a => String -> [String] -> [Opt] -> String -> ([String] -> Opts String -> CommandActionT a) -> Cmd CommandAction
+		cmd' nm pos named descr act = checkPosArgs $ cmd nm pos named descr act' where
+			act' (Args args os) copts = do
+				r <- runErrorT (act args os copts)
+				case r of
+					Left (CommandError e ds) -> return $ Error e $ M.fromList $ map (first unpack) ds
+					Right r -> return $ Result $ toJSON r
+
+		-- Command arguments and flags
+		allFlag d = flag "all" `short` ['a'] `desc` d
+		cacheDir = pathArg `desc` "cache path"
+		cacheFile = fileArg `desc` "cache file"
+		ctx = [fileArg `desc` "source file", sandbox]
+		dataArg = req "data" "contents" `desc` "data to pass to command"
+		fileArg = req "file" "path" `short` ['f']
+		findArg = req "find" "query" `desc` "infix match"
+		ghcOpts = list "ghc" "option" `short` ['g'] `desc` "options to pass to GHC"
+		globalArg = flag "global" `desc` "scope of project"
+		hlintOpts = list "hlint" "option" `short` ['h'] `desc` "options to pass to hlint"
+		holdArg = flag "hold" `short` ['h'] `desc` "don't return any response"
+		localsArg = flag "locals" `short` ['l'] `desc` "look in local declarations"
+		noLastArg = flag "no-last" `desc` "don't select last package version"
+		matches = [prefixArg, findArg]
+		moduleArg = req "module" "name" `short` ['m'] `desc` "module name"
+		packageArg = req "package" "name" `desc` "module package"
+		pathArg = req "path" "path" `short` ['p']
+		prefixArg = req "prefix" "prefix" `desc` "prefix match"
+		projectArg = req "project" "project"
+		packageVersionArg = req "version" "id" `short` ['v'] `desc` "package version"
+		sandbox = req "sandbox" "path" `desc` "path to cabal sandbox"
+		sandboxes = [
+			flag "cabal" `desc` "cabal",
+			sandbox]
+		sourced = flag "src" `desc` "source files"
+		standaloned = flag "stand" `desc` "standalone files"
+
+		-- | Ping server
+		ping' :: [String] -> Opts String -> CommandActionT Value
+		ping' _ _ _ = return $ object ["message" .= ("pong" :: String)]
+
+		-- | Add data
+		add' :: [String] -> Opts String -> CommandActionT ()
+		add' _ as copts = do
+			dbval <- getDb copts
+			jsonData <- maybe (commandError "Specify --data" []) return $ arg "data" as
+			decodedData <- either
+				(\err -> commandError "Unable to decode data" [
+					"why" .= err,
+					"data" .= jsonData])
+				return $
+				eitherDecode $ toUtf8 jsonData
+
+			let
+				updateData (ResultDeclaration d) = commandError "Can't insert declaration" ["declaration" .= d]
+				updateData (ResultModuleDeclaration md) = do
+					let
+						ModuleId mname mloc = declarationModuleId md
+						defMod = Module mname Nothing mloc [] mempty mempty
+						defInspMod = Inspected InspectionNone mloc (Right defMod)
+						dbmod = maybe
+							defInspMod
+							(\i -> i { inspectionResult = inspectionResult i <|> (Right defMod) }) $
+							M.lookup mloc (databaseModules dbval)
+						updatedMod = dbmod {
+							inspectionResult = fmap (addDeclaration $ moduleDeclaration md) (inspectionResult dbmod) }
+					DB.update (dbVar copts) $ return $ fromModule updatedMod
+				updateData (ResultModuleId (ModuleId mname mloc)) = when (M.notMember mloc $ databaseModules dbval) $
+					DB.update (dbVar copts) $ return $ fromModule $ Inspected InspectionNone mloc (Right $ Module mname Nothing mloc [] mempty mempty)
+				updateData (ResultModule m) = DB.update (dbVar copts) $ return $ fromModule $ Inspected InspectionNone (moduleLocation m) (Right m)
+				updateData (ResultInspectedModule m) = DB.update (dbVar copts) $ return $ fromModule m
+				updateData (ResultProject p) = DB.update (dbVar copts) $ return $ fromProject p
+				updateData (ResultList l) = mapM_ updateData l
+				updateData (ResultMap m) = mapM_ updateData $ M.elems m
+				updateData (ResultString s) = commandError "Can't insert string" []
+				updateData ResultNone = return ()
+			updateData decodedData
+
+		-- | Scan sources and installed packages
+		scan' :: [String] -> Opts String -> CommandActionT ()
+		scan' _ as copts = do
+			cabals <- getSandboxes copts as
+			updateProcess copts as $ do
+				mapM_ (Update.scanCabal (listArg "ghc" as)) cabals
+				mapM_ (\(n, f) -> forM_ (listArg n as) (findPath copts >=> f (listArg "ghc" as))) [
+					("project", Update.scanProject),
+					("file", Update.scanFile),
+					("path", Update.scanDirectory)]
+
+		-- | Rescan data
+		rescan' :: [String] -> Opts String -> CommandActionT ()
+		rescan' _ as copts = do
+			cabals <- getSandboxes copts as
+			updateProcess copts as $ mapM_ (Update.scanCabal (listArg "ghc" as)) cabals
+
+			dbval <- getDb copts
+			let
+				fileMap = M.fromList $ mapMaybe toPair $
+					selectModules (byFile . moduleId) dbval
+
+			(errors, filteredMods) <- liftM partitionEithers $ mapM runErrorT $ concat [
+				[do
+					p' <- findProject copts p
+					return $ M.fromList $ mapMaybe toPair $
+						selectModules (inProject p' . moduleId) dbval |
+					p <- listArg "project" as],
+				[do
+					f' <- findPath copts f
+					maybe
+						(throwError $ "Unknown file: " ++ f')
+						(return . M.singleton f')
+						(lookupFile f' dbval) |
+					f <- listArg "file" as],
+				[do
+					d' <- findPath copts d
+					return $ M.filterWithKey (\f _ -> isParent d' f) fileMap |
+					d <- listArg "path" as]]
+			let
+				rescanMods = map (getInspected dbval) $
+					M.elems $ if null filteredMods then fileMap else M.unions filteredMods
+
+			if not (null errors)
+				then commandError (intercalate ", " errors) []
+				else updateProcess copts as $ Update.runTask "rescanning modules" [] $ do
+					needRescan <- Update.liftErrorT $ filterM (changedModule dbval (listArg "ghc" as) . inspectedId) rescanMods
+					Update.scanModules (listArg "ghc" as) (map (inspectedId &&& inspectionOpts . inspection) needRescan)
+
+		-- | Remove data
+		remove' :: [String] -> Opts String -> CommandActionT [ModuleId]
+		remove' _ as copts = do
+			dbval <- getDb copts
+			cabal <- getCabal_ copts as
+			proj <- traverse (findProject copts) $ arg "project" as
+			file <- traverse (findPath copts) $ arg "file" as
+			let
+				cleanAll = flagSet "all" as
+				filters = catMaybes [
+					fmap inProject proj,
+					fmap inFile file,
+					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
+					| null filters && cleanAll = liftIO $ do
+						DB.modifyAsync (dbVar copts) DB.Clear
+						return []
+					| null filters && not cleanAll = commandError "Specify filter or explicitely set flag --all" []
+					| cleanAll = commandError "--all flag can't be set with filters" []
+					| otherwise = liftIO $ do
+						DB.modifyAsync (dbVar copts) $ DB.Remove $ mconcat $ map (fromModule . getInspected dbval) toClean
+						return $ map moduleId toClean
+			action
+
+		-- | List modules
+		listModules' :: [String] -> Opts String -> CommandActionT [ModuleId]
+		listModules' _ as copts = do
+			dbval <- getDb copts
+			projs <- traverse (findProject copts) $ listArg "project" as
+			cabals <- getSandboxes copts as
+			let
+				packages = listArg "package" as
+				hasFilters = not $ null projs && null packages && null cabals
+				filters = allOf $ catMaybes [
+					if hasFilters
+						then Just $ anyOf $ catMaybes [
+							if null projs then Nothing else Just (\m -> any (`inProject` m) projs),
+							if null packages && null cabals then Nothing
+								else Just (\m -> (any (`inPackage` m) packages || null packages) && (any (`inCabal` m) cabals || null cabals))]
+						else Nothing,
+					if flagSet "src" as then Just byFile else Nothing,
+					if flagSet "stand" as then Just standalone else Nothing]
+			return $ map moduleId $ newest as $ selectModules (filters . moduleId) dbval
+
+		-- | List packages
+		listPackages' :: [String] -> Opts String -> CommandActionT [ModulePackage]
+		listPackages' _ _ copts = do
+			dbval <- getDb copts
+			return $ nub $ sort $
+				mapMaybe (moduleCabalPackage . moduleLocation) $
+				allModules dbval
+
+		-- | List projects
+		listProjects' :: [String] -> Opts String -> CommandActionT [Project]
+		listProjects' _ _ copts = do
+			dbval <- getDb copts
+			return $ M.elems $ databaseProjects dbval
+
+		-- | Get symbol info
+		symbol' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration]
+		symbol' ns as copts = do
+			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 (arg "module" as),
+					fmap inPackage (arg "package" as),
+					fmap inVersion (arg "version" as),
+					fmap inCabal cabal,
+					if flagSet "src" as then Just byFile else Nothing,
+					if flagSet "stand" as then Just standalone else Nothing]
+				toResult = newest as . filterMatch as . filter filters
+			case ns of
+				[] -> return $ toResult $ allDeclarations dbval
+				[nm] -> liftM toResult $ mapErrorT
+					(liftM $ left (\e -> CommandError ("Can't find symbol: " ++ e) []))
+					(findDeclaration dbval nm)
+				_ -> commandError "Too much arguments" []
+
+		-- | Get module info
+		modul' :: [String] -> Opts String -> CommandActionT Module
+		modul' _ as copts = do
+			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 (arg "module" as),
+					fmap inPackage (arg "package" as),
+					fmap inVersion (arg "version" as),
+					if flagSet "src" as then Just byFile else Nothing]
+			rs <- mapErrorT (fmap $ strMsg +++ id) $
+				(newest as . filter (filters . moduleId)) <$> maybe
+					(return $ allModules dbval)
+					(mapErrorStr . findModule dbval)
+					(arg "module" as)
+			case rs of
+				[] -> commandError "Module not found" []
+				[m] -> return m
+				ms' -> commandError "Ambiguous modules" ["modules" .= (map moduleId ms')]
+
+		-- | Get project info
+		project' :: [String] -> Opts String -> CommandActionT Project
+		project' _ as copts = do
+			proj <- maybe (commandError "Specify project name or .cabal file" []) (mapErrorStr . findProject copts) $ arg "project" as
+			return proj
+
+		-- | Lookup info about symbol
+		lookup' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration]
+		lookup' [nm] as copts = do
+			dbval <- getDb copts
+			(srcFile, cabal) <- getCtx copts as
+			mapErrorStr $ lookupSymbol dbval cabal srcFile nm
+		lookup' _ as copts = commandError "Invalid arguments" []
+
+		-- | Get detailed info about symbol in source file
+		whois' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration]
+		whois' [nm] as copts = do
+			dbval <- getDb copts
+			(srcFile, cabal) <- getCtx copts as
+			mapErrorStr $ whois dbval cabal srcFile nm
+		whois' _ as copts = commandError "Invalid arguments" []
+
+		-- | Get modules accessible from module
+		scopeModules' :: [String] -> Opts String -> CommandActionT [ModuleId]
+		scopeModules' [] as copts = do
+			dbval <- getDb copts
+			(srcFile, cabal) <- getCtx copts as
+			liftM (map moduleId) $ mapErrorStr $ scopeModules dbval cabal srcFile
+		scopeModules' _ as copts = commandError "Invalid arguments" []
+
+		-- | Get declarations accessible from module
+		scope' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration]
+		scope' [] as copts = do
+			dbval <- getDb copts
+			(srcFile, cabal) <- getCtx copts as
+			liftM (filterMatch as) $ mapErrorStr $ scope dbval cabal srcFile (flagSet "global" as)
+		scope' _ as copts = commandError "Invalid arguments" []
+
+		-- | Completion
+		complete' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration]
+		complete' [] as copts = complete' [""] as copts
+		complete' [input] as copts = do
+			dbval <- getDb copts
+			(srcFile, cabal) <- getCtx copts as
+			mapErrorStr $ completions dbval cabal srcFile input
+		complete' _ as copts = commandError "Invalid arguments" []
+
+		-- | Hayoo
+		hayoo' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration]
+		hayoo' [] as copts = commandError "Query not specified" []
+		hayoo' [query] as copts = liftM
+				(map Hayoo.hayooAsDeclaration . Hayoo.hayooFunctions) $
+				mapErrorStr $ Hayoo.hayoo query
+		hayoo' _ as copts = commandError "Too much arguments" []
+
+		-- | Cabal list
+		cabalList' :: [String] -> Opts String -> CommandActionT [Cabal.CabalPackage]
+		cabalList' qs as copts = mapErrorStr $ Cabal.cabalList qs
+
+		-- | Ghc-mod type
+		ghcmodType' :: [String] -> Opts String -> CommandActionT [GhcMod.TypedRegion]
+		ghcmodType' [line] as copts = ghcmodType' [line, "1"] as copts
+		ghcmodType' [line, column] as copts = do
+			line' <- maybe (commandError "line must be a number" []) return $ readMaybe line
+			column' <- maybe (commandError "column must be a number" []) return $ readMaybe column
+			dbval <- getDb copts
+			(srcFile, cabal) <- getCtx copts as
+			(srcFile', m, mproj) <- mapErrorStr $ fileCtx dbval srcFile
+			mapErrorStr $ GhcMod.typeOf (listArg "ghc" as) cabal srcFile' mproj (moduleName m) line' column'
+		ghcmodType' [] as copts = commandError "Specify line" []
+		ghcmodType' _ as copts = commandError "Too much arguments" []
+
+		-- | Ghc-mod check
+		ghcmodCheck' :: [String] -> Opts String -> CommandActionT [GhcMod.OutputMessage]
+		ghcmodCheck' [] as copts = commandError "Specify at least one file" []
+		ghcmodCheck' files as copts = do
+			files' <- mapM (findPath copts) files
+			mproj <- (listToMaybe . catMaybes) <$> liftIO (mapM (locateProject) files')
+			cabal <- getCabal copts as
+			mapErrorStr $ GhcMod.check (listArg "ghc" as) cabal files' mproj
+
+		-- | Ghc-mod lint
+		ghcmodLint' :: [String] -> Opts String -> CommandActionT [GhcMod.OutputMessage]
+		ghcmodLint' [] as copts = commandError "Specify file to hlint" []
+		ghcmodLint' [file] as copts = do
+			file' <- findPath copts file
+			mapErrorStr $ GhcMod.lint (listArg "hlint" as) file'
+		ghcmodLint' fs as copts = commandError "Too much files specified" []
+
+		-- | Dump database info
+		dump' :: [String] -> Opts String -> CommandActionT ()
+		dump' [] as copts = do
+			dbval <- getDb copts
+
+			cabals <- getSandboxes copts as
+			ps' <- traverse (findProject copts) $ listArg "project" as
+			fs' <- traverse (findPath copts) $ listArg "file" as
+
+			let
+				dat = mconcat [
+					if flagSet "all" as then dbval else mempty,
+					if flagSet "stand" as then standaloneDB dbval else mempty,
+					mconcat $ map (`cabalDB` dbval) cabals,
+					mconcat $ map (`projectDB` dbval) ps',
+					filterDB (\m -> any (`inFile` moduleId m) fs') (const False) dbval]
+
+			void $ runMaybeT $ msum [
+				do
+					p <- MaybeT $ traverse (findPath copts) $ arg "path" as
+					fork $ SC.dump p $ structurize dat,
+				do
+					f <- MaybeT $ traverse (findPath copts) $ arg "file" as
+					fork $ dump f dat]
+		dump' _ as copts = commandError "Invalid arguments" []
+
+		-- | Load database
+		load' :: [String] -> Opts String -> CommandActionT ()
+		load' _ as copts = do
+			void $ liftM (maybe (commandError "Specify one of: --path, --file or --data" []) return) $ runMaybeT $ msum [
+				do
+					p <- MaybeT $ return $ arg "path" as
+					lift $ cacheLoad copts (liftA merge <$> SC.load p),
+				do
+					f <- MaybeT $ return $ arg "file" as
+					e <- liftIO $ doesFileExist f
+					when e $ lift $ cacheLoad copts (load f),
+				do
+					dat <- MaybeT $ return $ arg "data" as
+					lift $ cacheLoad copts (return $ eitherDecode (toUtf8 dat))]
+			waitDb copts as
+
+		-- | Link to server
+		link' :: [String] -> Opts String -> CommandActionT ()
+		link' _ as copts = liftIO $ do
+			commandLink copts
+			when (flagSet "hold" as) $ commandHold copts
+
+		-- | Exit
+		exit' :: [String] -> Opts String -> CommandActionT ()
+		exit' _ _ copts = liftIO $ commandExit copts
+
+-- Helper functions
+
+-- | Check positional args count
+checkPosArgs :: Cmd a -> Cmd a
+checkPosArgs c = validateArgs pos' c where
+	pos' (Args args os) =
+		guard (length args <= length (cmdArgs c))
+		`mplus`
+		failMatch ("unexpected positional arguments: " ++ unwords (drop (length $ cmdArgs c) args))
+
+-- | Find sandbox by path
+findSandbox :: (MonadIO m, Error e) => CommandOptions -> Maybe FilePath -> ErrorT e m Cabal
+findSandbox copts = maybe
+	(return Cabal)
+	(findPath copts >=> mapErrorStr . mapErrorT liftIO . locateSandbox)
+
+-- | Canonicalize path
+findPath :: (MonadIO m, Error e) => CommandOptions -> FilePath -> ErrorT e m FilePath
+findPath copts f = liftIO $ canonicalizePath (normalise f') where
+	f'
+		| isRelative f = commandRoot copts </> f
+		| otherwise = f
+
+-- | Get context: file and sandbox
+getCtx :: (MonadIO m, Functor m, Error e) => CommandOptions -> Opts String -> ErrorT e m (FilePath, Cabal)
+getCtx copts as = liftM2 (,)
+	(forceJust "No file specified" $ traverse (findPath copts) $ arg "file" as)
+	(getCabal copts as)
+
+-- | Get current sandbox set, user-db by default
+getCabal :: (MonadIO m, Error e) => CommandOptions -> Opts String -> ErrorT e m Cabal
+getCabal copts as
+	| flagSet "cabal" as = findSandbox copts Nothing
+	| otherwise  = findSandbox copts $ arg "sandbox" as
+
+-- | Get current sandbox if set
+getCabal_ :: (MonadIO m, Functor m, Error e) => CommandOptions -> Opts String -> ErrorT e m (Maybe Cabal)
+getCabal_ copts as
+	| flagSet "cabal" as = Just <$> findSandbox copts Nothing
+	| otherwise = case arg "sandbox" as of
+		Just f -> Just <$> findSandbox copts (Just f)
+		Nothing -> return Nothing
+
+-- | Get list of enumerated sandboxes
+getSandboxes :: (MonadIO m, Functor m, Error e) => CommandOptions -> Opts String -> ErrorT e m [Cabal]
+getSandboxes copts as = traverse (findSandbox copts) paths where
+	paths
+		| flagSet "cabal" as = Nothing : sboxes
+		| otherwise = sboxes
+	sboxes = map Just $ listArg "sandbox" as
+
+-- | Find project by name of path
+findProject :: (MonadIO m, Error e) => CommandOptions -> String -> ErrorT e 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 $ strMsg $ "Projects " ++ proj ++ " not found") return result
+	where
+		addCabal p
+			| takeExtension p == ".cabal" = p
+			| otherwise = p </> (takeBaseName p <.> "cabal")
+
+-- | Supply module with its source file path if any
+toPair :: Module -> Maybe (FilePath, Module)
+toPair m = case moduleLocation m of
+	FileModule f _ -> Just (f, m)
+	_ -> Nothing
+
+-- | Module sandbox
+modCabal :: Module -> Maybe Cabal
+modCabal m = case moduleLocation m of
+	CabalModule c _ _ -> Just c
+	_ -> Nothing
+
+-- | Wait for DB to complete update
+waitDb :: CommandOptions -> Opts String -> CommandM ()
+waitDb copts as = when (flagSet "wait" as) $ liftIO $ do
+	commandLog copts "wait for db"
+	DB.wait (dbVar copts)
+	commandLog copts "db done"
+
+cacheLoad :: CommandOptions -> IO (Either String Database) -> CommandM ()
+cacheLoad copts act = liftIO $ do
+	db' <- act
+	case db' of
+		Left e -> commandLog copts e
+		Right database -> DB.update (dbVar copts) (return database)
+
+-- | Bring locals to top scope to search within them if 'locals' flag set
+localsDatabase :: Opts String -> Database -> Database
+localsDatabase as
+	| flagSet "locals" as = databaseLocals
+	| otherwise = id
+
+-- | Select newest packages if 'no-last' flag set
+newest :: Symbol a => Opts String -> [a] -> [a]
+newest as
+	| flagSet "no-last" as = id
+	| otherwise = newestPackage
+
+-- | Convert from just of throw
+forceJust :: (MonadIO m, Error e) => String -> ErrorT e m (Maybe a) -> ErrorT e m a
+forceJust msg act = act >>= maybe (throwError $ strMsg msg) return
+
+-- | Get actual DB state
+getDb :: (MonadIO m) => CommandOptions -> m Database
+getDb = liftIO . DB.readAsync . commandDatabase
+
+-- | Get DB async var
+dbVar :: CommandOptions -> DB.Async Database
+dbVar = commandDatabase
+
+mapErrorStr :: (Monad m, Error e) => ErrorT String m a -> ErrorT e m a
+mapErrorStr = mapErrorT (liftM $ left strMsg)
+
+-- | Run DB update action
+updateProcess :: CommandOptions -> Opts String -> ErrorT String (Update.UpdateDB IO) () -> CommandM ()
+updateProcess copts as act = lift $ Update.updateDB settings act where
+	settings = Update.Settings
+		(commandDatabase copts)
+		(commandReadCache copts)
+		(commandNotify copts . Notification . toJSON)
+		(listArg "ghc" as)
+
+-- | Filter declarations with prefix and infix
+filterMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration]
+filterMatch as = findMatch as . prefMatch as
+
+-- | Filter declarations with infix match
+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)
+
+-- | Filter declarations with prefix match
+prefMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration]
+prefMatch as = case fmap splitIdentifier (arg "prefix" as) of
+	Nothing -> id
+	Just (qname, pref) -> filter (match' qname pref)
+	where
+		match' qname pref m =
+			pref `isPrefixOf` declarationName (moduleDeclaration m) &&
+			maybe True (== moduleIdName (declarationModuleId m)) qname
+
+ src/HsDev/Database/Update.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings, MultiParamTypeClasses #-}
+
+module HsDev.Database.Update (
+	Status(..), Progress(..), Task(..), isStatus,
+	Settings(..),
+
+	UpdateDB,
+	updateDB,
+
+	postStatus, waiter, updater, loadCache, runTask, runTasks,
+	readDB,
+
+	scanModule, scanModules, scanFile, scanCabal, scanProjectFile, scanProject, scanDirectory,
+
+	-- * Helpers
+	liftErrorT
+	) where
+
+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.List (nub)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe, isJust)
+import Data.Monoid
+import Data.Traversable (traverse)
+import System.Directory (canonicalizePath)
+
+import qualified HsDev.Cache.Structured as Cache
+import HsDev.Database
+import HsDev.Database.Async
+import HsDev.Display
+import HsDev.Project
+import HsDev.Symbols
+import HsDev.Tools.HDocs
+import qualified HsDev.Scan as S
+import HsDev.Scan.Browse
+import HsDev.Util ((.::))
+
+data Status = StatusWorking | StatusOk | StatusError String
+
+instance ToJSON Status where
+	toJSON StatusWorking = toJSON ("working" :: String)
+	toJSON StatusOk = toJSON ("ok" :: String)
+	toJSON (StatusError e) = toJSON $ object ["error" .= e]
+
+instance FromJSON Status where
+	parseJSON v = msum $ map ($ v) [
+		withText "status" $ \t -> guard (t == "working") *> return StatusWorking,
+		withText "status" $ \t -> guard (t == "ok") *> return StatusOk,
+		withObject "status" $ \obj -> StatusError <$> (obj .:: "error"),
+		fail "invalid status"]
+
+data Progress = Progress {
+	progressCurrent :: Int,
+	progressTotal :: Int }
+
+instance ToJSON Progress where
+	toJSON (Progress c t) = object [
+		"current" .= c,
+		"total" .= t]
+
+instance FromJSON Progress where
+	parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total")
+
+data Task = Task {
+	taskName :: String,
+	taskStatus :: Status,
+	taskParams :: Object,
+	taskProgress :: Maybe Progress,
+	taskChild :: Maybe Task }
+
+instance ToJSON Task where
+	toJSON t = object [
+		"status" .= taskStatus t,
+		"task" .= taskName t,
+		"params" .= taskParams t,
+		"progress" .= taskProgress t,
+		"child" .= taskChild t]
+
+instance FromJSON Task where
+	parseJSON = withObject "task" $ \v -> Task <$>
+		(v .:: "task") <*>
+		(v .:: "status") <*>
+		(v .:: "params") <*>
+		(v .:: "progress") <*>
+		(v .:: "child")
+
+isStatus :: Value -> Bool
+isStatus = isJust . parseMaybe (parseJSON :: Value -> Parser Task)
+
+data Settings = Settings {
+	database :: Async Database,
+	databaseCacheReader :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database),
+	onStatus :: Task -> IO (),
+	ghcOptions :: [String] }
+
+newtype UpdateDB m a = UpdateDB { runUpdateDB :: ReaderT Settings m a }
+	deriving (Applicative, Monad, MonadIO, MonadCatchIO, Functor, MonadReader Settings)
+
+-- | Run `UpdateDB` monad
+updateDB :: Monad m => Settings -> ErrorT String (UpdateDB m) () -> m ()
+updateDB sets act = runUpdateDB (runErrorT act >> return ()) `runReaderT` sets
+
+-- | Post status
+postStatus :: (MonadIO m, MonadReader Settings m) => Task -> m ()
+postStatus s = do
+	on' <- asks onStatus
+	liftIO $ on' s
+
+-- | Wait DB to complete actions
+waiter :: (MonadIO m, MonadReader Settings m) => m () -> m ()
+waiter act = do
+	db <- asks database
+	act
+	wait db
+
+-- | Update task result to database
+updater :: (MonadIO m, MonadReader Settings m) => m Database -> m ()
+updater act = do
+	db <- asks database
+	act >>= update db . return
+
+-- | Load data from cache and wait
+loadCache :: (MonadIO m, MonadReader Settings m) => (FilePath -> ErrorT String IO Structured) -> m ()
+loadCache act = do
+	cacheReader <- asks databaseCacheReader
+	mdat <- liftIO $ cacheReader act
+	case mdat of
+		Nothing -> return ()
+		Just dat -> waiter (updater (return dat))
+
+-- | Run one task
+runTask :: MonadIO m => String -> [Pair] -> ErrorT String (UpdateDB m) a -> ErrorT String (UpdateDB m) a
+runTask action params act = do
+	postStatus $ task { taskStatus = StatusWorking }
+	x <- local childTask act
+	postStatus $ task { taskStatus = StatusOk }
+	return x
+	`catchError`
+	(\e -> postStatus (task { taskStatus = StatusError e }) >> throwError e)
+	where
+		task = Task {
+			taskName = action,
+			taskStatus = StatusWorking,
+			taskParams = HM.fromList params,
+			taskProgress = Nothing,
+			taskChild = Nothing }
+		childTask st = st {
+			onStatus = \t -> onStatus st (task { taskChild = Just t }) }
+
+-- | Run many tasks with numeration
+runTasks :: Monad m => [ErrorT String (UpdateDB m) ()] -> ErrorT String (UpdateDB m) ()
+runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where
+	total = length ts
+	taskNum n = local setProgress where
+		setProgress st = st {
+			onStatus = \t -> onStatus st (t { 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
+
+-- | Scan module
+scanModule :: MonadCatchIO m => [String] -> ModuleLocation -> ErrorT String (UpdateDB m) ()
+scanModule opts mloc = runTask "scanning" (subject mloc ["module" .= mloc]) $ do
+	im <- liftErrorT $ S.scanModule opts mloc
+	updater $ return $ fromModule im
+	ErrorT $ return $ inspectionResult im
+	return ()
+
+-- | Scan modules
+scanModules :: MonadCatchIO m => [String] -> [S.ModuleToScan] -> ErrorT String (UpdateDB m) ()
+scanModules opts ms = do
+	db <- asks database
+	dbval <- readDB
+	ms' <- liftErrorT $ filterM (S.changedModule dbval opts . fst) ms
+	runTasks $
+		[scanProjectFile opts p >> return () | p <- ps] ++
+		[scanModule (opts ++ snd m) (fst m) | m <- ms']
+	where
+		ps = nub $ mapMaybe (toProj . fst) ms
+		toProj (FileModule _ p) = fmap projectCabal p
+		toProj _ = Nothing
+
+-- | Scan source file
+scanFile :: MonadCatchIO m => [String] -> FilePath -> ErrorT String (UpdateDB m) ()
+scanFile opts fpath = do
+	fpath' <- liftIO $ canonicalizePath fpath
+	mproj <- liftIO $ locateProject fpath'
+	let
+		mtarget = mproj >>= (`fileTarget` fpath')
+		fileExts = maybe [] (extensionsOpts . infoExtensions) mtarget
+
+	scanModule (opts ++ fileExts) (FileModule fpath' mproj)
+
+-- | Scan cabal modules
+scanCabal :: MonadCatchIO m => [String] -> Cabal -> ErrorT String (UpdateDB m) ()
+scanCabal opts sandbox = runTask "scanning" (subject sandbox ["sandbox" .= sandbox]) $ do
+	loadCache $ Cache.loadCabal sandbox
+	dbval <- readDB
+	ms <- runTask "loading modules" [] $
+		liftErrorT $ browseFilter opts sandbox (S.changedModule dbval opts)
+	docs <- runTask "loading docs" [] $
+		liftErrorT $ hdocsCabal sandbox opts
+	updater $ return $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms
+	where
+		setDocs' :: Map String (Map String String) -> Module -> Module
+		setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (moduleName m) docs
+
+-- | Scan project file
+scanProjectFile :: MonadCatchIO m => [String] -> FilePath -> ErrorT String (UpdateDB m) Project
+scanProjectFile opts cabal = runTask "scanning" (subject cabal ["file" .= cabal]) $ do
+	proj <- liftErrorT $ S.scanProjectFile opts cabal
+	updater $ return $ fromProject proj
+	return proj
+
+-- | Scan project
+scanProject :: MonadCatchIO m => [String] -> FilePath -> ErrorT String (UpdateDB m) ()
+scanProject opts cabal = runTask "scanning" (subject (project cabal) ["project" .= cabal]) $ do
+	proj <- scanProjectFile opts cabal
+	loadCache $ Cache.loadProject $ projectCabal proj
+	(_, sources) <- liftErrorT $ S.enumProject proj
+	scanModules opts sources
+
+-- | Scan directory for source files and projects
+scanDirectory :: MonadCatchIO m => [String] -> FilePath -> ErrorT String (UpdateDB m) ()
+scanDirectory opts dir = runTask "scanning" (subject dir ["path" .= dir]) $ do
+	(projSrcs, standSrcs) <- runTask "getting list of sources" [] $
+		liftErrorT $ S.enumDirectory dir
+	runTasks [scanProject opts (projectCabal p) | (p, _) <- projSrcs]
+	loadCache $ Cache.loadFiles $ mapMaybe (moduleSource . fst) standSrcs
+	scanModules opts standSrcs
+
+-- | Lift errors
+liftErrorT :: MonadIO m => ErrorT String IO a -> ErrorT String m a
+liftErrorT = mapErrorT liftIO
+
+-- | Merge two JSON object
+union :: Value -> Value -> Value
+union (Object l) (Object r) = Object $ HM.union l r
+union _ _ = error "Commands.union: impossible happened"
+
+subject :: Display a => a -> [Pair] -> [Pair]
+subject x ps = ["name" .= display x, "type" .= displayType x] ++ ps
+ src/HsDev/Display.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
+module HsDev.Display (
+	Display(..)
+	) where
+
+import Data.Maybe (fromMaybe)
+
+import HsDev.Cabal
+import HsDev.Symbols.Location
+import HsDev.Project
+
+class Display a where
+	display :: a -> String
+	displayType :: a -> String
+
+instance Display Cabal where
+	display Cabal = "cabal"
+	display (Sandbox p) = "sandbox " ++ p
+	displayType _ = "cabal"
+
+instance Display ModuleLocation where
+	display (FileModule f _) = f
+	display (CabalModule _ _ n) = n
+	display (OtherModuleSource s) = fromMaybe "" s
+	displayType _ = "module"
+
+instance Display Project where
+	display = projectName
+	displayType _ = "project"
+
+instance Display FilePath where
+	display = id
+	displayType _ = "path"
src/HsDev/Inspect.hs view
@@ -40,7 +40,7 @@ 
 -- | Analize source contents
 analyzeModule :: [String] -> Maybe FilePath -> String -> Either String Module
-analyzeModule exts file source = case H.parseFileContentsWithMode pmode source of
+analyzeModule exts file source = case H.parseFileContentsWithMode pmode source' of
 		H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason
 		H.ParseOk (H.Module _ (H.ModuleName mname) _ _ _ imports declarations) -> Right $ Module {
 			moduleName = mname,
@@ -56,6 +56,11 @@ 			H.baseLanguage = H.Haskell2010,
 			H.extensions = map H.parseExtension exts }
 
+		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces
+		source' = map untab source
+		untab '\t' = ' '
+		untab ch = ch
+
 getImport :: H.ImportDecl -> Import
 getImport d = Import (mname (H.importModule d)) (H.importQualified d) (fmap mname $ H.importAs d) (Just $ toPosition $ H.importLoc d) where
 	mname (H.ModuleName n) = n
@@ -78,12 +83,12 @@ getDecl :: H.Decl -> [Declaration]
 getDecl decl = case decl of
 	H.TypeSig loc names typeSignature -> map
-		(\n -> setPosition loc (Declaration (identOfName n) Nothing Nothing (Function (Just $ H.prettyPrint typeSignature) [])))
+		(\n -> setPosition loc (Declaration (identOfName n) Nothing Nothing (Function (Just $ oneLinePrint typeSignature) [])))
 		names
-	H.TypeDecl loc n args _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (Type $ TypeInfo Nothing (map H.prettyPrint args) Nothing)]
-	H.DataDecl loc dataOrNew ctx n args _ _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (ctor dataOrNew $ TypeInfo (makeCtx ctx) (map H.prettyPrint args) Nothing)]
-	H.GDataDecl loc dataOrNew ctx n args _ _ _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (ctor dataOrNew $ TypeInfo (makeCtx ctx) (map H.prettyPrint args) Nothing)]
-	H.ClassDecl loc ctx n args _ _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (Class $ TypeInfo (makeCtx ctx) (map H.prettyPrint args) Nothing)]
+	H.TypeDecl loc n args _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (Type $ TypeInfo Nothing (map oneLinePrint args) Nothing)]
+	H.DataDecl loc dataOrNew ctx n args _ _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (ctor dataOrNew $ TypeInfo (makeCtx ctx) (map oneLinePrint args) Nothing)]
+	H.GDataDecl loc dataOrNew ctx n args _ _ _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (ctor dataOrNew $ TypeInfo (makeCtx ctx) (map oneLinePrint args) Nothing)]
+	H.ClassDecl loc ctx n args _ _ -> [setPosition loc $ Declaration (identOfName n) Nothing Nothing (Class $ TypeInfo (makeCtx ctx) (map oneLinePrint args) Nothing)]
 	_ -> []
 	where
 		ctor :: H.DataOrNew -> TypeInfo -> DeclarationInfo
@@ -91,7 +96,10 @@ 		ctor H.NewType = NewType
 
 		makeCtx [] = Nothing
-		makeCtx ctx = Just $ intercalate ", " $ map H.prettyPrint ctx
+		makeCtx ctx = Just $ intercalate ", " $ map oneLinePrint ctx
+
+		oneLinePrint :: H.Pretty a => a -> String
+		oneLinePrint = H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode
 
 getDef :: H.Decl -> [Declaration]
 getDef (H.FunBind []) = []
src/HsDev/Project.hs view
@@ -29,7 +29,7 @@ import qualified Distribution.PackageDescription as PD
 import Distribution.PackageDescription.Parse
 import Distribution.ModuleName (components)
-import Distribution.Text
+import Distribution.Text (display, simpleParse)
 import qualified Distribution.Text (Text)
 import Language.Haskell.Extension
 import System.FilePath
@@ -266,11 +266,17 @@ 
 -- | Make project by .cabal file
 project :: FilePath -> Project
-project file = Project {
-	projectName = takeBaseName (takeDirectory file),
-	projectPath = takeDirectory file,
-	projectCabal = file,
-	projectDescription = Nothing }
+project file
+	| takeExtension file == ".cabal" = Project {
+		projectName = takeBaseName (takeDirectory file),
+		projectPath = takeDirectory file,
+		projectCabal = file,
+		projectDescription = Nothing }
+	| otherwise = Project {
+		projectName = takeBaseName file,
+		projectPath = file,
+		projectCabal = file </> (takeBaseName file <.> "cabal"),
+		projectDescription = Nothing }
 
 -- | Entity with project extensions
 data Extensions a = Extensions {
+ src/HsDev/Server/Commands.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE OverloadedStrings, CPP #-}
+
+module HsDev.Server.Commands (
+	commands,
+	serverOpts, serverDefCfg,
+	clientOpts, clientDefCfg,
+
+	clientCmd, sendCmd,
+
+	initLog, runServer,
+	processRequest, processClient,
+
+	withCache, writeCache, readCache
+	) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Error
+import Data.Aeson hiding (Result, Error)
+import Data.Aeson.Encode.Pretty
+import Data.Aeson.Types hiding (Result, Error)
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Char
+import Data.Either (isLeft)
+import Data.List
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Monoid
+import Data.Traversable (traverse)
+import Network.Socket hiding (connect)
+import qualified Network.Socket as Net
+import System.Directory
+import System.Environment
+import System.Exit
+import System.IO
+import System.Process
+import Text.Read (readMaybe)
+
+import Control.Apply.Util
+import Control.Concurrent.Util
+import qualified Control.Concurrent.FiniteChan as F
+import System.Console.Cmd hiding (run)
+
+import qualified HsDev.Cache.Structured as SC
+import qualified HsDev.Client.Commands as Client
+import HsDev.Database
+import qualified HsDev.Database.Async as DB
+import HsDev.Server.Message as M
+import HsDev.Server.Types
+import HsDev.Util
+
+#if mingw32_HOST_OS
+import System.Win32.FileMapping.Memory (withMapFile, readMapFile)
+import System.Win32.FileMapping.NamePool
+import System.Win32.PowerShell (translateArg)
+#else
+import System.Posix.Process
+import System.Posix.IO
+#endif
+
+-- | Server commands
+commands :: [Cmd (IO ())]
+commands = [
+	cmd' "start" server' "start remote server" start',
+	cmd' "run" server' "run server" run',
+	cmd' "stop" client' "stop remote server" stop',
+	cmd' "connect" client' "connect to send commands directly" connect']
+	where
+		cmd' :: String -> ([Opt], Opts String) -> String -> (Args -> IO ()) -> Cmd (IO ())
+		cmd' nm (opts', defOpts') desc' act' =
+			cmd nm [] opts' desc' act' `with` [defaultOpts defOpts']
+
+		server' = (serverOpts, serverDefCfg)
+		client' = (clientOpts, clientDefCfg)
+
+		-- | Start remote server
+		start' :: Args -> IO ()
+		start' (Args _ sopts) = do
+#if mingw32_HOST_OS
+			let
+				args = ["run"] ++ toArgs (Args [] sopts)
+			myExe <- getExecutablePath
+			r <- readProcess "powershell" [
+				"-Command",
+				unwords [
+					"&", "{", "start-process",
+					translateArg myExe,
+					intercalate ", " (map translateArg args),
+					"-WindowStyle Hidden",
+					"}"]] ""
+			if all isSpace r
+				then putStrLn $ "Server started at port " ++ (fromJust $ arg "port" sopts)
+				else putStrLn $ "Failed to start server: " ++ r
+#else
+			let
+				forkError :: SomeException -> IO ()
+				forkError e  = putStrLn $ "Failed to start server: " ++ show e
+
+				proxy :: IO ()
+				proxy = do
+					createSession
+					forkProcess serverAction
+					exitImmediately ExitSuccess
+
+				serverAction :: IO ()
+				serverAction = do
+					mapM_ closeFd [stdInput, stdOutput, stdError]
+					nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
+					mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError]
+					closeFd nullFd
+					run' (Args [] sopts)
+
+			handle forkError $ do
+				forkProcess proxy
+				putStrLn $ "Server started at port " ++ (fromJust $ arg "port" sopts)
+#endif
+
+		-- | Run server
+		run' :: Args -> IO ()
+		run' (Args _ sopts)
+			| flagSet "as-client" sopts = runServer sopts $ \copts -> do
+				commandLog copts $ "Server started as client connecting at port " ++ (fromJust $ arg "port" sopts)
+				me <- myThreadId
+				s <- socket AF_INET Stream defaultProtocol
+				addr' <- inet_addr "127.0.0.1"
+				Net.connect s $ SockAddrInet (fromIntegral $ fromJust $ iarg "port" sopts) addr'
+				bracket (socketToHandle s ReadWriteMode) hClose $ \h ->
+					processClientHandle s h (copts {
+						commandExit = killThread me })
+			| otherwise = runServer sopts $ \copts -> do
+				commandLog copts $ "Server started at port " ++ (fromJust $ arg "port" sopts)
+
+				waitListen <- newEmptyMVar
+				clientChan <- F.newChan
+
+				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 $ iarg "port" sopts) iNADDR_ANY
+					listen s maxListenQueue
+					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
+									let
+										timeoutWait = do
+											notDone <- isEmptyMVar done
+											when notDone $ do
+												void $ forkIO $ do
+													threadDelay 1000000
+													tryPutMVar done ()
+													killThread me
+												takeMVar done
+										waitForever = forever $ hGetLineBS h
+									F.putChan clientChan timeoutWait
+									processClientHandle s' h (copts {
+										commandHold = waitForever,
+										commandExit = serverStop })
+
+				takeMVar waitListen
+				DB.readAsync (commandDatabase copts) >>= writeCache sopts (commandLog copts)
+				F.stopChan clientChan >>= sequence_
+				commandLog copts "server stopped"
+
+		-- | Stop remote server
+		stop' :: Args -> IO ()
+		stop' (Args _ copts) = runArgs (map clientCmd Client.commands) onDef onError (Args ["exit"] copts) where
+			onDef = putStrLn "Command 'exit' not found"
+			onError es = putStrLn $ "Failed to stop server: " ++ es
+
+		-- | Connect to remote server
+		connect' :: Args -> IO ()
+		connect' (Args _ copts) = do
+			curDir <- getCurrentDirectory
+			s <- socket AF_INET Stream defaultProtocol
+			addr' <- inet_addr "127.0.0.1"
+			Net.connect s (SockAddrInet (fromIntegral $ fromJust $ iarg "port" copts) addr')
+			bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [1..] $ \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) $
+							req' `M.withOpts` ["current-directory" %-- curDir]
+						waitResp h
+			where
+				pretty = flagSet "pretty" 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
+						r' <- unMmap r
+						putStrLn $ fromMaybe "_" i ++ ":" ++ fromUtf8 (encodeValue r')
+						case r of
+							Left _ -> waitResp h
+							_ -> return ()
+
+-- | Server options
+serverOpts :: [Opt]
+serverOpts = [
+	req "port" "number" `desc` "listen port",
+	req "timeout" "msec" `desc` "query timeout",
+	req "log" "file" `short` ['l'] `desc` "log file",
+	req "cache" "path" `desc` "cache directory",
+	flag "load" `desc` "force load all data from cache on startup"]
+
+-- | Client options
+clientOpts :: [Opt]
+clientOpts = [
+	req "port" "number" `desc` "connection port",
+	flag "pretty" `desc` "pretty json output",
+	req "stdin" "data" `desc` "pass data to stdin",
+	req "timeout" "msec" `desc` "overwrite timeout duration",
+	flag "silent" `desc` "supress notifications"]
+
+-- | Server default options
+serverDefCfg :: Opts String
+serverDefCfg = mconcat [
+	"port" %-- (4567 :: Int),
+	"timeout" %-- (1000 :: Int)]
+
+-- | Client default options
+clientDefCfg :: Opts String
+clientDefCfg = mconcat ["port" %-- (4567 :: Int)]
+
+-- | Command to send to client
+clientCmd :: Cmd CommandAction -> Cmd (IO ())
+clientCmd c = cmd (cmdName c) (cmdArgs c) (cmdOpts c ++ clientOpts) (cmdDesc c) (sendCmd (cmdName c))
+	`with` [defaultOpts clientDefCfg]
+
+-- | Send command to server
+sendCmd :: String -> Args -> IO ()
+sendCmd name (Args args opts) = ignoreIO sendReceive where
+	(copts, opts') = splitOpts clientOpts opts
+	reqCall = Request name args opts'
+	pretty = flagSet "pretty" copts
+	encodeValue :: ToJSON a => a -> L.ByteString
+	encodeValue
+		| pretty = encodePretty
+		| otherwise = encode
+	sendReceive = do
+		curDir <- getCurrentDirectory
+		stdinData <- if flagSet "data" copts
+			then do
+				cdata <- liftM (eitherDecode :: L.ByteString -> Either String Value) L.getContents
+				case cdata of
+					Left cdataErr -> do
+						putStrLn $ "Invalid data: " ++ cdataErr
+						exitFailure
+					Right dataValue -> return $ Just dataValue
+			else return Nothing
+
+		s <- socket AF_INET Stream defaultProtocol
+		addr' <- inet_addr "127.0.0.1"
+		Net.connect s (SockAddrInet (fromIntegral $ fromJust $ iarg "port" copts) addr')
+		h <- socketToHandle s ReadWriteMode
+		L.hPutStrLn h $ encode $ Message Nothing $ reqCall `M.withOpts` [
+			"current-directory" %-- curDir,
+			"data" %-? (fromUtf8 . encode <$> stdinData),
+			"timeout" %-? (iarg "timeout" copts :: Maybe Integer),
+			if flagSet "silent" copts then hoist "silent" else mempty]
+		hFlush h
+		peekResponse h
+
+	peekResponse h = do
+		resp <- hGetLineBS h
+		parseResponse h resp
+
+	parseResponse h str = case eitherDecode str of
+		Left e -> putStrLn $ "Can't decode response: " ++ e
+		Right (Message i r) -> do
+			r' <- unMmap r
+			L.putStrLn $ case r' of
+				Left n -> encodeValue n
+				Right (Result v) -> encodeValue v
+				Right e -> encodeValue e
+			when (isLeft r') $ peekResponse h
+
+-- | Inits log chan and returns functions (print message, wait channel)
+initLog :: Opts String -> 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 :: Opts String -> (CommandOptions -> IO ()) -> IO ()
+runServer sopts act = bracket (initLog sopts) snd $ \(outputStr, waitOutput) -> do
+	db <- DB.newAsync
+	when (flagSet "load" 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
+		(const $ return ())
+		(return ())
+		(return ())
+		(return ())
+
+-- | Process request, notifications can be sent during processing
+processRequest :: CommandOptions -> (Notification -> IO ()) -> Request -> IO Result
+processRequest copts onNotify req =
+	runArgs
+		Client.commands
+		unknownCommand
+		requestError
+		(requestToArgs req)
+		(copts { commandNotify = onNotify })
+	where
+		unknownCommand :: CommandAction
+		unknownCommand _ = return $ Error "Unknown command" M.empty
+
+		requestError :: String -> CommandAction
+		requestError errs _ = return $ Error "Command syntax error" $ M.fromList [
+			("what", toJSON $ lines errs)]
+
+-- | Process client, listen for requests and process them
+processClient :: String -> IO ByteString -> (ByteString -> IO ()) -> CommandOptions -> IO ()
+processClient name receive send copts = do
+	commandLog copts $ name ++ " connected"
+	respChan <- newChan
+	forkIO $ do
+		responses <- getChanContents respChan
+		mapM_ (send . encode) responses
+	linkVar <- newMVar $ return ()
+	let
+		answer :: Message Response -> IO ()
+		answer m@(Message i r) = do
+			commandLog copts $ name ++ " << " ++ fromMaybe "_" i ++ ":" ++ fromUtf8 (encode r)
+			writeChan respChan m
+	flip finally (disconnected linkVar) $ forever $ do
+		req <- receive
+		case fmap extractMeta <$> eitherDecode req of
+			Left err -> do
+				commandLog copts $ name ++ " >> #: " ++ fromUtf8 req
+				answer $ Message Nothing $ responseError "Invalid request" [
+					"request" .= fromUtf8 req]
+			Right m -> do
+				resp' <- flip traverse m $ \(cdir, noFile, silent, tm, reqArgs) -> do
+					let
+						onNotify n
+							| silent = return ()
+							| otherwise = traverse (const $ mmap' noFile (Left n)) m >>= answer
+					commandLog copts $ name ++ " >> " ++ fromMaybe "_" (messageId m) ++ ":" ++ fromUtf8 (encode reqArgs)
+					resp <- fmap Right $ handleTimeout tm $ handleError $
+						processRequest
+							(copts {
+								commandRoot = cdir,
+								commandLink = void (swapMVar linkVar $ commandExit copts) })
+							onNotify
+							reqArgs
+					mmap' noFile resp
+				answer resp'
+	where
+		extractMeta :: Request -> (FilePath, Bool, Bool, Maybe Int, Request)
+		extractMeta c = (cdir, noFile, silent, tm, c { requestOpts = opts' }) where
+			cdir = fromMaybe (commandRoot copts) $ arg "current-directory" metaOpts
+			noFile = flagSet "no-file" metaOpts
+			silent = flagSet "silent" metaOpts
+			tm = join $ fmap readMaybe $ arg "timeout" metaOpts
+			(metaOpts, opts') = flip splitOpts (requestOpts c) [
+				req "current-directory" "path",
+				flag "no-file",
+				flag "silent",
+				req "timeout" "ms"]
+
+		handleTimeout :: Maybe Int -> IO Result -> IO Result
+		handleTimeout Nothing = id
+		handleTimeout (Just tm) = fmap (fromMaybe $ Error "Timeout" M.empty) . timeout tm
+
+		handleError :: IO Result -> IO Result
+		handleError = handle onErr where
+			onErr :: SomeException -> IO Result
+			onErr e = return $ Error "Exception" $ M.fromList [("what", toJSON $ show e)]
+
+		mmap' :: Bool -> Response -> IO Response
+#if mingw32_HOST_OS
+		mmap' False
+			| Just pool <- commandMmapPool copts = mmap pool
+#endif
+		mmap' _ = return
+
+		disconnected :: MVar (IO ()) -> IO ()
+		disconnected var = do
+			commandLog copts $ name ++ " disconnected"
+			join $ takeMVar var
+
+-- | Process client by Handle
+processClientHandle :: Show a => a -> Handle -> CommandOptions -> IO ()
+processClientHandle n h = processClient (show n) (hGetLineBS h) (\s -> L.hPutStrLn h s >> hFlush h)
+
+-- | Perform action on cache
+withCache :: Opts String -> a -> (FilePath -> IO a) -> IO a
+withCache sopts v onCache = case arg "cache" sopts of
+	Nothing -> return v
+	Just cdir -> onCache cdir
+
+writeCache :: Opts String -> (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 :: Opts String -> (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
+data MmapFile = MmapFile String
+
+instance ToJSON MmapFile where
+	toJSON (MmapFile f) = object ["file" .= f]
+
+instance FromJSON MmapFile where
+	parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file"
+
+-- | 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
+	| otherwise = withSync (responseError "timeout" []) $ \sync -> timeout 10000000 $
+		withName mmapPool $ \mmapName -> do
+			runErrorT $ flip catchError
+				(\e -> liftIO $ sync $ responseError e [])
+				(withMapFile mmapName (L.toStrict msg) $ liftIO $ do
+					sync $ result $ MmapFile mmapName
+					-- give 10 seconds for client to read data
+					threadDelay 10000000)
+	where
+		msg = encode r
+#endif
+
+-- | If response points to mmap, get its contents and parse
+unMmap :: Response -> IO Response
+#if mingw32_HOST_OS
+unMmap (Right (Result v))
+	| Just (MmapFile f) <- parseMaybe parseJSON v = do
+		cts <- runErrorT (fmap L.fromStrict (readMapFile f))
+		case cts of
+			Left e -> return $ responseError "Unable to read map view of file" ["file" .= f]
+			Right r' -> case eitherDecode r' of
+				Left e' -> return $ responseError "Invalid response" ["response" .= fromUtf8 r', "parser error" .= e']
+				Right r'' -> return r''
+#endif
+unMmap r = return r
+
+-- | Log message
+logMsg :: Opts String -> String -> IO ()
+logMsg sopts s = ignoreIO $ do
+	putStrLn s
+	case arg "log" sopts of
+		Nothing -> return ()
+		Just f -> withFile f AppendMode (`hPutStrLn` s)
+ src/HsDev/Server/Message.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances #-}
+
+module HsDev.Server.Message (
+	Message(..),
+	messagesById,
+	Request(..), requestToArgs,
+	withOpts, withoutOpts,
+	Notification(..), Result(..),
+	Response(..), notification, result, responseError,
+	groupResponses, responsesById
+	) where
+
+import Control.Arrow (first)
+import Control.Applicative
+import Control.Monad (join)
+import Data.Aeson hiding (Error, Result)
+import Data.Aeson.Types (Pair)
+import Data.Either (lefts, isRight)
+import Data.List (unfoldr)
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Monoid (mempty, mconcat)
+import Data.Foldable (Foldable(foldMap))
+import Data.Text (unpack)
+import Data.Traversable (Traversable(traverse))
+
+import System.Console.Args hiding (withOpts)
+import HsDev.Util ((.::), (.::?), objectUnion)
+
+-- | Message with id to link request and response
+data Message a = Message {
+	messageId :: Maybe String,
+	message :: a }
+		deriving (Eq, Ord, Functor)
+
+instance ToJSON a => ToJSON (Message a) where
+	toJSON (Message i m) = object ["id" .= i] `objectUnion` toJSON m
+
+instance FromJSON a => FromJSON (Message a) where
+	parseJSON = withObject "message" $ \v ->
+		Message <$> (fmap join (v .::? "id")) <*> parseJSON (Object v)
+
+instance Foldable Message where
+	foldMap f (Message i m) = f m
+
+instance Traversable Message where
+	traverse f (Message i m) = Message i <$> f m
+
+-- | Get messages by id
+messagesById :: Maybe String -> [Message a] -> [a]
+messagesById i = map message . filter ((== i) . messageId)
+
+-- | Request from client
+data Request = Request {
+	requestCommand :: String,
+	requestArgs :: [String],
+	requestOpts :: Opts String }
+
+requestToArgs :: Request -> Args
+requestToArgs (Request c as opts) = Args (words c ++ as) opts
+
+instance ToJSON Request where
+	toJSON (Request c as os) = object [
+		"command" .= c,
+		"args" .= as,
+		"opts" .= os]
+
+instance FromJSON Request where
+	parseJSON = withObject "request" $ \v -> Request <$>
+		v .:: "command" <*>
+		(fromMaybe [] <$> v .::? "args") <*>
+		(fromMaybe mempty <$> v .::? "opts")
+
+-- | Add options to request
+withOpts :: Request -> [Opts String] -> Request
+withOpts r os = r {
+	requestOpts = mconcat (requestOpts r : os) }
+
+-- | Remove options from request
+withoutOpts :: Request -> [String] -> Request
+withoutOpts r os = r {
+	requestOpts = Opts $ foldr (.) id (map M.delete os) $ getOpts (requestOpts r) }
+
+-- | Notification from server
+data Notification = Notification Value
+
+instance ToJSON Notification where
+	toJSON (Notification v) = object ["notify" .= v]
+
+instance FromJSON Notification where
+	parseJSON = withObject "notification" $ \v -> Notification <$> v .:: "notify"
+
+-- | Result from server
+data Result =
+	Result Value |
+	-- ^ Result
+	Error String (Map String Value)
+	-- ^ Error
+
+instance ToJSON Result where
+	toJSON (Result r) = object [
+		"result" .= r]
+	toJSON (Error msg rs) = object [
+		"error" .= msg,
+		"details" .= toJSON rs]
+
+instance FromJSON Result where
+	parseJSON = withObject "result" $ \v -> foldr1 (<|>) [
+		Result <$> v .:: "result",
+		Error <$> v .:: "error" <*> v .:: "details"]
+
+type Response = Either Notification Result
+
+notification :: ToJSON a => a -> Response
+notification = Left . Notification . toJSON
+
+result :: ToJSON a => a -> Response
+result = Right . Result . toJSON
+
+responseError :: String -> [Pair] -> Response
+responseError e ds = Right $ Error e $ M.fromList $ map (first unpack) ds
+
+instance ToJSON Response where
+	toJSON (Left n) = toJSON n
+	toJSON (Right r) = toJSON r
+
+instance FromJSON Response where
+	parseJSON v = (Left <$> parseJSON v) <|> (Right <$> parseJSON v)
+
+groupResponses :: [Response] -> [([Notification], Result)]
+groupResponses = unfoldr break' where
+	break' :: [Response] -> Maybe (([Notification], Result), [Response])
+	break' [] = Nothing
+	break' cs =  Just ((lefts ns, r), drop 1 cs') where
+		(ns, cs') = break isRight cs
+		r = case cs' of
+			(Right r' : _) -> r'
+			[] -> Error "groupResponses: no result" mempty
+
+responsesById :: Maybe String -> [Message Response] -> [([Notification], Result)]
+responsesById i = groupResponses . messagesById i
+ src/HsDev/Server/Types.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances #-}
+
+module HsDev.Server.Types (
+	CommandOptions(..), CommandError(..), commandError,
+	CommandAction, CommandM, CommandActionT,
+	ResultValue(..)
+	) where
+
+import Control.Applicative
+import Control.Monad.Error
+import Data.Aeson hiding (Result, Error)
+import Data.Aeson.Types (Pair)
+import qualified Data.HashMap.Strict as HM (null)
+import Data.Map (Map)
+
+import HsDev.Database
+import qualified HsDev.Database.Async as DB
+import HsDev.Project
+import HsDev.Symbols
+import HsDev.Server.Message
+import HsDev.Tools.GhcMod (OutputMessage, TypedRegion)
+
+#if mingw32_HOST_OS
+import System.Win32.FileMapping.NamePool (Pool)
+#endif
+
+data CommandOptions = CommandOptions {
+	commandDatabase :: DB.Async Database,
+	commandWriteCache :: Database -> IO (),
+	commandReadCache :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database),
+	commandRoot :: FilePath,
+	commandLog :: String -> IO (),
+	commandLogWait :: IO (),
+#if mingw32_HOST_OS
+	commandMmapPool :: Maybe Pool,
+#endif
+	commandNotify :: Notification -> IO (),
+	commandLink :: IO (),
+	commandHold :: IO (),
+	commandExit :: IO () }
+
+data CommandError = CommandError String [Pair]
+
+instance Control.Monad.Error.Error CommandError where
+	noMsg = CommandError noMsg []
+	strMsg m = CommandError m []
+
+commandError :: String -> [Pair] -> ErrorT CommandError IO a
+commandError m ps = throwError $ CommandError m ps
+
+type CommandAction = CommandOptions -> IO Result
+
+type CommandM a = ErrorT CommandError IO a
+
+type CommandActionT a = CommandOptions -> CommandM a
+
+data ResultValue =
+	ResultDatabase Database |
+	ResultDeclaration Declaration |
+	ResultModuleDeclaration ModuleDeclaration |
+	ResultModuleId ModuleId |
+	ResultModule Module |
+	ResultInspectedModule InspectedModule |
+	ResultPackage ModulePackage |
+	ResultProject Project |
+	ResultTyped TypedRegion |
+	ResultOutputMessage OutputMessage |
+	ResultList [ResultValue] |
+	ResultMap (Map String ResultValue) |
+	ResultJSON Value |
+	ResultString String |
+	ResultNone
+
+instance ToJSON ResultValue where
+	toJSON (ResultDatabase db) = toJSON db
+	toJSON (ResultDeclaration d) = toJSON d
+	toJSON (ResultModuleDeclaration md) = toJSON md
+	toJSON (ResultModuleId mid) = toJSON mid
+	toJSON (ResultModule m) = toJSON m
+	toJSON (ResultInspectedModule m) = toJSON m
+	toJSON (ResultPackage p) = toJSON p
+	toJSON (ResultProject p) = toJSON p
+	toJSON (ResultTyped t) = toJSON t
+	toJSON (ResultOutputMessage e) = toJSON e
+	toJSON (ResultList l) = toJSON l
+	toJSON (ResultMap m) = toJSON m
+	toJSON (ResultJSON v) = toJSON v
+	toJSON (ResultString s) = toJSON s
+	toJSON ResultNone = toJSON $ object []
+
+instance FromJSON ResultValue where
+	parseJSON v = foldr1 (<|>) [
+		do
+			(Object m) <- parseJSON v
+			if HM.null m then return ResultNone else mzero,
+		ResultDatabase <$> parseJSON v,
+		ResultDeclaration <$> parseJSON v,
+		ResultModuleDeclaration <$> parseJSON v,
+		ResultModuleId <$> parseJSON v,
+		ResultModule <$> parseJSON v,
+		ResultInspectedModule <$> parseJSON v,
+		ResultPackage <$> parseJSON v,
+		ResultProject <$> parseJSON v,
+		ResultTyped <$> parseJSON v,
+		ResultOutputMessage <$> parseJSON v,
+		ResultList <$> parseJSON v,
+		ResultMap <$> parseJSON v,
+		pure $ ResultJSON v,
+		ResultString <$> parseJSON v]
src/HsDev/Tools/Cabal.hs view
@@ -8,7 +8,6 @@ import Control.Arrow
 import Control.Applicative
 import Control.Monad
-import Control.Monad.Error
 import Data.Aeson
 import Data.Char (isSpace)
 import Data.Maybe
src/HsDev/Tools/GhcMod.hs view
@@ -5,7 +5,10 @@ 	browse, browseInspection,
 	info,
 	TypedRegion(..),
-	typeOf
+	typeOf,
+	OutputMessage(..),
+	check,
+	lint
 	) where
 
 import Control.Applicative
@@ -139,6 +142,53 @@ 		parseRegion = Region <$> parsePosition <*> parsePosition
 		parsePosition :: ReadM Position
 		parsePosition = Position <$> readParse <*> readParse
+
+data OutputMessage = OutputMessage {
+	errorLocation :: Location,
+	errorWarning :: Bool,
+	errorMessage :: String }
+		deriving (Eq, Show)
+
+instance NFData OutputMessage where
+	rnf (OutputMessage l w m) = rnf l `seq` rnf w `seq` rnf m
+
+instance ToJSON OutputMessage where
+	toJSON (OutputMessage l w m) = object [
+		"location" .= l,
+		"warning" .= w,
+		"message" .= m]
+
+instance FromJSON OutputMessage where
+	parseJSON = withObject "error message" $ \v -> OutputMessage <$>
+		v .:: "location" <*>
+		v .:: "warning" <*>
+		v .:: "message"
+
+parseOutputMessage :: String -> Maybe OutputMessage
+parseOutputMessage s = do
+	groups <- match "^(.+):(\\d+):(\\d+):(\\s*Warning:)?\\s*(.*)$" s
+	return $ OutputMessage {
+		errorLocation = Location {
+			locationModule = FileModule (groups `at` 1) Nothing,
+			locationPosition = Position <$> readMaybe (groups `at` 2) <*> readMaybe (groups `at` 3) },
+		errorWarning = isJust (groups 4),
+		errorMessage = groups `at` 5 }
+
+check :: [String] -> Cabal -> [FilePath] -> Maybe Project -> ErrorT String IO [OutputMessage]
+check opts cabal files mproj = liftException $ do
+	cradle <- cradle cabal mproj
+	msgs <- lines <$> GhcMod.checkSyntax
+		(GhcMod.defaultOptions { GhcMod.ghcOpts = cabalOpt cabal ++ opts })
+		cradle
+		files
+	return $ mapMaybe parseOutputMessage msgs
+
+lint :: [String] -> FilePath -> ErrorT String IO [OutputMessage]
+lint opts file = liftException $ do
+	msgs <- lines <$> GhcMod.lintSyntax
+		(GhcMod.defaultOptions { GhcMod.hlintOpts = opts })
+		file
+	return $ mapMaybe parseOutputMessage msgs
 
 cradle :: Cabal -> Maybe Project -> IO GhcMod.Cradle
 cradle cabal Nothing = do
src/HsDev/Tools/HDocs.hs view
@@ -44,7 +44,7 @@ 	return $ setDocs d m
 
 hdocsProcess :: String -> [String] -> IO (Maybe (Map String String))
-hdocsProcess mname opts = handle onErr $ liftM (decode . L.pack) $ readProcess "hdocs" opts' "" where
+hdocsProcess mname opts = handle onErr $ liftM (decode . L.pack . last . lines) $ readProcess "hdocs" opts' "" where
 	opts' = mname : concat [["-g", opt] | opt <- opts]
 	onErr :: SomeException -> IO (Maybe a)
 	onErr _ = return Nothing
src/HsDev/Tools/Hayoo.hs view
@@ -130,7 +130,7 @@ -- | Search hayoo
 hayoo :: String -> ErrorT String IO HayooResult
 hayoo q = do
-	resp <- ErrorT $ fmap (show +++ rspBody) $ simpleHTTP (getRequest $ "http://holumbus.fh-wedel.de/hayoo/hayoo.json?query=" ++ urlEncode q)
+	resp <- ErrorT $ fmap (show +++ rspBody) $ simpleHTTP (getRequest $ "http://hayoo.fh-wedel.de/?query=" ++ urlEncode q)
 	ErrorT $ return $ eitherDecode $ L.pack resp
 
 -- | Remove tags in description
src/HsDev/Util.hs view
@@ -7,12 +7,14 @@ 	-- * String utils
 	tab, tabs, trim, split,
 	-- * Helper
-	(.::), (.::?),
+	(.::), (.::?), objectUnion,
 	-- * Exceptions
 	liftException, liftExceptionM, liftIOErrors,
 	eitherT,
 	-- * UTF-8
-	fromUtf8, toUtf8
+	fromUtf8, toUtf8,
+	-- * IO
+	hGetLineBS, logIO, ignoreIO
 	) where
 
 import Control.Arrow (second)
@@ -24,14 +26,17 @@ import Data.Aeson.Types (Parser)
 import Data.Char (isSpace)
 import Data.List (isPrefixOf, unfoldr)
-import qualified Data.HashMap.Strict as HM (HashMap, toList)
+import qualified Data.HashMap.Strict as HM (HashMap, toList, union)
+import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
 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
+import System.IO (Handle)
 
 -- | Get directory contents safely
 directoryContents :: FilePath -> IO [FilePath]
@@ -94,6 +99,13 @@ (.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> Parser (Maybe a)
 v .::? name = traverse parseJSON $ lookup name $ HM.toList v
 
+-- | Union two JSON objects
+objectUnion :: Value -> Value -> Value
+objectUnion (Object l) (Object r) = Object $ HM.union l r
+objectUnion (Object l) _ = Object l
+objectUnion _ (Object r) = Object r
+objectUnion _ _ = Null
+
 -- | 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
@@ -116,3 +128,14 @@ 
 toUtf8 :: String -> ByteString
 toUtf8 = T.encodeUtf8 . T.pack
+
+hGetLineBS :: Handle -> IO ByteString
+hGetLineBS = fmap L.fromStrict . B.hGetLine
+
+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 ())
+ src/HsDev/Version.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}
+
+module HsDev.Version (
+	cabalVersion
+	) where
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import Language.Haskell.TH
+
+cabalVersion :: ExpQ
+cabalVersion = do
+	s <- runIO (readFile "hsdev.cabal")
+	let
+		version = listToMaybe $ map (dropWhile isSpace) $ mapMaybe (stripPrefix "version:") $ lines s
+	maybe (fail "Can't detect version") (\v -> [e| v |]) version
+ src/System/Console/Args.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE FlexibleInstances, TupleSections #-}
+
+module System.Console.Args (
+	Args(..), Opts(..), Arg(..), Opt(..),
+	withOpts, defOpts, defArgs, selectOpts, splitOpts,
+	(%--), (%-?), hoist, has, arg, narg, iarg, listArg, flagSet,
+	flag, req, list,
+	desc, alias, short,
+	parse, parse_, tryParse, toArgs, info,
+
+	-- * Helpers
+	splitArgs, unsplitArgs, verify,
+
+	module Data.Help
+	) where
+
+import Control.Arrow
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Loops
+import Data.Aeson
+import Data.Char
+import qualified Data.HashMap.Strict as HM (HashMap, toList)
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Monoid
+import Data.Foldable (Foldable(foldMap))
+import Data.String (fromString)
+import qualified Data.Text as T
+import Data.Traversable (Traversable(traverse))
+import Text.Read (readMaybe)
+
+import Data.Help
+import Text.Format
+
+data Args = Args {
+	posArgs :: [String],
+	namedArgs :: Opts String }
+		deriving (Eq, Show)
+
+instance Monoid Args where
+	mempty = Args [] mempty
+	(Args largs lopts) `mappend` (Args rargs ropts) = Args (largs ++ rargs) (lopts `mappend` ropts)
+
+newtype Opts a = Opts { getOpts :: Map String [a] } deriving (Eq, Show)
+
+--instance Eq a => Eq (Opts a) where
+--	Opts l == Opts r = l == r
+
+instance Functor Opts where
+	fmap f = Opts . fmap (fmap f) . getOpts
+
+instance Foldable Opts where
+	foldMap f = foldMap (foldMap f) . getOpts
+
+instance Traversable Opts where
+	traverse f = fmap Opts . traverse (traverse f) . getOpts
+
+instance Monoid (Opts a) where
+	mempty = Opts mempty
+	(Opts l) `mappend` (Opts r) = Opts $ M.unionWith mappend l r
+
+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
+
+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
+
+data Arg = Flag | Required String | List String deriving (Eq, Ord, Show)
+
+argName :: Arg -> Maybe String
+argName Flag = Nothing
+argName (Required n) = Just n
+argName (List n) = Just $ n ++ "..."
+
+data Opt = Opt {
+	optName :: String,
+	optShort :: [Char],
+	optLong :: [String],
+	optDescription :: Maybe String,
+	optArg :: Arg }
+		deriving (Eq, Show)
+
+withOpts :: (Opts String -> Opts String) -> Args -> Args
+withOpts f (Args a o) = Args a (f o)
+
+-- | Set default values, if option doesn't present
+defOpts :: Opts String -> Opts String -> Opts String
+defOpts (Opts def) (Opts new) = Opts $ new `M.union` def
+
+defArgs :: Opts String -> Args -> Args
+defArgs = withOpts . defOpts
+
+selectOpts :: [Opt] -> Opts a -> Opts a
+selectOpts opts = Opts . M.filterWithKey (\n _ -> n `elem` optNames) . getOpts where
+	optNames = map optName opts
+
+splitOpts :: [Opt] -> Opts a -> (Opts a, Opts a)
+splitOpts opts = (Opts *** Opts) . M.partitionWithKey (\n _ -> n `elem` optNames) . getOpts where
+	optNames = map optName opts
+
+(%--) :: Format a => String -> a -> Opts String
+n %-- v = Opts $ M.singleton n [format v]
+
+(%-?) :: Format a => String -> Maybe a -> Opts String
+n %-? v = maybe mempty (n %--) v
+
+-- | Make 'Opts' with flag set
+hoist :: String -> Opts a
+hoist n = Opts $ M.singleton n []
+
+has :: String -> Opts a -> Bool
+has n = M.member n . getOpts
+
+-- | Get argument value
+arg :: String -> Opts a -> Maybe a
+arg n = (M.lookup n . getOpts) >=> listToMaybe
+
+-- | Get numeric value
+narg :: (Read a, Num a) => String -> Opts String -> Maybe a
+narg n = join . fmap readMaybe . arg n
+
+-- | Get integer value
+iarg :: String -> Opts String -> Maybe Integer
+iarg = narg
+
+-- | Get list argument
+listArg :: String -> Opts a -> [a]
+listArg n = fromMaybe [] . M.lookup n . getOpts
+
+-- | Is flag set
+flagSet :: String -> Opts a -> Bool
+flagSet n = isJust . M.lookup n . getOpts
+
+-- | Flag option
+flag :: String -> Opt
+flag n = Opt n [] [] Nothing Flag
+
+-- | Required option
+req :: String -> String -> Opt
+req n v = Opt n [] [] Nothing (Required v)
+
+-- | List option
+list :: String -> String -> Opt
+list n v = Opt n [] [] Nothing (List v)
+
+-- | Set description
+--
+-- >flag "quiet" `desc` "quiet mode"
+desc :: Opt -> String -> Opt
+desc o d = o { optDescription = Just d }
+
+-- | Set aliases
+--
+-- >fliag "quiet" `alias` 
+alias :: Opt -> [String] -> Opt
+alias o ls = o { optLong = optLong o ++ ls }
+
+-- | Shortcuts
+short :: Opt -> [Char] -> Opt
+short o ss = o { optShort = optShort o ++ ss }
+
+findOpt :: String -> [Opt] -> Maybe Opt
+findOpt n = find opt' where
+	opt' :: Opt -> Bool
+	opt' (Opt n' s l _ _) = n `elem` (n' : (map return s ++ l))
+
+parse :: [Opt] -> [String] -> Either String Args
+parse os = unfoldrM parseCmd >=> (verify os . mconcat) where
+	parseCmd :: [String] -> Either String (Maybe (Args, [String]))
+	parseCmd [] = Right Nothing
+	parseCmd (cmd:cmds)
+		| isFlag cmd = do
+			opt' <- lookOpt cmd os
+			case optArg opt' of
+				Flag -> Right $ Just (Args [] $ Opts $ M.singleton (optName opt') [], cmds)
+				Required _ -> case cmds of
+					(value:cmds')
+						| not (isFlag value) -> Right $ Just (Args [] $ Opts $ M.singleton (optName opt') [value], cmds')
+						| otherwise -> Left $ "No value specified for option '$'" ~~ optName opt'
+					[] -> Left $ "No value specified for option '" ++ optName opt' ++ "'"
+				List _ -> case cmds of
+					(value:cmds')
+						| not (isFlag value) -> Right $ Just (Args [] $ Opts $ M.singleton (optName opt') [value], cmds')
+						| otherwise -> Left $ "No value specified for option '$'" ~~ optName opt'
+					[] -> Left $ "No value specified for option '$'" ~~ optName opt'
+		| otherwise = Right $ Just (Args [cmd] mempty, cmds)
+
+	lookOpt :: String -> [Opt] -> Either String Opt
+	lookOpt n = maybe (Left $ "Invalid option '$'" ~~ n) Right . findOpt (dropWhile (== '-') n)
+
+-- | Parse with no options declarations
+parse_ :: [String] -> Args
+parse_ = mconcat . unfoldr parseCmd where
+	parseCmd :: [String] -> Maybe (Args, [String])
+	parseCmd [] = Nothing
+	parseCmd (cmd:cmds)
+		| isFlag cmd = case cmds of
+			(value:cmds')
+				| not (isFlag value) -> Just (Args [] $ Opts $ M.singleton cmd [value], cmds')
+				| otherwise -> Just (Args [] $ Opts $ M.singleton cmd [], cmds)
+			[] -> Just (Args [] $ Opts $ M.singleton cmd [], [])
+		| otherwise = Just (Args [cmd] mempty, cmds)
+
+tryParse :: [Opt] -> [String] -> Args
+tryParse os s = either (const $ parse_ s) id $ parse os s
+
+toArgs :: Args -> [String]
+toArgs (Args p o) = p ++ (concatMap toArgs' . M.toList . getOpts $ o) where
+	toArgs' :: (String, [String]) -> [String]
+	toArgs' (n, []) = ["--" ++ n]
+	toArgs' (n, vs) = concat [["--" ++ n, v] | v <- vs]
+
+instance Help Opt where
+	brief (Opt n _ _ _ arg') = concat [
+		longOpt n,
+		maybe "" (" " ++) $ argName arg']
+	help (Opt n ss ls desc' arg') = [concat [
+		unwords (map shortOpt ss ++ map longOpt (n : ls)),
+		maybe "" (" " ++) $ argName arg',
+		maybe "" (" -- " ++) desc']]
+
+instance Help [Opt] where
+	brief = unwords . map ((\s -> "[" ++ s ++ "]") . brief)
+	help = concatMap help
+
+info :: [Opt] -> String
+info = unlines . indented
+
+splitArgs :: String -> [String]
+splitArgs "" = []
+splitArgs (c:cs)
+	| isSpace c = splitArgs cs
+	| c == '"' = let (w, cs') = readQuote cs in w : splitArgs cs'
+	| otherwise = let (ws, tl) = break isSpace cs in (c:ws) : splitArgs tl
+	where
+		readQuote :: String -> (String, String)
+		readQuote "" = ("", "")
+		readQuote ('\\':ss)
+			| null ss = ("\\", "")
+			| otherwise = first (head ss :) $ readQuote (tail ss)
+		readQuote ('"':ss) = ("", ss)
+		readQuote (s:ss) = first (s:) $ readQuote ss
+
+unsplitArgs :: [String] -> String
+unsplitArgs = unwords . map escape where
+	escape :: String -> String
+	escape str
+		| any isSpace str || '"' `elem` str = "\"" ++ concat (unfoldr escape' str) ++ "\""
+		| otherwise = str
+	escape' :: String -> Maybe (String, String)
+	escape' [] = Nothing
+	escape' (ch:tl) = Just (escaped, tl) where
+		escaped = case ch of
+			'"' -> "\\\""
+			'\\' -> "\\\\"
+			_ -> [ch]
+
+verify :: [Opt] -> Args -> Either String Args
+verify os = withOpts' $ fmap (Opts . M.fromList) . mapM (uncurry verify') . M.toList . getOpts where
+	withOpts' :: Functor f => (Opts String -> f (Opts String)) -> Args -> f Args
+	withOpts' f (Args a o) = Args a <$> f o
+	verify' :: String -> [String] -> Either String (String, [String])
+	verify' n v = case findOpt n os of
+		Nothing -> Left $ "Invalid option '$'" ~~ n
+		Just opt -> maybe (Right (n, v)) Left $ case (optArg opt, v) of
+			(Flag, []) -> Nothing
+			(Flag, _) -> Just $ "Flag '$' has a value" ~~ n
+			(Required _, []) -> Just $ "No value for '$'" ~~ n
+			(Required _, [_]) -> Nothing
+			(Required _, _:_) -> Just $ "Too much values for '$'" ~~ n
+			(List _, []) -> Just $ "No values for '$'" ~~ n
+			(List _, _) -> Nothing
+
+isFlag :: String -> Bool
+isFlag ('-':'-':s) = not $ null s
+isFlag ('-':_:[]) = True
+isFlag _ = False
+
+longOpt :: String -> String
+longOpt = ("--" ++)
+
+shortOpt :: Char -> String
+shortOpt = ('-':) . return
+ src/System/Console/Cmd.hs view
@@ -0,0 +1,162 @@+module System.Console.Cmd (
+	CmdAction, notMatch, failMatch, runCmd, defaultOpts, validateArgs, alterArgs,
+	Cmd(..), cmdAct, cutName, cmda, cmda_, cmd, cmd_, defCmd,
+	CmdHelp(..), helpCommand, withHelp, printWith,
+	run, runArgs, runOn,
+
+	module System.Console.Args
+	) where
+
+import Control.Arrow
+import Control.Monad (join, (>=>))
+import Data.List (stripPrefix, unfoldr, isPrefixOf)
+import Control.Monad.Error
+import Data.Map (Map)
+import Data.Maybe (fromMaybe, mapMaybe, listToMaybe, maybeToList, isJust)
+import qualified Data.Map as M
+
+import System.Console.Args
+import Text.Format
+
+type CmdAction a = ErrorT String Maybe a
+
+-- | Arguments doesn't match command
+notMatch :: CmdAction a
+notMatch = lift Nothing
+
+-- | Invalid command arguments
+failMatch :: String -> CmdAction a
+failMatch = throwError
+
+data Cmd a = Cmd {
+	cmdName :: String,
+	cmdArgs :: [String],
+	cmdOpts :: [Opt],
+	cmdDesc :: String,
+	cmdGetArgs :: Args -> CmdAction Args,
+	-- ^ Get command arguments from source arguments, by default it cuts command name
+	cmdAction :: Args -> CmdAction a }
+
+instance Functor Cmd where
+	fmap f cmd' = cmd' {
+		cmdAction = fmap f . cmdAction cmd' }
+
+-- | Run cmd
+runCmd :: Cmd a -> Args -> CmdAction a
+runCmd c = cmdGetArgs c >=> cmdAction c
+
+-- | Set default opts
+defaultOpts :: Opts String -> Cmd a -> Cmd a
+defaultOpts opts = alterArgs (cmdAct $ withOpts $ defOpts opts)
+
+-- | Validate Args in command
+validateArgs :: (Args -> CmdAction ()) -> Cmd a -> Cmd a
+validateArgs p c = c {
+	cmdAction = \a -> p a >> cmdAction c a }
+
+-- | Alter Args in command
+alterArgs :: (Args -> CmdAction Args) -> Cmd a -> Cmd a
+alterArgs f c = c {
+	cmdGetArgs = f >=> cmdGetArgs c }
+
+-- | Make CmdAction function
+cmdAct :: (b -> a) -> b -> CmdAction a
+cmdAct f = return . f
+
+-- | Cut name of command from arguments and checks if it matches
+--
+-- > cutName >=> cmdAct act
+cutName :: String -> Args -> CmdAction Args
+cutName name args@(Args as os) = case stripPrefix (words name) as of
+	Just as' -> return (Args as' os)
+	Nothing -> notMatch
+
+verifyOpts :: [Opt] -> Args -> CmdAction Args
+verifyOpts os = ErrorT . Just . verify os
+
+cmda :: String -> [String] -> [Opt] -> String -> (Args -> CmdAction a) -> Cmd a
+cmda name as os desc act = Cmd {
+	cmdName = name,
+	cmdArgs = as,
+	cmdOpts = os,
+	cmdDesc = desc,
+	cmdGetArgs = cut',
+	cmdAction = verifyOpts os >=> act }
+	where
+		cut'
+			| null name = return
+			| otherwise = cutName name
+
+cmda_ :: String -> [Opt] -> String -> (Opts String -> CmdAction a) -> Cmd a
+cmda_ name os desc act = validateArgs noPos $ cmda name [] os desc (act . namedArgs) where
+	noPos (Args [] _) = return ()
+	noPos (Args _ _) = failMatch "No positional argument expected"
+
+cmd :: String -> [String] -> [Opt] -> String -> (Args -> a) -> Cmd a
+cmd name as os desc act = cmda name as os desc (cmdAct act)
+
+cmd_ :: String -> [Opt] -> String -> (Opts String -> a) -> Cmd a
+cmd_ name os desc act = cmda_ name os desc (cmdAct act)
+
+-- | Unnamed command
+defCmd :: [String] -> [Opt] -> String -> (Args -> a) -> Cmd a
+defCmd as os desc act = cmda "" as os desc (cmdAct act)
+
+data CmdHelp =
+	HelpUsage [String] |
+	HelpCommands [(String, [String])]
+		deriving (Eq, Ord, Read, Show)
+
+-- | Make help command, which will show help on for specified commands
+helpCommand :: String -> (Either String CmdHelp -> a) -> [Cmd a] -> Cmd a
+helpCommand tool toCmd cmds = helpcmd where
+	helpcmd = fmap toCmd $ alterArgs (cmdAct checkHelp) $ cmd
+		"help"
+		["command"]
+		[flag "help" `short` ['?'] `desc` "show help (when using form 'command -?' or 'command --help')"]
+		("help command, can be called in form '$ [command] -?' or '$ [command] --help" ~~ tool % tool)
+		onHelp
+	checkHelp :: Args -> Args
+	checkHelp a
+		| flagSet "help" (namedArgs a) = a {
+			posArgs = "help" : posArgs a,
+			namedArgs = Opts $ M.delete "help" $ getOpts $ namedArgs a }
+		| otherwise = a
+	onHelp (Args [] _) = Right $ HelpUsage [tool ++ " " ++ brief c | c <- (helpcmd:cmds)]
+	onHelp (Args cmdname _) = case filter ((cmdname ==) . words . cmdName) (helpcmd:cmds) of
+		[] -> Left $ "Unknown command: " ++ unwords cmdname
+		helps -> Right $ HelpCommands $ map (cmdName &&& (addHeader . indented)) helps
+	addHeader [] = []
+	addHeader (h:hs) = (tool ++ " " ++ h) : hs
+
+-- | Add help command
+withHelp :: String -> (Either String CmdHelp -> a) -> [Cmd a] -> [Cmd a]
+withHelp tool toCmd cmds = helpCommand tool toCmd cmds : cmds
+
+printWith :: (String -> a) -> (Either String CmdHelp -> a)
+printWith fn = fn . either id (unlines . print') where
+	print' :: CmdHelp -> [String]
+	print' (HelpUsage u) = map ('\t':) u
+	print' (HelpCommands cs) = map ('\t':) $ concatMap snd cs
+
+instance Help (Cmd a) where
+	brief c = unwords $ filter (not . null) $ [cmdName c, unwords (map angled (cmdArgs c)), brief (cmdOpts c)] ++ desc' where
+		angled s = "<" ++ s ++ ">"
+		desc'
+			| null (cmdDesc c) = []
+			| otherwise = ["-- " ++ cmdDesc c]
+	help = help . cmdOpts
+
+-- | Run commands
+run :: [Cmd a] -> a -> (String -> a) -> [String] -> a
+run cmds onDef onError = runOn cmds onDef onError (tryParse . cmdOpts)
+
+-- | Run commands with parsed args
+runArgs :: [Cmd a] -> a -> (String -> a) -> Args -> a
+runArgs cmds onDef onError = runOn cmds onDef onError (const id)
+
+-- | Run commands with 
+runOn :: [Cmd a] -> a -> (String -> a) -> (Cmd a -> c -> Args) -> c -> a
+runOn cmds onDef onError f as = maybe onDef (either onError id) found where
+	found = listToMaybe $ mapMaybe (runErrorT . (`act` as)) cmds
+	act c = runCmd c . f c
+ src/System/Win32/FileMapping/Memory.hs view
@@ -0,0 +1,57 @@+module System.Win32.FileMapping.Memory (
+	createMap, openMap, mapFile,
+	withMapFile, readMapFile
+	) where
+
+import Control.Monad.CatchIO (bracket)
+import Control.Monad.Cont
+import Control.Monad.Error
+import Data.ByteString.Char8
+import qualified Data.ByteString.Char8 as BS
+import Foreign.Ptr
+import System.Win32.File (closeHandle)
+import System.Win32.FileMapping hiding (mapFile)
+import System.Win32.Types
+import System.Win32.Mem
+
+createMap :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> ContT r (ErrorT String IO) HANDLE
+createMap mh pf sz mn = ContT $ bracket
+	(verify iNVALID_HANDLE_VALUE "Invalid handle" $
+		liftIO (createFileMapping mh pf sz mn))
+	(liftIO . closeHandle)
+
+openMap :: FileMapAccess -> Bool -> Maybe String -> ContT r (ErrorT String IO) HANDLE
+openMap f i mn = ContT $ bracket
+	(verify iNVALID_HANDLE_VALUE "Invalid handle" $
+		liftIO (openFileMapping f i mn))
+	(liftIO . closeHandle)
+
+mapFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> ErrorT String IO (Ptr a)
+mapFile h f off sz = verify nullPtr "null pointer" $ liftIO (mapViewOfFile h f off sz) 
+
+-- | Write data to named map view of file
+withMapFile :: String -> ByteString -> IO a -> ErrorT String IO a
+withMapFile name str act = flip runContT return $ do
+	p <- ContT $ \f -> ErrorT (BS.useAsCString str (runErrorT . f))
+	h <- createMap Nothing pAGE_READWRITE (fromIntegral len) (Just name)
+	ptr <- lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
+	liftIO $ do
+		copyMemory ptr p (fromIntegral len)
+		unmapViewOfFile ptr
+		act
+	where
+		len = BS.length str + 1
+
+-- | Read data from named map view of file
+readMapFile :: String -> ErrorT String IO ByteString
+readMapFile name = flip runContT return $ do
+	h <- openMap fILE_MAP_ALL_ACCESS True (Just name)
+	ptr <- lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
+	liftIO $ BS.packCString ptr
+
+verify :: (Error e, MonadError e m, Eq a) => a -> String -> m a -> m a
+verify v str act = do
+	x <- act
+	if x == v
+		then throwError (strMsg str)
+		else return x
+ src/System/Win32/FileMapping/NamePool.hs view
@@ -0,0 +1,31 @@+module System.Win32.FileMapping.NamePool (
+	Pool(..),
+	createPool, withName
+	) where
+
+import Control.Concurrent
+import Control.Exception (bracket)
+import Control.Monad (liftM, liftM2)
+import System.Win32.FileMapping.Memory ()
+
+-- | Pool of names for memory mapped files
+data Pool = Pool {
+	poolFreeNames :: MVar [String],
+	poolNewName :: IO String }
+
+-- | Create pool of numbered names by base name
+createPool :: String -> IO Pool
+createPool baseName = liftM2 Pool (newMVar []) mkNewName where
+	mkNewName :: IO (IO String)
+	mkNewName = do
+		num <- newMVar 0
+		return $ modifyMVar num $ \n -> do
+			return (succ n, baseName ++ show n)
+
+-- | Use free name from pool
+withName :: Pool -> (String -> IO a) -> IO a
+withName p act = bracket getName freeName act where
+	getName = modifyMVar (poolFreeNames p) $ \names -> case names of
+		[] -> liftM ((,) []) $ poolNewName p
+		(n:ns) -> return (ns, n)
+	freeName name = modifyMVar_ (poolFreeNames p) (return . (name:))
src/System/Win32/PowerShell.hs view
@@ -9,7 +9,7 @@ 	PS(..), seqPS, emit, emit_, (=:), invoke,
 	-- * Expression
 	Args(..), CmdLet(..), Expr(..), compile,
-	raw, name, lit, var, bra, (.=), flag, named, call, cmdlet, invoke, lambda, (.|), foreach, filter,
+	raw, name, lit, var, bra, (.=), flag, named, call, cmdlet, lambda, (.|), foreach, filter,
 	-- * Convertible
 	ToPS(..),
 	-- * Escape functions
@@ -59,7 +59,7 @@ 
 infixr 6 =:
 (=:) :: String -> Expr -> PS Expr
-name =: expr = emit_ (name .= expr) >> return (var name)
+n =: expr = emit_ (n .= expr) >> return (var n)
 
 -- | Invoke cmdlet
 invoke :: CmdLet -> PS ()
@@ -104,11 +104,11 @@ compile (Var v) = '$':v
 compile (Bracket e) = "(" ++ compile e ++ ")"
 compile (Assign vs es) = intercalate ", " (map ('$':) vs) ++ " = " ++ intercalate ", " (map (compile . bra) es)
-compile (Invoke (CmdLet e (Args ps ns))) = unwords [invoke', ps', ns'] where
+compile (Invoke (CmdLet e (Args p ns))) = unwords [invoke', p', ns'] where
 	invoke' = case e of
 		Var n -> n
 		_ -> unwords ["&", compile $ bra e]
-	ps' = intercalate " " $ map (compile . bra) ps
+	p' = intercalate " " $ map (compile . bra) p
 	ns' = intercalate " " $ concatMap named' $ M.toList ns where
 		named' :: (String, Maybe Expr) -> [String]
 		named' (n, Just v) = [n, compile $ bra v]
@@ -146,7 +146,7 @@ named n e = (n, Just e)
 
 call :: Expr -> [Expr] -> [(String, Maybe Expr)] -> CmdLet
-call f pos named = CmdLet f $ Args pos (M.fromList named)
+call f pos named' = CmdLet f $ Args pos (M.fromList named')
 
 cmdlet :: String -> [Expr] -> [(String, Maybe Expr)] -> CmdLet
 cmdlet n pos = call (name n) pos
@@ -181,13 +181,13 @@ 	toPS = intercalate ", " . map toPS
 
 translate :: String -> String
-translate str = '"' : snd (foldr escape (True, "\"") str) where
-	escape '"' (b, str) = (True, '\\' : '"' : str)
-	escape '\\' (True, str) = (True, '\\' : '\\' : str)
-	escape '\\' (False, str) = (False, '\\' : str)
-	escape c (b, str) = (False, c : str)
+translate s = '"' : snd (foldr escape (True, "\"") s) where
+	escape '"' (_, s') = (True, '\\' : '"' : s')
+	escape '\\' (True, s') = (True, '\\' : '\\' : s')
+	escape '\\' (False, s') = (False, '\\' : s')
+	escape c (b, s') = (False, c : s')
 
 translateArg :: String -> String
-translateArg str
-	| all isAlphaNum str = str
-	| otherwise = "'" ++ translate str ++ "'"
+translateArg s
+	| all isAlphaNum s = s
+	| otherwise = "'" ++ translate s ++ "'"
+ src/Text/Format.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
+
+-- | Format module
+--
+-- >"My name is $, I am ${age} years old, I am from $" %~ ("Vasya" % ("age" %= 20) % "Moscow")
+-- >"My name is Vasya, I am 20 years old"
+module Text.Format (
+	Format(..), FormatArgs, Hole(..),
+	(%~), (~~), (%), (%=)
+	) where
+
+import Control.Arrow (first)
+import Data.List (delete, isSuffixOf)
+import Text.Regex.Posix
+
+class Format a where
+	format :: a -> String
+
+instance Format String where
+	format = id
+instance Format Int where
+	format = show
+instance Format Integer where
+	format = show
+
+type FormatArgs = [(Maybe String, String)]
+
+class Hole a where
+	hole :: a -> FormatArgs
+
+instance Hole FormatArgs where
+	hole = id
+
+instance Format a => Hole a where
+	hole v = [(Nothing, format v)]
+
+instance Format a => Hole (String, a) where
+	hole (n, v) = [(Just n, format v)]
+
+instance Hole [(String, String)] where
+	hole = map (first Just)
+
+infixr 1 %~
+
+(%~) :: Hole a => String -> a -> Either String String
+fmt %~ hargs = case fmt =~ "\\$({([a-zA-Z]+)})?" of
+	(pre, "", "", []) -> Right pre
+	(pre, _, post, []) -> Right $ pre ++ post
+	(pre, _, post, gs) -> do
+		let
+			name = case gs of
+				_:name':_ -> name'
+				_ -> ""
+		(arg', args') <- split' name
+		post' <- post %~ args'
+		return $ concat [
+			pre,
+			if "$" `isSuffixOf` pre then name else arg',
+			post']
+	where
+		args = hole hargs
+
+		split' :: String -> Either String (String, FormatArgs)
+		split' n = maybe
+			(Left $ maybe
+				(concat [
+					"Format: not enough arguments for format string '",
+					fmt,
+					"'"])
+				("Format argument '$' not found" ~~) n')
+			(\v -> Right (v, delete (n', v) args))
+			(lookup n' args)
+			where
+				n'
+					| null n = Nothing
+					| otherwise = Just n
+
+infixr 1 ~~
+
+(~~) :: Hole a => String -> a -> String
+fmt ~~ hargs = either error id $ fmt %~ hargs
+
+infixr 5 %
+
+(%) :: (Hole a, Hole b) => a -> b -> FormatArgs
+x % y = hole x ++ hole y
+
+infixr 1 %=
+
+(%=) :: Format a => String -> a -> (String, String)
+name %= value = (name, format value)
− tools/Commands.hs 
@@ -1,1073 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP, TupleSections #-}
-
-module Commands (
-	mainCommands, commands
-	) where
-
-import Control.Applicative
-import Control.Arrow
-import Control.Monad
-import Control.Monad.Error
-import Control.Monad.Trans.Maybe
-import Control.Exception
-import Control.Concurrent
-import Data.Aeson
-import Data.Aeson.Encode.Pretty
-import Data.Aeson.Types
-import Data.Char
-import Data.Either
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import qualified Data.ByteString.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as L
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Traversable (traverse)
-import Network.Socket
-import System.Directory
-import System.Environment
-import System.Exit
-import System.IO
-import System.Process
-import System.Console.GetOpt
-import System.Timeout
-import System.FilePath
-import Text.Read (readMaybe)
-
-import qualified HsDev.Database.Async as DB
-import HsDev.Commands
-import HsDev.Database
-import HsDev.Project
-import HsDev.Symbols
-import HsDev.Symbols.Util
-import HsDev.Util
-import HsDev.Scan
-import qualified HsDev.Tools.Cabal as Cabal
-import qualified HsDev.Tools.GhcMod as GhcMod (typeOf)
-import qualified HsDev.Tools.Hayoo as Hayoo
-import qualified HsDev.Cache.Structured as SC
-import HsDev.Cache
-
-import qualified Control.Concurrent.FiniteChan as F
-import System.Command
-
-#if mingw32_HOST_OS
-import System.Win32.FileMapping.Memory (withMapFile, readMapFile)
-import System.Win32.FileMapping.NamePool
-#else
-import System.Posix.Process
-import System.Posix.IO
-#endif
-
-import qualified Update
-import Types
-
-#if mingw32_HOST_OS
-
-translate :: String -> String
-translate str = '"' : snd (foldr escape (True,"\"") str) where
-	escape '"'  (b, str) = (True,  '\\' : '"'  : str)
-	escape '\\' (True, str) = (True,  '\\' : '\\' : str)
-	escape '\\' (False, str) = (False, '\\' : str)
-	escape c (b, str) = (False, c : str)
-
-powershell :: String -> String
-powershell str
-	| all isAlphaNum str = str
-	| otherwise = "'" ++ translate str ++ "'"
-
-#endif
-
--- | Main commands
-mainCommands :: [Command (IO ())]
-mainCommands = addHelp "hsdev" id $ srvCmds ++ map wrapCmd commands where
-	wrapCmd :: Command CommandAction -> Command (IO ())
-	wrapCmd = fmap sendCmd . addClientOpts . fmap withOptsCommand
-	srvCmds = [
-		cmd ["server", "start"] [] "start remote server" serverOpts start',
-		cmd ["server", "run"] [] "start server" serverOpts run',
-		cmd ["server", "stop"] [] "stop remote server" clientOpts stop',
-		cmd ["connect"] [] "connect to send commands directly" clientOpts connect']
-
-	start' sopts _ = do
-#if mingw32_HOST_OS
-		let
-			args = ["server", "run"] ++ serverOptsToArgs sopts
-		myExe <- getExecutablePath
-		r <- readProcess "powershell" [
-			"-Command",
-			unwords [
-				"&", "{", "start-process",
-				powershell myExe,
-				intercalate ", " (map powershell args),
-				"-WindowStyle Hidden",
-				"}"]] ""
-		if all isSpace r
-			then putStrLn $ "Server started at port " ++ show (fromJust $ getFirst $ serverPort sopts)
-			else putStrLn $ "Failed to start server: " ++ r
-#else
-		let
-			forkError :: SomeException -> IO ()
-			forkError e  = putStrLn $ "Failed to start server: " ++ show e
-
-			proxy :: IO ()
-			proxy = do
-				createSession
-				forkProcess serverAction
-				exitImmediately ExitSuccess
-
-			serverAction :: IO ()
-			serverAction = do
-				mapM_ closeFd [stdInput, stdOutput, stdError]
-				nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
-				mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError]
-				closeFd nullFd
-				run' sopts []
-
-		handle forkError $ do
-			forkProcess proxy
-			putStrLn $ "Server started at port " ++ show (fromJust $ getFirst $ serverPort sopts)
-#endif
-	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
-
-			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
-				listen s maxListenQueue
-				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
-								let
-									timeoutWait = do
-										notDone <- isEmptyMVar done
-										when notDone $ do
-											void $ forkIO $ do
-												threadDelay 1000000
-												tryPutMVar done ()
-												killThread me
-											takeMVar done
-									waitForever = forever $ hGetLine' h
-								F.putChan clientChan timeoutWait
-								processClient (show s') (hGetLine' h) (L.hPutStrLn h) sopts (copts {
-									commandHold = waitForever,
-									commandExit = serverStop })
-
-			takeMVar waitListen
-			DB.readAsync (commandDatabase copts) >>= writeCache sopts (commandLog copts)
-			F.stopChan clientChan >>= sequence_
-			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 . (copts,) . withOptsCommand)
-
-	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
-
-			waitResp h = do
-				resp <- hGetLine' h
-				parseResp h resp
-
-			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 :: (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
-				stdinData <- if getAny (clientData p)
-					then do
-						cdata <- liftM (eitherDecode :: L.ByteString -> Either String Value) L.getContents
-						case cdata of
-							Left cdataErr -> do
-								putStrLn $ "Invalid data: " ++ cdataErr
-								exitFailure
-							Right dataValue -> return $ Just dataValue
-					else return Nothing
-
-				s <- socket AF_INET Stream defaultProtocol
-				addr' <- inet_addr "127.0.0.1"
-				connect s (SockAddrInet (fromIntegral $ fromJust $ getFirst $ clientPort p) addr')
-				h <- socketToHandle s ReadWriteMode
-				L.hPutStrLn h $ encode $ cmdCall `addCallOpts` [
-					"current-directory" %-- curDir,
-					case stdinData of
-						Nothing -> mempty
-						Just d -> "data" %-- (fromUtf8 $ encode d)]
-				peekResponse h
-
-			peekResponse h = do
-				resp <- hGetLine' h
-				parseResponse h resp
-
-			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
-					ResponseStatus s -> liftIO $ do
-						L.putStrLn $ encodeValue s
-						peekResponse 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 $ parseResponse 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))
-
-	-- Add parsing 'ClieptOpts'
-	addClientOpts :: Command CommandCall -> Command (ClientOpts, CommandCall)
-	addClientOpts c = c { commandRun = run' } where
-		run' args = fmap (fmap (p,)) $ commandRun c args' where
-			(ps, args', _) = getOpt RequireOrder clientOpts args
-			p = mconcat ps `mappend` defaultConfig
-
--- | 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)
-	timeout' f tm copts = fmap (fromMaybe $ err "timeout") $ timeout (tm * 1000) $ f copts
-	noTimeout :: (CommandOptions -> IO CommandResult) -> (Int -> CommandOptions -> IO CommandResult)
-	noTimeout f _ copts = f copts
-
-	handleErrors :: (Int -> CommandOptions -> IO CommandResult) -> (Int -> CommandOptions -> IO CommandResult)
-	handleErrors act tm copts = handle onCmdErr (act tm copts) where
-		onCmdErr :: SomeException -> IO CommandResult
-		onCmdErr = return . err . show
-
-	wrapErrors :: Command CommandAction -> Command CommandAction
-	wrapErrors = fmap (fmap handleErrors)
-
-	cmds = [
-		-- Ping command
-		cmd_' ["ping"] [] "ping server" ping',
-		-- Database commands
-		cmd' ["add"] [] "add info to database" [dataArg] add',
-		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",
-			pathArg "directory to scan for files and projects",
-			ghcOpts, wait, status] scan',
-		cmd' ["rescan"] [] "rescan sources" [
-			projectArg "project path or .cabal",
-			fileArg "source file",
-			pathArg "path to rescan",
-			ghcOpts, wait, status] rescan',
-		cmd' ["remove"] [] "remove modules info" (sandboxes ++ [
-			projectArg "module project",
-			fileArg "module source file",
-			moduleArg,
-			packageArg, noLastArg, packageVersionArg,
-			allFlag]) remove',
-		-- | Context free commands
-		cmd' ["list", "modules"] [] "list modules" (sandboxes ++ [
-			projectArg "projects to list modules from",
-			noLastArg,
-			packageArg,
-			sourced, standaloned]) listModules',
-		cmd_' ["list", "packages"] [] "list packages" listPackages',
-		cmd_' ["list", "projects"] [] "list projects" listProjects',
-		cmd' ["symbol"] ["name"] "get symbol info" (matches ++ sandboxes ++ [
-			projectArg "related project",
-			fileArg "source file",
-			moduleArg, localsArg,
-			packageArg, noLastArg, packageVersionArg,
-			sourced, standaloned]) symbol',
-		cmd' ["module"] [] "get module info" (sandboxes ++ [
-			moduleArg, localsArg,
-			packageArg, noLastArg, packageVersionArg,
-			projectArg "module project",
-			fileArg "module source file",
-			sourced]) modul',
-		cmd' ["project"] [] "get project info" [
-			projectArg "project path or name"] project',
-		-- Context commands
-		cmd' ["lookup"] ["symbol"] "lookup for symbol" ctx lookup',
-		cmd' ["whois"] ["symbol"] "get info for symbol" ctx whois',
-		cmd' ["scope", "modules"] [] "get modules accessible from module or within a project" ctx scopeModules',
-		cmd' ["scope"] [] "get declarations accessible from module or within a project" (ctx ++ matches ++ [globalArg]) scope',
-		cmd' ["complete"] ["input"] "show completions for input" ctx complete',
-		-- Tool commands
-		cmd' ["hayoo"] ["query"] "find declarations online via Hayoo" [] hayoo',
-		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" (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" [holdArg] link']
-
-	-- Command arguments and flags
-	allFlag = option_ ['a'] "all" no "remove all"
-	cacheDir = pathArg "cache path"
-	cacheFile = fileArg "cache file"
-	ctx = [fileArg "source file", sandbox]
-	dataArg = option_ [] "data" (req "contents") "data to pass to command"
-	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" 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"
-	pathArg = option_ ['p'] "path" (req "path")
-	prefixArg = option_ [] "prefix" (req "prefix") "prefix match"
-	projectArg = option [] "project" ["proj"] (req "project")
-	packageVersionArg = option_ ['v'] "version" (req "version") "package version"
-	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 $ 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 $ arg "data" as
-			decodedData <- either
-				(\err -> throwError (errArgs "Unable to decode data" [
-					("why", ResultString err),
-					("data", ResultString jsonData)]))
-				return $
-				eitherDecode $ toUtf8 jsonData
-			let
-				updateData (ResultDeclaration d) = throwError $ errArgs "Can't insert declaration" [("declaration", ResultDeclaration d)]
-				updateData (ResultModuleDeclaration md) = do
-					let
-						ModuleId mname mloc = declarationModuleId md
-						defMod = Module mname Nothing mloc [] mempty mempty
-						defInspMod = Inspected InspectionNone mloc (Right defMod)
-						dbmod = maybe
-							defInspMod
-							(\i -> i { inspectionResult = inspectionResult i <|> (Right defMod) }) $
-							M.lookup mloc (databaseModules dbval)
-						updatedMod = dbmod {
-							inspectionResult = fmap (addDeclaration $ moduleDeclaration md) (inspectionResult dbmod) }
-					DB.update (dbVar copts) $ return $ fromModule updatedMod
-				updateData (ResultModuleId (ModuleId mname mloc)) = when (M.notMember mloc $ databaseModules dbval) $
-					DB.update (dbVar copts) $ return $ fromModule $ Inspected InspectionNone mloc (Right $ Module mname Nothing mloc [] mempty mempty)
-				updateData (ResultModule m) = DB.update (dbVar copts) $ return $ fromModule $ Inspected InspectionNone (moduleLocation m) (Right m)
-				updateData (ResultInspectedModule m) = DB.update (dbVar copts) $ return $ fromModule m
-				updateData (ResultProject p) = DB.update (dbVar copts) $ return $ fromProject p
-				updateData (ResultList l) = mapM_ updateData l
-				updateData (ResultMap m) = mapM_ updateData $ M.elems m
-				updateData (ResultString s) = throwError $ err "Can't insert string"
-				updateData ResultNone = return ()
-			updateData decodedData
-		return $ either id (const (ResultOk ResultNone)) res
-	-- scan
-	scan' as _ copts = updateProcess copts 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
-		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 (list "ghc" as) . CabalModule cabal Nothing)
-	-- rescan
-	rescan' as _ copts = do
-		dbval <- getDb copts
-		let
-			fileMap = M.fromList $ mapMaybe toPair $
-				selectModules (byFile . moduleId) dbval
-
-		(errors, filteredMods) <- liftM partitionEithers $ mapM runErrorT $ concat [
-			[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
-
-		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 (list "ghc" as) . inspectedId) rescanMods
-				Update.scanModules (list "ghc" as) (map (inspectedId &&& inspectionOpts . inspection) needRescan)
-	-- remove
-	remove' as _ copts = errorT $ do
-		dbval <- getDb copts
-		cabal <- getCabal_ copts as
-		proj <- traverse (findProject copts) $ arg "project" as
-		file <- traverse (findPath copts) $ arg "file" as
-		let
-			cleanAll = flag "all" as
-			filters = catMaybes [
-				fmap inProject proj,
-				fmap inFile file,
-				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
-				| null filters && cleanAll = liftIO $ do
-					DB.modifyAsync (dbVar copts) DB.Clear
-					return ResultNone
-				| null filters && not cleanAll = throwError "Specify filter or explicitely set flag --all"
-				| cleanAll = throwError "--all flag can't be set with filters"
-				| otherwise = liftIO $ do
-					DB.modifyAsync (dbVar copts) $ DB.Remove $ mconcat $ map (fromModule . getInspected dbval) toClean
-					return $ ResultList $ map (ResultModuleId . moduleId) toClean
-		action
-	-- list modules
-	listModules' as _ copts = errorT $ do
-		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 [
-				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
-		dbval <- getDb copts
-		return $ ResultOk $ ResultList $
-			map ResultPackage $ nub $ sort $
-			mapMaybe (moduleCabalPackage . moduleLocation) $
-			allModules dbval
-	-- list projects
-	listProjects' _ copts = do
-		dbval <- getDb copts
-		return $ ResultOk $ ResultList $ map ResultProject $ M.elems $ databaseProjects dbval
-	-- get symbol info
-	symbol' as ns copts = errorT $ do
-		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 (arg "module" as),
-				fmap inPackage (arg "package" as),
-				fmap inVersion (arg "version" as),
-				fmap inCabal cabal,
-				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
-			[nm] -> liftM toResult (findDeclaration dbval nm) `catchError` (\e ->
-				throwError ("Can't find symbol: " ++ e))
-			_ -> throwError "Too much arguments"
-	-- get module info
-	modul' as _ copts = errorT' $ do
-		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 (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)
-				(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 <- 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 <- 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 <- 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 <- 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 <- 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) <- getCtx copts as
-		liftM (ResultList . map ResultModuleDeclaration) $ completions dbval cabal srcFile input
-	complete' as _ copts = return $ err "Invalid arguments"
-	-- hayoo
-	hayoo' as [] copts = return $ err "Query not specified"
-	hayoo' as [query] copts = errorT $
-		liftM
-			(ResultList . map (ResultModuleDeclaration . Hayoo.hayooAsDeclaration) . Hayoo.hayooFunctions) $
-			Hayoo.hayoo query
-	hayoo' as _ copts = return $ err "Too much arguments"
-	-- cabal list
-	cabalList' as qs copts = errorT $ do
-		ps <- Cabal.cabalList qs
-		return $ ResultList $ map (ResultJSON . toJSON) ps
-	-- ghc-mod type
-	ghcmodType' as [line] copts = ghcmodType' as [line, "1"] copts
-	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 <- getDb copts
-		(srcFile, cabal) <- getCtx copts as
-		(srcFile', m, mproj) <- fileCtx dbval srcFile
-		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 <- getDb copts
-		cabals <- getSandboxes copts as
-		let
-			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 <- 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 $ (lift . findPath copts) >=> \p ->
-					fork (forM_ dats $ \(proj, dat) -> (dump (p </> projectCache proj) dat)),
-				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 = errorT $ do
-		dbval <- getDb copts
-		let
-			dat = standaloneDB dbval
-		liftM (fromMaybe $ ResultDatabase dat) $ runMaybeT $ msum [
-			maybeOpt "path" as $ (lift . findPath copts) >=> \p ->
-				fork (dump (p </> standaloneCache) dat),
-			maybeOpt "file" as $ (lift . findPath copts) >=> \f ->
-				fork (dump f dat)]
-	dumpFiles' as _ copts = return $ err "Invalid arguments"
-	-- dump database
-	dump' as _ copts = errorT $ do
-		dbval <- getDb copts
-		liftM (fromMaybe $ ResultDatabase dbval) $ runMaybeT $ msum [
-			do
-				p <- MaybeT $ traverse (findPath copts) $ arg "path" as
-				fork $ SC.dump p $ structurize dbval
-				return ResultNone,
-			do
-				f <- MaybeT $ traverse (findPath copts) $ arg "file" as
-				fork $ dump f dbval
-				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 $ arg "path" as
-				forkOrWait as $ cacheLoad copts (liftA merge <$> SC.load p)
-				return ok,
-			do
-				f <- MaybeT $ return $ arg "file" as
-				e <- liftIO $ doesFileExist f
-				forkOrWait as $ when e $ cacheLoad copts (load f)
-				return ok,
-			do
-				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
-		commandLink copts
-		when (flag "hold" as) $ commandHold copts
-		return ok
-	-- exit
-	exit' _ copts = do
-		commandExit copts
-		return ok
-
-	-- Helper functions
-	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) $ 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) $ CommandCall name args defaultConfig
-
-	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)
-		_ -> Nothing
-
-	modCabal :: Module -> Maybe Cabal
-	modCabal m = case moduleLocation m of
-		CabalModule c _ _ -> Just c
-		_ -> Nothing
-
-	waitDb copts as = when (flag "wait" as) $ do
-		commandLog copts "wait for db"
-		DB.wait (dbVar copts)
-		commandLog copts "db done"
-
-	forkOrWait as act
-		| flag "wait" as = liftIO act
-		| otherwise = liftIO $ void $ forkIO act
-
-	cacheLoad copts act = do
-		db' <- act
-		case db' of
-			Left e -> commandLog copts e
-			Right database -> DB.update (dbVar copts) (return database)
-
-	localsDatabase :: Opts String -> Database -> Database
-	localsDatabase as
-		| flag "locals" as = databaseLocals
-		| otherwise = id
-
-	newest :: Symbol a => Opts String -> [a] -> [a]
-	newest as
-		| flag "no-last" as = id
-		| otherwise = newestPackage
-
-	forceJust :: MonadIO m => String -> ErrorT String m (Maybe a) -> ErrorT String m a
-	forceJust msg act = act >>= maybe (throwError msg) return
-
-	getDb :: (MonadIO m) => CommandOptions -> m Database
-	getDb = liftIO . DB.readAsync . commandDatabase
-
-	dbVar :: CommandOptions -> DB.Async Database
-	dbVar = commandDatabase
-
-	startProcess :: Opts String -> ((Update.Status -> IO ()) -> IO ()) -> IO CommandResult
-	startProcess as f
-		| flag "wait" as = return $ ResultProcess (f . onMsg)
-		| otherwise = forkIO (f $ const $ return ()) >> return ok
-		where
-			onMsg showMsg
-				| flag "status" as = showMsg
-				| otherwise = const $ return ()
-	error_ :: ErrorT String IO CommandResult -> IO CommandResult
-	error_ = liftM (either err id) . runErrorT
-
-	errorT :: ErrorT String IO ResultValue -> IO CommandResult
-	errorT = liftM (either err ResultOk) . runErrorT
-
-	errorT' :: ErrorT CommandResult IO ResultValue -> IO CommandResult
-	errorT' = liftM (either id ResultOk) . runErrorT
-
-	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
-
-	voidm :: Monad m => m a -> m ()
-	voidm act = act >> return ()
-
-	maybeOpt :: Monad m => String -> Opts String -> (String -> MaybeT m a) -> MaybeT m ResultValue
-	maybeOpt n as act = do
-		p <- MaybeT $ return $ arg n as
-		act p
-		return ResultNone
-
-	filterMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration]
-	filterMatch as = findMatch as . prefMatch as
-
-	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 String -> [ModuleDeclaration] -> [ModuleDeclaration]
-	prefMatch as = case fmap splitIdentifier (arg "prefix" as) of
-		Nothing -> id
-		Just (qname, pref) -> filter (match' qname pref)
-		where
-			match' qname pref m =
-				pref `isPrefixOf` declarationName (moduleDeclaration m) &&
-				maybe True (== moduleIdName (declarationModuleId m)) qname
-
-processCmd :: CommandOptions -> Int -> String -> (Response -> IO ()) -> IO ()
-processCmd copts tm cmdLine sendResponse = processCmdArgs copts tm (splitArgs cmdLine) sendResponse
-
--- | Process command, returns 'False' if exit requested
-processCmdArgs :: CommandOptions -> Int -> [String] -> (Response -> IO ()) -> IO ()
-processCmdArgs copts tm cmdArgs sendResponse = run (map (fmap withOptsAct) commands) (asCmd unknownCommand) (asCmd . commandError) cmdArgs tm copts >>= sendResponses where
-	asCmd :: CommandResult -> (Int -> CommandOptions -> IO CommandResult)
-	asCmd r _ _ = return r
-
-	unknownCommand :: CommandResult
-	unknownCommand = err "Unknown command"
-	commandError :: [String] -> CommandResult
-	commandError errs = errArgs "Command syntax error" [("what", ResultList $ map ResultString errs)]
-
-	sendResponses :: CommandResult -> IO ()
-	sendResponses (ResultOk v) = sendResponse $ Response $ toJSON v
-	sendResponses (ResultError e args) = sendResponse $ Response $ object [
-		"error" .= e,
-		"details" .= args]
-	sendResponses (ResultProcess act) = do
-		act (sendResponse . ResponseStatus)
-		sendResponses ok
-		`catch`
-		processFailed
-		where
-			processFailed :: SomeException -> IO ()
-			processFailed e = sendResponses $ errArgs "process throws exception" [
-				("exception", ResultString $ show e)]
-
-hGetLine' :: Handle -> IO ByteString
-hGetLine' = fmap L.fromStrict . B.hGetLine
-
-race :: [IO ()] -> IO ()
-race acts = do
-	v <- newEmptyMVar
-	forM_ acts $ \a -> forkIO ((a `finally` putMVar v ()) `catch` ignoreError)
-	takeMVar v
-	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)
− tools/Control/Concurrent/FiniteChan.hs 
@@ -1,38 +0,0 @@-module Control.Concurrent.FiniteChan (
-	Chan,
-	newChan, dupChan, putChan, getChan, readChan, closeChan, stopChan
-	) where
-
-import qualified Control.Concurrent.Chan as C
-import Data.Maybe
-
--- | 'Chan' is stoppable channel unline 'Control.Concurrent.Chan'
-newtype Chan a = Chan (C.Chan (Maybe a))
-
--- | Create channel
-newChan :: IO (Chan a)
-newChan = fmap Chan C.newChan
-
--- | Duplicate channel
-dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan ch) = fmap Chan $ C.dupChan ch
-
--- | Write data to channel
-putChan :: Chan a -> a -> IO ()
-putChan (Chan ch) = C.writeChan ch . Just
-
--- | Get data from channel
-getChan :: Chan a -> IO (Maybe a)
-getChan (Chan ch) = C.readChan ch
-
--- | Read channel contents
-readChan :: Chan a -> IO [a]
-readChan (Chan ch) = fmap (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
-
--- | Stop channel and return all data
-stopChan :: Chan a -> IO [a]
-stopChan ch = closeChan ch >> readChan ch
− tools/System/Command.hs 
@@ -1,268 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, DefaultSignatures, FlexibleInstances, TupleSections #-}
-
-module System.Command (
-	Command(..),
-	DefaultConfig(..),
-	cmd, cmd_,
-	Help(..), addHelpCommand, addHelp,
-	brief, help,
-	run, runCmd,
-	OptionValue(..),
-	Opts(..),
-	(%--), 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 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, isJust)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Monoid
-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],
-	commandPosArgs :: [String],
-	commandDesc :: Maybe String,
-	commandUsage :: [String],
-	commandRun :: [String] -> Maybe (Either [String] a) }
-
-instance Functor Command where
-	fmap f cmd' = cmd' {
-		commandRun = fmap (fmap f) . commandRun cmd' }
-
--- | Default value for options
-class DefaultConfig a where
-	defaultConfig :: a
-	default defaultConfig :: Monoid a => a
-	defaultConfig = mempty
-
-instance DefaultConfig ()
-instance DefaultConfig [String]
-
--- | Make command
--- >cmd name args desc args' onCmd
-cmd :: (Monoid c, DefaultConfig c) => [String] -> [String] -> String -> [OptDescr c] -> (c -> [String] -> a) -> Command a
-cmd name posArgs descr as act = Command {
-	commandName = name,
-	commandPosArgs = posArgs,
-	commandDesc = descr',
-	commandUsage = lines $ usageInfo (unwords (name ++ map (\a -> "[" ++ a ++ "]") posArgs) ++ maybe "" (" -- " ++) descr') as,
-	commandRun = \opts -> case getOpt Permute as opts of
-		(opts', cs, errs) -> fmap (\cs' -> if null errs then return (act (mconcat opts' `mappend` defaultConfig) cs') else Left errs) (stripPrefix name cs) }
-	where
-		descr' = if null descr then Nothing else Just descr
-
--- | Make command without params
-cmd_ :: [String] -> [String] -> String -> ([String] -> a) -> Command a
-cmd_ name posArgs descr act = cmd name posArgs descr [] (act' act) where
-	act' :: a -> () -> a
-	act' = const
-
-data Help =
-	HelpUsage [String] |
-	HelpCommands [([String], [String])]
-		deriving (Eq, Ord, Read, Show)
-
--- | Add help command
-addHelpCommand :: String -> (Either String Help -> a) -> [Command a] -> [Command a]
-addHelpCommand tool toCmd cmds = cmds' where
-	cmds' = helpcmd' : cmds
-	helpcmd = fmap toCmd $ cmd_ ["help"] ["command"] ("help command, also can be called in form '" ++ tool ++ " [command] -?'") onHelp
-	-- allow help by last argument '-?'
-	helpcmd' = helpcmd { commandRun = commandRun helpcmd . rewrite } where
-		rewrite as
-			| last as == "-?" = "help" : init as
-			| otherwise = as
-	onHelp [] = Right $ HelpUsage [tool ++ " " ++ brief c | c <- cmds']
-	onHelp cmdname = case filter ((cmdname `isPrefixOf`) . commandName) cmds' of
-		[] -> Left $ "Unknown command: " ++ unwords cmdname
-		helps -> Right $ HelpCommands $ map (commandName &&& (addHeader . help)) helps
-	addHeader [] = []
-	addHeader (h:hs) = (tool ++ " " ++ h) : hs
-
--- | Add help commands, which outputs help to stdout
-addHelp :: String -> (IO () -> a) -> [Command a] -> [Command a]
-addHelp tool liftPrint cmds = addHelpCommand tool toCmd cmds where
-	toCmd = liftPrint . either putStrLn printHelp
-	printHelp :: Help -> IO ()
-	printHelp (HelpUsage u) = mapM_ putStrLn $ map ('\t':) u
-	printHelp (HelpCommands cs) = mapM_ putStrLn $ map ('\t':) $ concatMap snd cs
-
--- | Show brief help for command
-brief :: Command a -> String
-brief = head . commandUsage
-
--- | Show detailed help for command
-help :: Command a -> [String]
-help = commandUsage
-
--- | Run commands
-run :: [Command a] -> a -> ([String] -> a) -> [String] -> a
-run cmds onDef onError as = maybe onDef (either onError id) found where
-	found = listToMaybe $ mapMaybe (`commandRun` as) cmds
-
--- | Try run command, wrapping any negative result to 'Maybe'
-runCmd :: Command a -> [String] -> Maybe a
-runCmd cmd = join . fmap toMaybe . commandRun cmd where
-	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 a = Opts { getOpts :: Map String [a] }
-
-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 mappend l r
-
-instance Eq a => Group (Opts a) where
-	add = mappend
-	(Opts l) `sub` (Opts r) = Opts $ l `sub` r
-	zero = mempty
-
-instance DefaultConfig (Opts a)
-
-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
-
-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
-
--- | 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 []
-
-has :: String -> Opts a -> Bool
-has n = M.member n . getOpts
-
--- | Required option
-req :: String -> String -> ArgDescr (Opts String)
-req nm n = ReqArg (n %--) nm
-
--- | Not required option
-noreq :: String -> String -> ArgDescr (Opts String)
-noreq nm n = OptArg (maybe (hoist n) (n %--)) nm
-
--- | No option
-no :: String -> ArgDescr (Opts String)
-no = NoArg . hoist
-
--- | Get argument
-arg :: String -> Opts a -> Maybe a
-arg n = M.lookup n . getOpts >=> listToMaybe
-
--- | Get optional argument
-opt :: String -> Opts a -> Maybe (Maybe a)
-opt n = fmap listToMaybe . M.lookup n . getOpts
-
--- | Get argument with default
-def :: a -> String -> Opts a -> Maybe a
-def d n = fmap (fromMaybe d . listToMaybe) . M.lookup n . getOpts
-
--- | Get list arguments
-list :: String -> Opts a -> [a]
-list n = fromMaybe [] . M.lookup n . getOpts
-
--- | Get flag
-flag :: String -> Opts a -> Bool
-flag n = isJust . M.lookup n . getOpts
-
--- | Print 'Opts' as args
-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]
-splitArgs "" = []
-splitArgs (c:cs)
-	| isSpace c = splitArgs cs
-	| c == '"' = let (w, cs') = readQuote cs in w : splitArgs cs'
-	| otherwise = let (ws, tl) = break isSpace cs in (c:ws) : splitArgs tl
-	where
-		readQuote :: String -> (String, String)
-		readQuote "" = ("", "")
-		readQuote ('\\':ss)
-			| null ss = ("\\", "")
-			| otherwise = first (head ss :) $ readQuote (tail ss)
-		readQuote ('"':ss) = ("", ss)
-		readQuote (s:ss) = first (s:) $ readQuote ss
-
-unsplitArgs :: [String] -> String
-unsplitArgs = unwords . map escape where
-	escape :: String -> String
-	escape str
-		| any isSpace str || '"' `elem` str = "\"" ++ concat (unfoldr escape' str) ++ "\""
-		| otherwise = str
-	escape' :: String -> Maybe (String, String)
-	escape' [] = Nothing
-	escape' (ch:tl) = Just (escaped, tl) where
-		escaped = case ch of
-			'"' -> "\\\""
-			'\\' -> "\\\\"
-			_ -> [ch]
− tools/System/Win32/FileMapping/Memory.hs 
@@ -1,58 +0,0 @@-module System.Win32.FileMapping.Memory (
-	createMap, openMap, mapFile,
-	withMapFile, readMapFile
-	) where
-
-import Control.Monad.CatchIO (bracket)
-import Control.Monad.Cont
-import Control.Monad.Error
-import Data.ByteString.Char8
-import qualified Data.ByteString.Char8 as BS
-import Foreign.C.String
-import Foreign.Ptr
-import System.Win32.File (closeHandle)
-import System.Win32.FileMapping hiding (mapFile)
-import System.Win32.Types
-import System.Win32.Mem
-
-createMap :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> ContT r (ErrorT String IO) HANDLE
-createMap mh pf sz mn = ContT $ bracket
-	(verify iNVALID_HANDLE_VALUE "Invalid handle" $
-		liftIO (createFileMapping mh pf sz mn))
-	(liftIO . closeHandle)
-
-openMap :: FileMapAccess -> Bool -> Maybe String -> ContT r (ErrorT String IO) HANDLE
-openMap f i mn = ContT $ bracket
-	(verify iNVALID_HANDLE_VALUE "Invalid handle" $
-		liftIO (openFileMapping f i mn))
-	(liftIO . closeHandle)
-
-mapFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> ErrorT String IO (Ptr a)
-mapFile h f off sz = verify nullPtr "null pointer" $ liftIO (mapViewOfFile h f off sz) 
-
--- | Write data to named map view of file
-withMapFile :: String -> ByteString -> IO a -> ErrorT String IO a
-withMapFile name str act = flip runContT return $ do
-	p <- ContT $ \f -> ErrorT (BS.useAsCString str (runErrorT . f))
-	h <- createMap Nothing pAGE_READWRITE (fromIntegral len) (Just name)
-	ptr <- lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
-	liftIO $ do
-		copyMemory ptr p (fromIntegral len)
-		unmapViewOfFile ptr
-		act
-	where
-		len = BS.length str + 1
-
--- | Read data from named map view of file
-readMapFile :: String -> ErrorT String IO ByteString
-readMapFile name = flip runContT return $ do
-	h <- openMap fILE_MAP_ALL_ACCESS True (Just name)
-	ptr <- lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
-	liftIO $ BS.packCString ptr
-
-verify :: (Error e, MonadError e m, Eq a) => a -> String -> m a -> m a
-verify v str act = do
-	x <- act
-	if x == v
-		then throwError (strMsg str)
-		else return x
− tools/System/Win32/FileMapping/NamePool.hs 
@@ -1,31 +0,0 @@-module System.Win32.FileMapping.NamePool (
-	Pool(..),
-	createPool, withName
-	) where
-
-import Control.Concurrent
-import Control.Exception (bracket)
-import Control.Monad (liftM, liftM2)
-import System.Win32.FileMapping.Memory ()
-
--- | Pool of names for memory mapped files
-data Pool = Pool {
-	poolFreeNames :: MVar [String],
-	poolNewName :: IO String }
-
--- | Create pool of numbered names by base name
-createPool :: String -> IO Pool
-createPool baseName = liftM2 Pool (newMVar []) mkNewName where
-	mkNewName :: IO (IO String)
-	mkNewName = do
-		num <- newMVar 0
-		return $ modifyMVar num $ \n -> do
-			return (succ n, baseName ++ show n)
-
--- | Use free name from pool
-withName :: Pool -> (String -> IO a) -> IO a
-withName p act = bracket getName freeName act where
-	getName = modifyMVar (poolFreeNames p) $ \names -> case names of
-		[] -> liftM ((,) []) $ poolNewName p
-		(n:ns) -> return (ns, n)
-	freeName name = modifyMVar_ (poolFreeNames p) (return . (name:))
tools/Tool.hs view
@@ -10,23 +10,22 @@ 	-- * Options
 	prettyOpt, isPretty,
 
-	module System.Command
+	module System.Console.Cmd
 	) where
 
 import Control.Monad.Error (ErrorT, runErrorT, throwError)
 import Data.Aeson
 import Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Lazy.Char8 as L (ByteString, putStrLn)
-import System.Console.GetOpt
 import System.Environment
 import System.IO
 
 import HsDev.Tools.Base (ToolM)
 
-import System.Command
+import System.Console.Cmd
 
 -- | Run tool with commands
-toolMain :: String -> [Command (IO ())] -> IO ()
+toolMain :: String -> [Cmd (IO ())] -> IO ()
 toolMain name commands = do
 	hSetBuffering stdout LineBuffering
 	hSetEncoding stdout utf8
@@ -35,22 +34,22 @@ 		[] -> usage name toolCmds
 		_ -> run toolCmds unknownCmd onError as
 	where
-		onError :: [String] -> IO ()
-		onError = mapM_ putStrLn
+		onError :: String -> IO ()
+		onError = putStrLn
 
 		unknownCmd :: IO ()
 		unknownCmd = putStrLn "Unknown command" >> usage name toolCmds
 
-		toolCmds = addHelp name id commands
+		toolCmds = withHelp name (printWith putStrLn) commands
 
 -- | Print usage
-usage :: String -> [Command (IO ())] -> IO ()
+usage :: String -> [Cmd (IO ())] -> IO ()
 usage toolName = mapM_ (putStrLn . ('\t':) . ((toolName ++ " ") ++) . brief)
 
 -- | Command with JSONable result
-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
+jsonCmd :: ToJSON a => String -> [String] -> [Opt] -> String -> (Args -> ToolM a) -> Cmd (IO ())
+jsonCmd name pos os descr act = cmd name pos (prettyOpt : os) descr $ \(Args as opts) -> do
+	r <- runErrorT $ act (Args as opts)
 	L.putStrLn $ either (toStr opts . errorStr) (toStr opts) r
 	where
 		toStr :: ToJSON a => Opts String -> a -> L.ByteString
@@ -62,15 +61,15 @@ 		errorStr s = object ["error" .= s]
 
 -- | `jsonCmd` with the only '--pretty' option
-jsonCmd_ :: ToJSON a => [String] -> [String] -> String -> ([String] -> ToolM a) -> Command (IO ())
-jsonCmd_ name posArgs descr = jsonCmd name posArgs descr [] . const
+jsonCmd_ :: ToJSON a => String -> [String] -> String -> ([String] -> ToolM a) -> Cmd (IO ())
+jsonCmd_ name pos descr act = jsonCmd name pos [] descr (act . posArgs)
 
 -- | Fail with error
 toolError :: String -> ToolM a
 toolError = throwError
 
-prettyOpt :: OptDescr (Opts String)
-prettyOpt = option_ [] "pretty" no "pretty JSON output"
+prettyOpt :: Opt
+prettyOpt = flag "pretty" `desc` "pretty JSON output"
 
 isPretty :: Opts String -> Bool
-isPretty = flag "pretty"
+isPretty = flagSet "pretty"
− tools/Types.hs 
@@ -1,260 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}
-
-module Types (
-	-- * Server options
-	ServerOpts(..), serverOpts, serverOptsToArgs,
-	-- * Client options
-	ClientOpts(..), clientOpts,
-	-- * Messages and results
-	ResultValue(..), Response(..),
-	CommandResult(..), ok, err, errArgs, details,
-	CommandCall(..), callArgs, addCallOpts, removeCallOpts, WithOpts(..),
-	CommandOptions(..), CommandAction
-	) where
-
-import Control.Applicative
-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
-import System.Console.GetOpt
-import Text.Read
-
-import HsDev.Database
-import HsDev.Project
-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,
-	serverAsClient :: Any }
-
-instance DefaultConfig ServerOpts where
-	defaultConfig = ServerOpts
-		(First $ Just 4567)
-		(First $ Just 1000)
-		(First Nothing)
-		(First Nothing)
-		mempty
-		mempty
-
-instance Monoid ServerOpts where
-	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]
-serverOpts = [
-	Option [] ["port"] (ReqArg (\p -> mempty { serverPort = First (readMaybe p) }) "number") "listen port",
-	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 ['c'] ["as-client"] (NoArg (mempty { serverAsClient = Any True })) "make server be client and connect to port specified"]
-
--- | Convert 'ServerOpts' to args
-serverOptsToArgs :: ServerOpts -> [String]
-serverOptsToArgs sopts = concat [
-	arg' "port" show $ serverPort sopts,
-	arg' "timeout" show $ serverTimeout sopts,
-	arg' "log" id $ serverLog sopts,
-	arg' "cache" id $ serverCache sopts,
-	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
-
--- | Client options
-data ClientOpts = ClientOpts {
-	clientPort :: First Int,
-	clientPretty :: Any,
-	clientData :: Any }
-
-instance DefaultConfig ClientOpts where
-	defaultConfig = ClientOpts (First $ Just 4567) mempty mempty
-
-instance Monoid ClientOpts where
-	mempty = ClientOpts mempty mempty mempty
-	l `mappend` r = ClientOpts
-		(clientPort l `mappend` clientPort r)
-		(clientPretty l `mappend` clientPretty r)
-		(clientData l `mappend` clientData r)
-
--- | Client options command opts
-clientOpts :: [OptDescr ClientOpts]
-clientOpts = [
-	Option [] ["port"] (ReqArg (\p -> mempty { clientPort = First (readMaybe p) }) "number") "connection port",
-	Option [] ["pretty"] (NoArg (mempty { clientPretty = Any True })) "pretty json output",
-	Option [] ["stdin"] (NoArg (mempty { clientData = Any True })) "pass data to stdin"]
-
-data ResultValue =
-	ResultDatabase Database |
-	ResultDeclaration Declaration |
-	ResultModuleDeclaration ModuleDeclaration |
-	ResultModuleId ModuleId |
-	ResultModule Module |
-	ResultInspectedModule InspectedModule |
-	ResultPackage ModulePackage |
-	ResultProject Project |
-	ResultTyped TypedRegion |
-	ResultList [ResultValue] |
-	ResultMap (Map String ResultValue) |
-	ResultJSON Value |
-	ResultString String |
-	ResultNone
-
-instance ToJSON ResultValue where
-	toJSON (ResultDatabase db) = toJSON db
-	toJSON (ResultDeclaration d) = toJSON d
-	toJSON (ResultModuleDeclaration md) = toJSON md
-	toJSON (ResultModuleId mid) = toJSON mid
-	toJSON (ResultModule m) = toJSON m
-	toJSON (ResultInspectedModule m) = toJSON m
-	toJSON (ResultPackage p) = toJSON p
-	toJSON (ResultProject p) = toJSON p
-	toJSON (ResultTyped t) = toJSON t
-	toJSON (ResultList l) = toJSON l
-	toJSON (ResultMap m) = toJSON m
-	toJSON (ResultJSON v) = toJSON v
-	toJSON (ResultString s) = toJSON s
-	toJSON ResultNone = toJSON $ object []
-
-instance FromJSON ResultValue where
-	parseJSON v = foldr1 (<|>) [
-		do
-			(Object m) <- parseJSON v
-			if HM.null m then return ResultNone else mzero,
-		ResultDatabase <$> parseJSON v,
-		ResultDeclaration <$> parseJSON v,
-		ResultModuleDeclaration <$> parseJSON v,
-		ResultModuleId <$> parseJSON v,
-		ResultModule <$> parseJSON v,
-		ResultInspectedModule <$> parseJSON v,
-		ResultPackage <$> parseJSON v,
-		ResultProject <$> parseJSON v,
-		ResultTyped <$> parseJSON v,
-		ResultList <$> parseJSON v,
-		ResultMap <$> parseJSON v,
-		pure $ ResultJSON v,
-		ResultString <$> parseJSON v]
-
-data Response =
-	ResponseStatus Status |
-	ResponseMapFile String |
-	Response Value
-
-instance ToJSON Response where
-	toJSON (ResponseStatus s) = toJSON s
-	toJSON (ResponseMapFile s) = object ["file" .= s]
-	toJSON (Response v) = v
-
-instance FromJSON Response where
-	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 ((Status -> IO ()) -> IO ())
-
-instance Error CommandResult where
-	noMsg = ResultError noMsg mempty
-	strMsg s = ResultError s mempty
-
-ok :: CommandResult
-ok = ResultOk ResultNone
-
-err :: String -> CommandResult
-err s = ResultError s M.empty
-
-errArgs :: String -> [(String, ResultValue)] -> CommandResult
-errArgs s as = ResultError s (M.fromList as)
-
--- | Add detailed information to error message
-details :: [(String, ResultValue)] -> CommandResult -> CommandResult
-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,
-	withOptsCommand :: CommandCall }
-
-instance Functor WithOpts where
-	fmap f (WithOpts x as) = WithOpts (f x) as
-
-data CommandOptions = CommandOptions {
-	commandDatabase :: DB.Async Database,
-	commandWriteCache :: Database -> IO (),
-	commandReadCache :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database),
-	commandRoot :: FilePath,
-	commandLog :: String -> IO (),
-	commandLogWait :: IO (),
-#if mingw32_HOST_OS
-	commandMmapPool :: Maybe Pool,
-#endif
-	commandLink :: IO (),
-	commandHold :: IO (),
-	commandExit :: IO () }
-
-type CommandAction = WithOpts (Int -> CommandOptions -> IO CommandResult)
-
− tools/Update.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings, MultiParamTypeClasses #-}
-
-module Update (
-	Status(..), isStatus,
-	Settings(..),
-
-	UpdateDB,
-	updateDB,
-
-	setStatus, postStatus, waiter, updater, loadCache, runTask, runTasks,
-	readDB,
-
-	scanModule, scanModules, scanFile, scanCabal, scanProject, scanDirectory,
-
-	-- * Helpers
-	liftErrorT
-	) where
-
-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, isJust)
-import Data.Monoid
-import Data.Traversable (traverse)
-import System.Directory (canonicalizePath)
-
-import qualified HsDev.Cache.Structured as Cache
-import HsDev.Database
-import HsDev.Database.Async
-import HsDev.Project
-import HsDev.Symbols
-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 :: Status -> IO (),
-	ghcOptions :: [String] }
-
-newtype UpdateDB m a = UpdateDB { runUpdateDB :: ReaderT Settings m a }
-	deriving (Applicative, Monad, MonadIO, MonadCatchIO, Functor, MonadReader Settings)
-
--- | Run `UpdateDB` monad
-updateDB :: Monad m => Settings -> ErrorT String (UpdateDB m) () -> m ()
-updateDB sets act = runUpdateDB (runErrorT act >> return ()) `runReaderT` sets
-
--- | 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
-	db <- asks database
-	act
-	wait db
-
--- | Update task result to database
-updater :: (MonadIO m, MonadReader Settings m) => m Database -> m ()
-updater act = do
-	db <- asks database
-	act >>= update db . return
-
--- | Load data from cache and wait
-loadCache :: (MonadIO m, MonadReader Settings m) => (FilePath -> ErrorT String IO Structured) -> m ()
-loadCache act = do
-	cacheReader <- asks databaseCacheReader
-	mdat <- liftIO $ cacheReader act
-	case mdat of
-		Nothing -> return ()
-		Just dat -> waiter (updater (return dat))
-
--- | Run one task
-runTask :: MonadIO m => Value -> ErrorT String (UpdateDB m) a -> ErrorT String (UpdateDB m) a
-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
-		postStatus $ toJSON ("working" :: String)
-		x <- a
-		postStatus taskOk
-		return x
-		`catchError`
-		(\e -> postStatus (taskErr e) >> throwError e)
-	taskOk = toJSON ("ok" :: String)
-	taskErr e = object ["error" .= e]
-
--- | Run many tasks with numeration
-runTasks :: Monad m => [ErrorT String (UpdateDB m) ()] -> ErrorT String (UpdateDB m) ()
-runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where
-	total = length ts
-	taskNum n t = progress `setStatus` t where
-		progress = ["progress" .= object [
-			"current" .= (n :: Integer), "total" .= total]]
-	noErr v = v `mplus` return ()
-
--- | Get database value
-readDB :: (MonadIO m, MonadReader Settings m) => m Database
-readDB = asks database >>= liftIO . readAsync
-
--- | Scan module
-scanModule :: MonadCatchIO m => [String] -> ModuleLocation -> ErrorT String (UpdateDB m) ()
-scanModule opts mloc = runTask task' $ do
-	im <- liftErrorT $ S.scanModule opts mloc
-	updater $ return $ fromModule im
-	ErrorT $ return $ inspectionResult im
-	return ()
-	where
-		task' = object ["scanning" .= mloc]
-
--- | Scan modules
-scanModules :: MonadCatchIO m => [String] -> [S.ModuleToScan] -> ErrorT String (UpdateDB m) ()
-scanModules opts ms = do
-	db <- asks database
-	dbval <- readDB
-	runTask (toJSON ("updating projects files" :: String)) $ updater $ do
-		projects <- mapM (liftErrorT . S.scanProjectFile opts) ps
-		return $ mconcat $ map fromProject projects
-	ms' <- liftErrorT $ filterM (S.changedModule dbval opts . fst) ms
-	runTasks [scanModule (opts ++ snd m) (fst m) | m <- ms']
-	where
-		ps = mapMaybe (toProj . fst) ms
-		toProj (FileModule _ p) = fmap projectCabal p
-		toProj _ = Nothing
-
--- | Scan source file
-scanFile :: MonadCatchIO m => [String] -> FilePath -> ErrorT String (UpdateDB m) ()
-scanFile opts fpath = do
-	fpath' <- liftIO $ canonicalizePath fpath
-	mproj <- liftIO $ locateProject fpath'
-	let
-		mtarget = mproj >>= (`fileTarget` fpath')
-		fileExts = maybe [] (extensionsOpts . infoExtensions) mtarget
-
-	scanModule (opts ++ fileExts) (FileModule fpath' mproj)
-
--- | Scan cabal modules
-scanCabal :: MonadCatchIO m => [String] -> Cabal -> ErrorT String (UpdateDB m) ()
-scanCabal opts sandbox = do
-	loadCache $ Cache.loadCabal sandbox
-	dbval <- readDB
-	ms <- runTask
-		(object ["action" .= ("loading modules" :: String), "sandbox" .= sandbox]) $
-		liftErrorT $ browseFilter opts sandbox (S.changedModule dbval opts)
-	docs <- runTask
-		(object ["action" .= ("loading docs" :: String), "sandbox" .= sandbox]) $
-		liftErrorT $ hdocsCabal sandbox opts
-	updater $ return $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms
-	where
-		setDocs' :: Map String (Map String String) -> Module -> Module
-		setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (moduleName m) docs
-
--- | Scan project
-scanProject :: MonadCatchIO m => [String] -> FilePath -> ErrorT String (UpdateDB m) ()
-scanProject opts cabal = do
-	proj <- liftErrorT $ S.scanProjectFile opts cabal
-	loadCache $ Cache.loadProject $ projectCabal proj
-	(_, sources) <- liftErrorT $ S.enumProject proj
-	scanModules opts sources
-
--- | Scan directory for source files and projects
-scanDirectory :: MonadCatchIO m => [String] -> FilePath -> ErrorT String (UpdateDB m) ()
-scanDirectory opts dir = do
-	(projSrcs, standSrcs) <- runTask (toJSON ("getting list of sources" :: String)) $ liftErrorT $ S.enumDirectory dir
-	forM_ projSrcs $ \(p, _) -> loadCache (Cache.loadProject $ projectCabal p)
-	loadCache $ Cache.loadFiles $ mapMaybe (moduleSource . fst) standSrcs
-	scanModules opts (concatMap snd projSrcs ++ standSrcs)
-
--- | Lift errors
-liftErrorT :: MonadIO m => ErrorT String IO a -> ErrorT String m a
-liftErrorT = mapErrorT liftIO
-
--- | Merge two JSON object
-union :: Value -> Value -> Value
-union (Object l) (Object r) = Object $ HM.union l r
-union _ _ = error "Commands.union: impossible happened"
tools/hscabal.hs view
@@ -8,4 +8,4 @@ 
 main :: IO ()
 main = toolMain "hscabal" [
-	jsonCmd_ ["list"] ["packages..."] "list hackage packages" cabalList]
+	jsonCmd_ "list" ["packages..."] "list hackage packages" cabalList]
tools/hsclearimports.hs view
@@ -5,7 +5,6 @@ import Control.Exception (finally)
 import Control.Monad (void)
 import Control.Monad.Error
-import System.Console.GetOpt (OptDescr)
 import System.Directory
 import System.Environment (getArgs)
 import Text.Read (readMaybe)
@@ -13,34 +12,34 @@ import HsDev.Tools.ClearImports (clearImports)
 import HsDev.Symbols (locateSourceDir)
 
-import System.Command
+import System.Console.Cmd
 
-opts :: [OptDescr (Opts String)]
+opts :: [Opt]
 opts = [
-	option_ ['g'] "ghc" (req "ghc options") "options for GHC",
-	option_ [] "hide-import-list" no "hide import list",
-	option_ [] "max-import-list" (req "max import list length") "hide long import lists"]
+	list "ghc" "GHC_OPT" `short` "g" `desc` "options for GHC",
+	flag "hide-import-list" `desc` "hide import list",
+	req "max-import-list" "N" `desc` "hide long import lists"]
 
-cmds :: [Command (IO ())]
-cmds = addHelp "hsclearimports" id [
-	cmd [] ["file"] "clear imports in haskell source" opts clear]
+cmds :: [Cmd (IO ())]
+cmds = withHelp "hsclearimports" (printWith putStrLn) $ [
+	cmd [] ["file"] opts "clear imports in haskell source" clear]
 	where
-		clear :: Opts String -> [String] -> IO ()
-		clear as [f] = do
+		clear :: Args -> IO ()
+		clear (Args [f] as) = do
 			file <- canonicalizePath f
 			mroot <- locateSourceDir file
 			cur <- getCurrentDirectory
 			flip finally (setCurrentDirectory cur) $ do
 				maybe (return ()) setCurrentDirectory mroot
 				void $ runErrorT $ catchError
-					(clearImports (list "ghc" as) file >>= mapM_ (liftIO . putStrLn . format as))
+					(clearImports (listArg "ghc" as) file >>= mapM_ (liftIO . putStrLn . format as))
 					(\e -> liftIO (putStrLn $ "Error: " ++ e))
-		clear _ _ = putStrLn "Invalid arguments"
-		
+		clear _ = putStrLn "Invalid arguments"
+
 		format :: Opts String -> (String, String) -> String
 		format as (imp, lst)
-			| flag "hide-import-list" as = imp
-			| maybe False (length lst >) (arg "max-import-list" as >>= readMaybe) = imp
+			| flagSet "hide-import-list" as = imp
+			| maybe False (length lst >) (narg "max-import-list" as) = imp
 			| otherwise = imp ++ " (" ++ lst ++ ")"
 
 main :: IO ()
@@ -49,4 +48,4 @@ 	run cmds noCmd onError args
 	where
 		noCmd = putStrLn "Invalid command"
-		onError = mapM_ putStrLn
+		onError = putStrLn
tools/hsdev.hs view
@@ -1,18 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}
+
 module Main (
 	main
 	) where
 
 import Control.Monad
-import Network.Socket
-import System.Environment
+import Data.List
+import Data.Char
+import Data.Maybe (listToMaybe, mapMaybe)
+import Network.Socket (withSocketsDo)
+import System.Environment (getArgs)
 import System.Exit
 import System.IO
+import Text.Read (readMaybe)
 
-import System.Command hiding (brief)
-import qualified System.Command as C (brief)
+import Control.Apply.Util (chain)
+import System.Console.Cmd
+import qualified System.Console.Cmd as C (brief)
 
-import Types
-import Commands
+import qualified HsDev.Client.Commands as Client (commands)
+import qualified HsDev.Server.Commands as Server
+import HsDev.Version
 
 main :: IO ()
 main = withSocketsDo $ do
@@ -20,15 +28,15 @@ 	hSetEncoding stdout utf8
 	as <- getArgs
 	when (null as) $ do
-		printMainUsage
+		printUsage
 		exitSuccess
 	let
 		asr = if last as == "-?" then "help" : init as else as 
 	run mainCommands onDef onError asr
 	where
-		onError :: [String] -> IO ()
+		onError :: String -> IO ()
 		onError errs = do
-			mapM_ putStrLn errs
+			putStrLn errs
 			exitFailure
 
 		onDef :: IO ()
@@ -36,10 +44,32 @@ 			putStrLn "Unknown command"
 			exitFailure
 
-printMainUsage :: IO ()
-printMainUsage = do
-	mapM_ (putStrLn . ('\t':) . ("hsdev " ++) . C.brief) mainCommands
-	putStrLn "\thsdev [--port=number] [--pretty] [--stdin] interactive command... -- send command to server, use flag stdin to pass data argument through stdin"
+mainCommands :: [Cmd (IO ())]
+mainCommands = withHelp "hsdev" (printWith putStrLn) $ concat [
+	[cmd "version" [] [] "hsdev version" version'],
+	map (chain [validateOpts, noArgs]) Server.commands,
+	map Server.clientCmd Client.commands]
+	where
+		version' _ = putStrLn $cabalVersion
 
 printUsage :: IO ()
-printUsage = mapM_ (putStrLn . ('\t':) . ("hsdev " ++) . C.brief) commands
+printUsage = mapM_ (putStrLn . ('\t':) . ("hsdev " ++) . C.brief) mainCommands
+
+-- | Check that specified options are numbers
+validateNums :: [String] -> Cmd a -> Cmd a
+validateNums ns = validateArgs (check . namedArgs) where
+	check os = forM_ ns $ \n -> case fmap (readMaybe :: String -> Maybe Int) $ arg n os of
+		Just Nothing -> failMatch "Must be a number"
+		_ -> return ()
+
+-- | Check, that 'port' and 'timeout' are numbers
+validateOpts :: Cmd a -> Cmd a
+validateOpts = validateNums ["port", "timeout"]
+
+-- | Ensure no positional arguments provided
+noArgs :: Cmd a -> Cmd a
+noArgs = validateArgs (noPos . posArgs) where
+	noPos ps =
+		guard (null ps)
+		`mplus`
+		failMatch "positional arguments are not expected"
tools/hshayoo.hs view
@@ -9,7 +9,7 @@ 
 main :: IO ()
 main = toolMain "hshayoo" [
-	jsonCmd_ [] ["query"] "search in hayoo" hayoo']
+	jsonCmd_ "" ["query"] "search in hayoo" hayoo']
 	where
 		hayoo' [q] = liftM (map hayooAsDeclaration . hayooFunctions) $ hayoo q
 		hayoo' _ = toolError "Invalid arguments"
tools/hsinspect.hs view
@@ -12,18 +12,18 @@ 
 main :: IO ()
 main = toolMain "hsinspect" [
-	jsonCmd ["module"] ["module name"] "inspect installed module" [ghcOpts] inspectModule',
-	jsonCmd ["file"] ["source file"] "inspect file" [ghcOpts] inspectFile',
-	jsonCmd_ ["cabal"] ["project file"] "inspect .cabal file" inspectCabal']
+	jsonCmd "module" ["module name"] [ghcOpts] "inspect installed module" inspectModule',
+	jsonCmd "file" ["source file"] [ghcOpts] "inspect file" inspectFile',
+	jsonCmd_ "cabal" ["project file"] "inspect .cabal file" inspectCabal']
 	where
-		ghcOpts = option_ ['g'] "ghc" (req "ghc options") "options to pass to GHC"
-		ghcs = list "ghc"
+		ghcOpts = list "ghc" "option" `short` ['g'] `desc` "options to pass to GHC"
+		ghcs = listArg "ghc"
 
-		inspectModule' opts [mname] = scanModule (ghcs opts) (CabalModule Cabal Nothing mname)
-		inspectModule' _ _ = toolError "Specify module name"
+		inspectModule' (Args [mname] opts) = scanModule (ghcs opts) (CabalModule Cabal Nothing mname)
+		inspectModule' _ = toolError "Specify module name"
 
-		inspectFile' opts [fname] = scanModule (ghcs opts) (FileModule fname Nothing)
-		inspectFile' _ _ = toolError "Specify source file name"
+		inspectFile' (Args [fname] opts) = scanModule (ghcs opts) (FileModule fname Nothing)
+		inspectFile' _ = toolError "Specify source file name"
 
 		inspectCabal' [fcabal] = readProject fcabal
 		inspectCabal' _ = toolError "Specify project .cabal file"