hsdev 0.3.3.8 → 0.3.4.0

raw patch · 91 files changed

+13752/−13706 lines, 91 filesdep +ghc-lib-parserdep ~Cabaldep ~aesondep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ghc-lib-parser

Dependency ranges changed: Cabal, aeson, ghc, ghc-boot, haddock-api, haddock-library, hlint, lens, template-haskell

API changes (from Hackage documentation)

Files

• LICENSE +30/−30
• data/hsdev.sql +360/−360
• hsdev.cabal +298/−286
• src/Control/Apply/Util.hs +9/−9
• src/Control/Concurrent/FiniteChan.hs +57/−57
• src/Control/Concurrent/Util.hs +22/−22
• src/Control/Concurrent/Worker.hs +92/−92
• src/Data/Deps.hs +105/−105
• src/Data/Help.hs +24/−24
• src/Data/Lisp.hs +126/−126
• src/Data/LookupTable.hs +65/−65
• src/Data/Maybe/JustIf.hs +19/−19
• src/HsDev.hs +31/−31
• src/HsDev/Client/Commands.hs +715/−715
• src/HsDev/Database/SQLite.hs +501/−501
• src/HsDev/Database/SQLite/Instances.hs +370/−370
• src/HsDev/Database/SQLite/Schema.hs +25/−25
• src/HsDev/Database/SQLite/Schema/TH.hs +16/−16
• src/HsDev/Database/SQLite/Select.hs +159/−159
• src/HsDev/Database/SQLite/Transaction.hs +98/−98
• src/HsDev/Database/Update.hs +693/−693
• src/HsDev/Database/Update/Types.hs +144/−144
• src/HsDev/Display.hs +22/−22
• src/HsDev/Error.hs +53/−53
• src/HsDev/Inspect.hs +326/−326
• src/HsDev/Inspect/Definitions.hs +141/−141
• src/HsDev/Inspect/Order.hs +42/−42
• src/HsDev/Inspect/Resolve.hs +383/−383
• src/HsDev/Inspect/Types.hs +104/−104
• src/HsDev/PackageDb.hs +84/−77
• src/HsDev/PackageDb/Types.hs +136/−136
• src/HsDev/Project.hs +207/−207
• src/HsDev/Project/Compat.hs +85/−84
• src/HsDev/Project/Types.hs +429/−429
• src/HsDev/Sandbox.hs +171/−171
• src/HsDev/Scan.hs +259/−259
• src/HsDev/Scan/Browse.hs +228/−226
• src/HsDev/Server/Base.hs +425/−425
• src/HsDev/Server/Commands.hs +190/−190
• src/HsDev/Server/Message.hs +118/−118
• src/HsDev/Server/Message/Lisp.hs +47/−47
• src/HsDev/Server/Types.hs +932/−932
• src/HsDev/Stack.hs +137/−137
• src/HsDev/Symbols.hs +137/−137
• src/HsDev/Symbols/Class.hs +30/−30
• src/HsDev/Symbols/Documented.hs +62/−62
• src/HsDev/Symbols/HaskellNames.hs +61/−61
• src/HsDev/Symbols/Location.hs +367/−367
• src/HsDev/Symbols/Name.hs +90/−90
• src/HsDev/Symbols/Parsed.hs +197/−197
• src/HsDev/Symbols/Resolve.hs +27/−27
• src/HsDev/Symbols/Types.hs +645/−648
• src/HsDev/Tools/AutoFix.hs +67/−67
• src/HsDev/Tools/Base.hs +87/−87
• src/HsDev/Tools/Cabal.hs +85/−85
• src/HsDev/Tools/ClearImports.hs +113/−113
• src/HsDev/Tools/Ghc/Base.hs +196/−196
• src/HsDev/Tools/Ghc/Check.hs +48/−48
• src/HsDev/Tools/Ghc/Compat.hs +292/−267
• src/HsDev/Tools/Ghc/MGhc.hs +260/−260
• src/HsDev/Tools/Ghc/Prelude.hs +91/−91
• src/HsDev/Tools/Ghc/Repl.hs +60/−60
• src/HsDev/Tools/Ghc/Session.hs +42/−42
• src/HsDev/Tools/Ghc/System.hs +56/−56
• src/HsDev/Tools/Ghc/Types.hs +174/−171
• src/HsDev/Tools/Ghc/Worker.hs +133/−133
• src/HsDev/Tools/HDocs.hs +179/−179
• src/HsDev/Tools/HLint.hs +118/−119
• src/HsDev/Tools/Hayoo.hs +143/−143
• src/HsDev/Tools/Refact.hs +56/−56
• src/HsDev/Tools/Tabs.hs +30/−30
• src/HsDev/Tools/Types.hs +103/−103
• src/HsDev/Types.hs +137/−137
• src/HsDev/Util.hs +329/−329
• src/HsDev/Version.hs +17/−17
• src/HsDev/Watcher.hs +73/−73
• src/HsDev/Watcher/Types.hs +14/−14
• src/System/Directory/Paths.hs +94/−94
• src/System/Directory/Watcher.hs +174/−174
• src/System/Win32/FileMapping/Memory.hs +53/−53
• src/System/Win32/FileMapping/NamePool.hs +33/−33
• src/System/Win32/PowerShell.hs +36/−36
• tests/Test.hs +189/−189
• tests/data/ModuleTwo.broken.hs +29/−29
• tests/data/ModuleTwo.modified.hs +25/−25
• tests/data/base.sql +4/−4
• tests/test-package/ModuleOne.hs +21/−21
• tests/test-package/ModuleThree.hs +15/−15
• tests/test-package/ModuleTwo.hs +21/−21
• tests/test-package/test-package.cabal +25/−25
• tools/hsdev.hs +36/−36

@@ -1,30 +1,30 @@-Copyright (c) 2013, Alexandr `Voidex` Ruchkin
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of Alexandr `Voidex` Ruchkin nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c) 2013, Alexandr `Voidex` Ruchkin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Alexandr `Voidex` Ruchkin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,360 +1,360 @@--- system table for various options, for now only version
-create table hsdev (
-	option text,
-	value json
-);
-
--- packages per package-db
-create table package_dbs (
-	package_db text not null, -- global, user or path
-	package_name text not null,
-	package_version text not null
-);
-
-create index package_names_index on package_dbs (package_db, package_name);
-
--- same as `package_dbs`, but only latest version of package left
-create view latest_packages (
-	package_db,
-	package_name,
-	package_version
-) as
-select package_db, package_name, max(package_version)
-from package_dbs
-group by package_db, package_name;
-
--- sandboxes
-create table sandboxes (
-	type text not null, -- cabal/stack
-	path text not null, -- sandbox path, should include `.cabal-sandbox`/`.stack-work`
-	package_db_stack json -- list of package-db of sandbox
-);
-
-create unique index sandboxes_path_index on sandboxes (path);
-
--- source projects
-create table projects (
-	id integer primary key autoincrement,
-	name text not null,
-	cabal text not null, -- path to `.cabal` file
-	version text,
-	build_tool text not null, -- cabal/stack
-	package_db_stack json -- list of package-db
-);
-
-create unique index projects_id_index on projects (id);
-create unique index projects_cabal_index on projects (cabal);
-
--- project's library targets
-create table libraries (
-	project_id integer not null,
-	modules json not null, -- list of modules
-	build_info_id integer not null
-);
-
-create unique index libraries_ids_index on libraries (project_id, build_info_id);
-
--- project's executables targets
-create table executables (
-	project_id integer not null,
-	name text not null,
-	path text not null,
-	build_info_id integer not null
-);
-
-create unique index executables_ids_index on executables (project_id, build_info_id);
-
--- project's tests targets
-create table tests (
-	project_id integer not null,
-	name text not null,
-	enabled integer not null,
-	main text,
-	build_info_id integer not null
-);
-
-create unique index tests_ids_index on tests (project_id, build_info_id);
-
--- map from project to build-info for all targets
-create view targets (
-	project_id,
-	build_info_id
-) as
-select project_id, build_info_id from libraries
-union
-select project_id, build_info_id from executables
-union
-select project_id, build_info_id from tests;
-
--- target build-info
-create table build_infos(
-	id integer primary key autoincrement,
-	depends json not null, -- list of dependencies
-	language text,
-	extensions json not null, -- list of extensions
-	ghc_options json not null, -- list of ghc-options
-	source_dirs json not null, -- list of source directories
-	other_modules json not null -- list of other modules
-);
-
-create unique index build_infos_id_index on build_infos (id);
-
--- project dependent packages
-create view projects_deps (
-	cabal,
-	package_db,
-	package_name,
-	package_version
-) as
-select distinct p.cabal, ps.package_db, ps.package_name, ps.package_version
-from projects as p, json_each(p.package_db_stack) as pdb_stack, build_infos as b, json_each(b.depends) as deps, targets as t, latest_packages as ps
-where
-	(p.id == t.project_id) and
-	(b.id == t.build_info_id) and
-	(deps.value <> p.name) and
-	(ps.package_name == deps.value) and
-	(ps.package_db == pdb_stack.value);
-
--- packages in scope of project
--- `cabal` may be null for standalone files, in this case all 'user-db' is in scope
-create view projects_modules_scope (
-	cabal,
-	module_id
-) as
-select pdbs.cabal, m.id
-from projects_deps as pdbs, modules as m
-where
-	(m.package_name == pdbs.package_name) and
-	(m.package_version == pdbs.package_version) and
-	m.exposed
-union
-select p.cabal, m.id
-from projects as p, modules as m
-where (m.cabal == p.cabal)
-union
-select null, m.id
-from modules as m, latest_packages as ps
-where
-	(m.package_name == ps.package_name) and
-	(m.package_version == ps.package_version) and
-	m.exposed and
-	(ps.package_db in ('user-db', 'global-db'));
-
--- symbols
-create table symbols (
-	id integer primary key autoincrement,
-	name text not null,
-	module_id integer not null, -- definition module
-	docs text,
-	line integer, -- line of definition
-	column integer, -- column of definition
-	what text not null, -- kind of symbol: function, method, ...
-	type text, -- type of function/method/...
-	parent text, -- parent of selector/method/...
-	constructors json, -- list of constructors for selector
-	args json, -- list of arguments for types
-	context json, -- list of contexts for types
-	associate text, -- associates for families
-	pat_type text,
-	pat_constructor text
-);
-
-create unique index symbols_id_index on symbols (id);
-create unique index symbols_index on symbols (module_id, name, what);
-
--- modules
-create table modules (
-	id integer primary key autoincrement,
-	-- source module location
-	file text, -- source file
-	cabal text, -- related project's `.cabal`
-	-- installed module location
-	install_dirs json, -- list of paths
-	package_name text, -- package name of module
-	package_version text, -- package version
-	installed_name text, -- if not null, should be equal to name
-	exposed integer, -- is module exposed or hidden
-	-- some other location
-	other_location text, -- anything
-
-	name text,
-	docs text,
-	fixities json, -- list of fixities
-	tags json, -- dict of tags, value not used, tag is set if present; used by hsdev to mark if types was inferred or docs scanned
-	inspection_error text,
-	inspection_time real,
-	inspection_opts json -- list of flags
-);
-
-create unique index modules_id_index on modules (id);
-create index modules_name_index on modules (name);
-create unique index modules_file_index on modules (file) where file is not null;
-create unique index modules_installed_index on modules (package_name, package_version, installed_name) where
-	package_name is not null and
-	package_version is not null and
-	installed_name is not null;
-create unique index modules_other_locations_index on modules (other_location) where other_location is not null;
-
--- module import statements
-create table imports (
-	module_id integer not null,
-	line integer not null, -- line number of import
-	column integer not null, -- column of impoty
-	module_name text not null, -- import module name
-	qualified integer not null, -- is import qualified
-	alias text, -- imported with `as`
-	hiding integer, -- is list hiding
-	import_list json, -- list of import specs, null if not specified
-	import_module_id -- `id` of imported module
-);
-
-create unique index imports_position_index on imports (module_id, line, column);
-
--- symbols bringed into scope by import, with qualifier
-create view imported_scopes as
-select i.*, q.value as qualifier, s.name as name, s.id as symbol_id
-from imports as i, json_each(case when i.qualified then json_array(ifnull(i.alias, i.module_name)) else json_array(ifnull(i.alias, i.module_name), null) end) as q, symbols as s, exports as e
-where
-	e.module_id == i.import_module_id and
-	e.symbol_id == s.id and
-	(i.import_list is null or (s.name in (select json_extract(import_list_item.value, '$.name') from json_each(i.import_list) as import_list_item) == not i.hiding));
-
--- module exports
-create table exports (
-	module_id integer not null,
-	symbol_id integer not null
-);
-
-create index exports_module_id_index on exports (module_id);
-
--- source file module's symbols in scope
-create table scopes (
-	module_id integer not null,
-	qualifier text,
-	name text not null,
-	symbol_id integer not null
-);
-
-create index scopes_name_index on scopes (module_id, name);
-
--- like `scopes`, but with column `completion` with fully qualified name
-create view completions (
-	module_id,
-	completion,
-	qualifier,
-	symbol_id
-) as
-select id, (case when sc.qualifier is null then sc.name else sc.qualifier || '.' || sc.name end) as full_name, sc.qualifier, sc.symbol_id
-from modules as m, scopes as sc
-where (m.id == sc.module_id);
-
--- resolved names in module
-create table names (
-	module_id integer not null,
-	qualifier text, -- name qualifier
-	name text not null, -- name
-	line integer not null, -- line of name
-	column integer not null, -- column of name
-	line_to integer not null, -- line of name end
-	column_to integer not null, -- column of name end
-	def_line integer, -- name definition line, for local names
-	def_column integer, -- name definition column, for local names
-	inferred_type text, -- inferred name type, set by hsdev
-	resolved_module text, -- resolved module name, for global and top-level names
-	resolved_name text, -- resolved name, for global and top-level names
-	resolved_what text, -- resolved symbol kind
-	resolve_error text,
-	symbol_id integer -- resolved symbol id
-);
-
-create unique index names_position_index on names (module_id, line, column, line_to, column_to);
-create index names_name_index on names (module_id, name);
-
--- like `names`, but with definition position set for both local and global names
-create view definitions (
-	module_id,
-	name,
-	line,
-	column,
-	line_to,
-	column_to,
-	def_module_id,
-	def_line,
-	def_column,
-	local
-) as
-select module_id, name, line, column, line_to, column_to, module_id, def_line, def_column, 1
-from names
-where def_line is not null and def_column is not null
-union
-select n.module_id, n.resolved_name, n.line, n.column, n.line_to, n.column_to, s.module_id, s.line, s.column, 0
-from names as n, modules as srcm, modules as m, symbols as s
-where
-	(n.module_id == srcm.id) and
-	(n.symbol_id == s.id) and
-	(m.name == n.resolved_module) and
-	(s.module_id == m.id) and
-	(s.name == n.resolved_name);
-
--- sources dependencies relations
-create view sources_depends (
-	module_id,
-	module_file,
-	depends_id,
-	depends_file
-) as
-select m.id, m.file, im.id, im.file
-from modules as im, imports as i, modules as m, projects_modules_scope as ps
-where
-	(m.cabal is ps.cabal) and
-	(ps.module_id == im.id) and
-	(i.module_id == m.id) and
-	(im.name == i.module_name) and
-	(m.file is not null) and
-	(im.file is not null);
-
--- expressions types
-create table types (
-	module_id integer not null,
-	line integer not null, -- line of expression
-	column integer not null, -- column of expression
-	line_to integer not null, --  line of expression end
-	column_to integer not null, -- column of expression end
-	expr text not null, -- expression contents
-	type text not null -- expression type
-);
-
-create unique index types_position_index on types (module_id, line, column, line_to, column_to);
-
--- modified file contents, hsdev will use it in commands whenever it is newer than file
-create table file_contents (
-	file text not null, -- file path
-	contents text not null, -- file contents
-	mtime real not null -- posix modification time
-);
-
-create unique index file_contents_index on file_contents (file);
-
--- table with last time of loading module
-create table load_times (
-	module_id integer not null, -- module affected
-	load_time real not null -- timestamp
-);
-
-create unique index load_times_module_id_index on load_times (module_id);
-
--- table with ghc warnings on file
--- sequential call to load module won't actually reload file and won't produce warnings
--- but we want to see them again
-create table messages (
-	module_id integer not null,
-	line integer not null,
-	column integer not null,
-	line_to integer not null,
-	column_to integer not null,
-	severity text,
-	message text not null,
-	suggestion text
-);
-
-create index messages_module_id_index on messages (module_id);
+-- system table for various options, for now only version+create table hsdev (+	option text,+	value json+);++-- packages per package-db+create table package_dbs (+	package_db text not null, -- global, user or path+	package_name text not null,+	package_version text not null+);++create index package_names_index on package_dbs (package_db, package_name);++-- same as `package_dbs`, but only latest version of package left+create view latest_packages (+	package_db,+	package_name,+	package_version+) as+select package_db, package_name, max(package_version)+from package_dbs+group by package_db, package_name;++-- sandboxes+create table sandboxes (+	type text not null, -- cabal/stack+	path text not null, -- sandbox path, should include `.cabal-sandbox`/`.stack-work`+	package_db_stack json -- list of package-db of sandbox+);++create unique index sandboxes_path_index on sandboxes (path);++-- source projects+create table projects (+	id integer primary key autoincrement,+	name text not null,+	cabal text not null, -- path to `.cabal` file+	version text,+	build_tool text not null, -- cabal/stack+	package_db_stack json -- list of package-db+);++create unique index projects_id_index on projects (id);+create unique index projects_cabal_index on projects (cabal);++-- project's library targets+create table libraries (+	project_id integer not null,+	modules json not null, -- list of modules+	build_info_id integer not null+);++create unique index libraries_ids_index on libraries (project_id, build_info_id);++-- project's executables targets+create table executables (+	project_id integer not null,+	name text not null,+	path text not null,+	build_info_id integer not null+);++create unique index executables_ids_index on executables (project_id, build_info_id);++-- project's tests targets+create table tests (+	project_id integer not null,+	name text not null,+	enabled integer not null,+	main text,+	build_info_id integer not null+);++create unique index tests_ids_index on tests (project_id, build_info_id);++-- map from project to build-info for all targets+create view targets (+	project_id,+	build_info_id+) as+select project_id, build_info_id from libraries+union+select project_id, build_info_id from executables+union+select project_id, build_info_id from tests;++-- target build-info+create table build_infos(+	id integer primary key autoincrement,+	depends json not null, -- list of dependencies+	language text,+	extensions json not null, -- list of extensions+	ghc_options json not null, -- list of ghc-options+	source_dirs json not null, -- list of source directories+	other_modules json not null -- list of other modules+);++create unique index build_infos_id_index on build_infos (id);++-- project dependent packages+create view projects_deps (+	cabal,+	package_db,+	package_name,+	package_version+) as+select distinct p.cabal, ps.package_db, ps.package_name, ps.package_version+from projects as p, json_each(p.package_db_stack) as pdb_stack, build_infos as b, json_each(b.depends) as deps, targets as t, latest_packages as ps+where+	(p.id == t.project_id) and+	(b.id == t.build_info_id) and+	(deps.value <> p.name) and+	(ps.package_name == deps.value) and+	(ps.package_db == pdb_stack.value);++-- packages in scope of project+-- `cabal` may be null for standalone files, in this case all 'user-db' is in scope+create view projects_modules_scope (+	cabal,+	module_id+) as+select pdbs.cabal, m.id+from projects_deps as pdbs, modules as m+where+	(m.package_name == pdbs.package_name) and+	(m.package_version == pdbs.package_version) and+	m.exposed+union+select p.cabal, m.id+from projects as p, modules as m+where (m.cabal == p.cabal)+union+select null, m.id+from modules as m, latest_packages as ps+where+	(m.package_name == ps.package_name) and+	(m.package_version == ps.package_version) and+	m.exposed and+	(ps.package_db in ('user-db', 'global-db'));++-- symbols+create table symbols (+	id integer primary key autoincrement,+	name text not null,+	module_id integer not null, -- definition module+	docs text,+	line integer, -- line of definition+	column integer, -- column of definition+	what text not null, -- kind of symbol: function, method, ...+	type text, -- type of function/method/...+	parent text, -- parent of selector/method/...+	constructors json, -- list of constructors for selector+	args json, -- list of arguments for types+	context json, -- list of contexts for types+	associate text, -- associates for families+	pat_type text,+	pat_constructor text+);++create unique index symbols_id_index on symbols (id);+create unique index symbols_index on symbols (module_id, name, what);++-- modules+create table modules (+	id integer primary key autoincrement,+	-- source module location+	file text, -- source file+	cabal text, -- related project's `.cabal`+	-- installed module location+	install_dirs json, -- list of paths+	package_name text, -- package name of module+	package_version text, -- package version+	installed_name text, -- if not null, should be equal to name+	exposed integer, -- is module exposed or hidden+	-- some other location+	other_location text, -- anything++	name text,+	docs text,+	fixities json, -- list of fixities+	tags json, -- dict of tags, value not used, tag is set if present; used by hsdev to mark if types was inferred or docs scanned+	inspection_error text,+	inspection_time real,+	inspection_opts json -- list of flags+);++create unique index modules_id_index on modules (id);+create index modules_name_index on modules (name);+create unique index modules_file_index on modules (file) where file is not null;+create unique index modules_installed_index on modules (package_name, package_version, installed_name) where+	package_name is not null and+	package_version is not null and+	installed_name is not null;+create unique index modules_other_locations_index on modules (other_location) where other_location is not null;++-- module import statements+create table imports (+	module_id integer not null,+	line integer not null, -- line number of import+	column integer not null, -- column of impoty+	module_name text not null, -- import module name+	qualified integer not null, -- is import qualified+	alias text, -- imported with `as`+	hiding integer, -- is list hiding+	import_list json, -- list of import specs, null if not specified+	import_module_id -- `id` of imported module+);++create unique index imports_position_index on imports (module_id, line, column);++-- symbols bringed into scope by import, with qualifier+create view imported_scopes as+select i.*, q.value as qualifier, s.name as name, s.id as symbol_id+from imports as i, json_each(case when i.qualified then json_array(ifnull(i.alias, i.module_name)) else json_array(ifnull(i.alias, i.module_name), null) end) as q, symbols as s, exports as e+where+	e.module_id == i.import_module_id and+	e.symbol_id == s.id and+	(i.import_list is null or (s.name in (select json_extract(import_list_item.value, '$.name') from json_each(i.import_list) as import_list_item) == not i.hiding));++-- module exports+create table exports (+	module_id integer not null,+	symbol_id integer not null+);++create index exports_module_id_index on exports (module_id);++-- source file module's symbols in scope+create table scopes (+	module_id integer not null,+	qualifier text,+	name text not null,+	symbol_id integer not null+);++create index scopes_name_index on scopes (module_id, name);++-- like `scopes`, but with column `completion` with fully qualified name+create view completions (+	module_id,+	completion,+	qualifier,+	symbol_id+) as+select id, (case when sc.qualifier is null then sc.name else sc.qualifier || '.' || sc.name end) as full_name, sc.qualifier, sc.symbol_id+from modules as m, scopes as sc+where (m.id == sc.module_id);++-- resolved names in module+create table names (+	module_id integer not null,+	qualifier text, -- name qualifier+	name text not null, -- name+	line integer not null, -- line of name+	column integer not null, -- column of name+	line_to integer not null, -- line of name end+	column_to integer not null, -- column of name end+	def_line integer, -- name definition line, for local names+	def_column integer, -- name definition column, for local names+	inferred_type text, -- inferred name type, set by hsdev+	resolved_module text, -- resolved module name, for global and top-level names+	resolved_name text, -- resolved name, for global and top-level names+	resolved_what text, -- resolved symbol kind+	resolve_error text,+	symbol_id integer -- resolved symbol id+);++create unique index names_position_index on names (module_id, line, column, line_to, column_to);+create index names_name_index on names (module_id, name);++-- like `names`, but with definition position set for both local and global names+create view definitions (+	module_id,+	name,+	line,+	column,+	line_to,+	column_to,+	def_module_id,+	def_line,+	def_column,+	local+) as+select module_id, name, line, column, line_to, column_to, module_id, def_line, def_column, 1+from names+where def_line is not null and def_column is not null+union+select n.module_id, n.resolved_name, n.line, n.column, n.line_to, n.column_to, s.module_id, s.line, s.column, 0+from names as n, modules as srcm, modules as m, symbols as s+where+	(n.module_id == srcm.id) and+	(n.symbol_id == s.id) and+	(m.name == n.resolved_module) and+	(s.module_id == m.id) and+	(s.name == n.resolved_name);++-- sources dependencies relations+create view sources_depends (+	module_id,+	module_file,+	depends_id,+	depends_file+) as+select m.id, m.file, im.id, im.file+from modules as im, imports as i, modules as m, projects_modules_scope as ps+where+	(m.cabal is ps.cabal) and+	(ps.module_id == im.id) and+	(i.module_id == m.id) and+	(im.name == i.module_name) and+	(m.file is not null) and+	(im.file is not null);++-- expressions types+create table types (+	module_id integer not null,+	line integer not null, -- line of expression+	column integer not null, -- column of expression+	line_to integer not null, --  line of expression end+	column_to integer not null, -- column of expression end+	expr text not null, -- expression contents+	type text not null -- expression type+);++create unique index types_position_index on types (module_id, line, column, line_to, column_to);++-- modified file contents, hsdev will use it in commands whenever it is newer than file+create table file_contents (+	file text not null, -- file path+	contents text not null, -- file contents+	mtime real not null -- posix modification time+);++create unique index file_contents_index on file_contents (file);++-- table with last time of loading module+create table load_times (+	module_id integer not null, -- module affected+	load_time real not null -- timestamp+);++create unique index load_times_module_id_index on load_times (module_id);++-- table with ghc warnings on file+-- sequential call to load module won't actually reload file and won't produce warnings+-- but we want to see them again+create table messages (+	module_id integer not null,+	line integer not null,+	column integer not null,+	line_to integer not null,+	column_to integer not null,+	severity text,+	message text not null,+	suggestion text+);++create index messages_module_id_index on messages (module_id);

@@ -1,286 +1,298 @@-name:                hsdev
-version:             0.3.3.8
-synopsis:            Haskell development library
-description:
-  Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
-homepage:            https://github.com/mvoidex/hsdev
-license:             BSD3
-license-file:        LICENSE
-author:              Alexandr `Voidex` Ruchkin
-maintainer:          voidex@live.com
--- copyright:
-category:            Development
-build-type:          Simple
-cabal-version:       >=1.8
-extra-source-files:
-  tests/test-package/*.hs
-  tests/test-package/test-package.cabal
-  tests/data/base.sql
-  tests/data/ModuleTwo.modified.hs
-  tests/data/ModuleTwo.broken.hs
-  data/hsdev.sql
-
-source-repository head
-  type: git
-  location: git://github.com/mvoidex/hsdev.git
-
-flag docs
-  description: build with haddock/hdocs to support scanning docs
-  default: True
-
-flag hlint
-  description: build with hlint to support linting
-  default: True
-
-library
-  hs-source-dirs: src
-  ghc-options: -Wall -fno-warn-tabs
-
-  if !flag(docs)
-    cpp-options: -DNODOCS
-
-  if !flag(hlint)
-    cpp-options: -DNOHLINT
-
-  exposed-modules:
-    Control.Apply.Util
-    Control.Concurrent.FiniteChan
-    Control.Concurrent.Worker
-    Control.Concurrent.Util
-    Data.Deps
-    Data.Help
-    Data.Lisp
-    Data.Maybe.JustIf
-    Data.LookupTable
-    HsDev
-    HsDev.Client.Commands
-    HsDev.Database.SQLite
-    HsDev.Database.SQLite.Instances
-    HsDev.Database.SQLite.Schema
-    HsDev.Database.SQLite.Schema.TH
-    HsDev.Database.SQLite.Select
-    HsDev.Database.SQLite.Transaction
-    HsDev.Database.Update
-    HsDev.Database.Update.Types
-    HsDev.Display
-    HsDev.Error
-    HsDev.Inspect
-    HsDev.Inspect.Definitions
-    HsDev.Inspect.Order
-    HsDev.Inspect.Resolve
-    HsDev.Inspect.Types
-    HsDev.PackageDb
-    HsDev.PackageDb.Types
-    HsDev.Project
-    HsDev.Project.Compat
-    HsDev.Project.Types
-    HsDev.Scan
-    HsDev.Scan.Browse
-    HsDev.Server.Base
-    HsDev.Server.Commands
-    HsDev.Server.Message
-    HsDev.Server.Message.Lisp
-    HsDev.Server.Types
-    HsDev.Sandbox
-    HsDev.Stack
-    HsDev.Symbols
-    HsDev.Symbols.Name
-    HsDev.Symbols.Class
-    HsDev.Symbols.HaskellNames
-    HsDev.Symbols.Location
-    HsDev.Symbols.Documented
-    HsDev.Symbols.Resolve
-    HsDev.Symbols.Parsed
-    HsDev.Symbols.Types
-    HsDev.Tools.AutoFix
-    HsDev.Tools.Base
-    HsDev.Tools.Cabal
-    HsDev.Tools.ClearImports
-    HsDev.Tools.Ghc.Base
-    HsDev.Tools.Ghc.Check
-    HsDev.Tools.Ghc.Compat
-    HsDev.Tools.Ghc.MGhc
-    HsDev.Tools.Ghc.Prelude
-    HsDev.Tools.Ghc.Repl
-    HsDev.Tools.Ghc.Session
-    HsDev.Tools.Ghc.System
-    HsDev.Tools.Ghc.Types
-    HsDev.Tools.Ghc.Worker
-    HsDev.Tools.Hayoo
-    HsDev.Tools.HDocs
-    HsDev.Tools.HLint
-    HsDev.Tools.Refact
-    HsDev.Tools.Tabs
-    HsDev.Tools.Types
-    HsDev.Types
-    HsDev.Util
-    HsDev.Version
-    HsDev.Watcher
-    HsDev.Watcher.Types
-    System.Directory.Paths
-    System.Directory.Watcher
-
-  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.2.0 && < 2.8
-
-  if impl(ghc >= 8.8) && impl(ghc < 8.9)
-    build-depends:
-      ghc   == 8.8.*,
-      Cabal >= 3.0 && < 3.1
-
-  if impl(ghc >= 8.6) && impl(ghc < 8.7)
-    build-depends:
-      ghc   == 8.6.*,
-      Cabal >= 2.4 && < 3.1
-
-  if impl(ghc >= 8.4) && impl(ghc < 8.5)
-    build-depends:
-      ghc   == 8.4.*,
-      Cabal == 2.2.0.1
-
-  if impl(ghc >= 8.2) && impl(ghc < 8.3)
-    build-depends:
-      ghc   == 8.2.*,
-      Cabal == 2.0.1.1
-
-  if impl(ghc >= 8.0) && impl(ghc < 8.2)
-    build-depends:
-      ghc >= 8.0.0 && < 8.1.0,
-      Cabal >= 1.24.2.0 && < 2.0
-
-  if flag(docs)
-    build-depends:
-      hdocs >= 0.5.3,
-      haddock-library >= 1.4.3 && < 1.9
-
-    if impl(ghc >= 8.8) && impl(ghc < 8.9)
-      build-depends:
-        haddock-api >= 2.23
-
-    if impl(ghc >= 8.6) && impl(ghc < 8.7)
-      build-depends:
-        haddock-api >= 2.21 && < 2.23
-
-    if impl(ghc >= 8.4) && impl(ghc < 8.5)
-      build-depends:
-        haddock-api == 2.20.*
-
-    if impl(ghc >= 8.2) && impl(ghc < 8.3)
-      build-depends:
-        haddock-api == 2.18.*
-
-    if impl(ghc >= 8.0) && impl(ghc < 8.2)
-      build-depends:
-        haddock-api == 2.17.*
-
-
-  if flag(hlint)
-    build-depends:
-      hlint >= 2.0.11 && < 2.3
-
-  -- Build dependency lower bound is set for GHC 8.0.1.
-  -- Upper bound is set for GHC 8.4
-  build-depends:
-    base                              >= 4.9 && < 5,
-    aeson                             >= 1.2.4.0 && < 1.5,
-    aeson-pretty                      >= 0.8.2 && < 0.9,
-    array                             >= 0.5.1.1 && < 0.6,
-    async                             >= 2.1.1.1 && < 2.3,
-    attoparsec                        >= 0.13.1.0 && < 0.14,
-    bytestring                        >= 0.10.8.1 && < 0.11,
-    containers                        >= 0.5.7.1 && < 0.7,
-    cpphs                             >= 1.20.5 && < 1.21,
-    data-default                      >= 0.7.1.1 && < 0.8,
-    deepseq                           >= 1.4.2.0 && < 1.5,
-    direct-sqlite                     >= 2.3.19 && < 2.4,
-    directory                         >= 1.2.6.2 && < 1.4,
-    exceptions                        >= 0.8.3 && < 0.11,
-    filepath                          >= 1.4.1.0 && < 1.5,
-    fsnotify                          >= 0.2.1 && < 0.4,
-    ghc-boot                          >= 8.0.1 && < 8.9,
-    ghc-paths                         >= 0.1.0.9 && < 0.2,
-    haskell-names                     >= 0.9.1 && < 0.10.0,
-    haskell-src-exts                  >= 1.19.1 && < 1.24.0,
-    hformat                           >= 0.1.0.1 && < 0.4,
-    hlint                             >= 2.0.11 && < 2.3,
-    http-client                    >= 0.5 && < 0.7,
-    lens                              >= 4.14 && < 4.19,
-    lifted-base                       >= 0.2.3.10 && < 0.3,
-    mmorph                            >= 1.0.9 && < 1.2,
-    monad-control                     >= 1.0.1.0 && < 1.1,
-    monad-loops                       >= 0.4.3 && < 0.5,
-    mtl                               >= 2.2.1 && < 2.3,
-    network                           >= 2.8 && < 3.2,
-    network-uri                      >= 2.6 && < 2.7,
-    optparse-applicative              >= 0.12.1.0 && < 0.16,
-    process                           >= 1.4.2.0 && < 1.7,
-    regex-pcre-builtin                >= 0.94.4 && < 0.96,
-    scientific                        >= 0.3.4.9 && < 0.4,
-    simple-log                        >= 0.9.9 && < 0.10,
-    sqlite-simple                     >= 0.4.13.0 && < 0.5,
-    stm                               >= 2.4 && < 2.6,
-    syb                               >= 0.6 && < 0.8,
-    template-haskell                  >= 2.11.0 && < 2.16,
-    text                              >= 1.2.2.2 && < 1.3,
-    text-region                       >= 0.1.0.1 && < 0.4,
-    time                              >= 1.6.0.1 && < 1.10,
-    transformers                      >= 0.5.2.0 && < 0.6,
-    transformers-base                 >= 0.4.4 && < 0.5,
-    uniplate                          >= 1.6.12 && < 1.7,
-    unordered-containers              >= 0.2.8.0 && < 0.3,
-    vector                            >= 0.11.0.0 && < 0.13
-
-executable hsdev
-  main-is: hsdev.hs
-  hs-source-dirs: tools
-  ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4"
-
-  build-depends:
-    hsdev,
-    base                              >= 4.9 && < 5,
-    aeson                             >= 1.2.4.0 && < 1.5,
-    aeson-pretty                      >= 0.8.2 && < 0.9,
-    bytestring                        >= 0.10.8.1 && < 0.11,
-    containers                        >= 0.5.7.1 && < 0.7,
-    deepseq                           >= 1.4.2.0 && < 1.5,
-    directory                         >= 1.2.6.2 && < 1.4,
-    exceptions                        >= 0.8.3 && < 0.11,
-    filepath                          >= 1.4.1.0 && < 1.5,
-    monad-loops                       >= 0.4.3 && < 0.5,
-    mtl                               >= 2.2.1 && < 2.3,
-    network                           >= 2.8 && < 3.2,
-    optparse-applicative              >= 0.12.1.0 && < 0.16,
-    process                           >= 1.4.2.0 && < 1.7,
-    text                              >= 1.2.2.2 && < 1.3,
-    transformers                      >= 0.5.2.0 && < 0.6,
-    unordered-containers              >= 0.2.8.0 && < 0.3
-
-test-suite test
-  main-is: Test.hs
-  hs-source-dirs: tests
-  ghc-options: -threaded -Wall -fno-warn-tabs
-  type: exitcode-stdio-1.0
-  build-depends:
-    hsdev,
-    base                              >= 4.9 && < 5,
-    aeson                             >= 1.2.4.0 && < 1.5,
-    lens-aeson                        >= 1.0 && < 1.2,
-    async                             >= 2.1.1.1 && < 2.3,
-    containers                        >= 0.5.7.1 && < 0.7,
-    data-default                      >= 0.7.1.1 && < 0.8,
-    deepseq                           >= 1.4.2.0 && < 1.5,
-    directory                         >= 1.2.6.2 && < 1.4,
-    filepath                          >= 1.4.1.0 && < 1.5,
-    hformat                           >= 0.1.0.1 && < 0.4,
-    hspec                             >= 2.2.4,
-    lens                              >= 4.14 && < 4.19,
-    mtl                               >= 2.2.1 && < 2.3,
-    text                              >= 1.2.2.2 && < 1.3
+name:                hsdev+version:             0.3.4.0+synopsis:            Haskell development library+description:+  Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.+homepage:            https://github.com/mvoidex/hsdev+license:             BSD3+license-file:        LICENSE+author:              Alexandr `Voidex` Ruchkin+maintainer:          voidex@live.com+-- copyright:+category:            Development+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:+  tests/test-package/*.hs+  tests/test-package/test-package.cabal+  tests/data/base.sql+  tests/data/ModuleTwo.modified.hs+  tests/data/ModuleTwo.broken.hs+  data/hsdev.sql++source-repository head+  type: git+  location: git://github.com/mvoidex/hsdev.git++flag docs+  description: build with haddock/hdocs to support scanning docs+  default: True++flag hlint+  description: build with hlint to support linting+  default: True++library+  hs-source-dirs: src+  ghc-options: -Wall -fno-warn-tabs+  default-language: Haskell2010++  if !flag(docs)+    cpp-options: -DNODOCS++  if !flag(hlint)+    cpp-options: -DNOHLINT++  exposed-modules:+    Control.Apply.Util+    Control.Concurrent.FiniteChan+    Control.Concurrent.Worker+    Control.Concurrent.Util+    Data.Deps+    Data.Help+    Data.Lisp+    Data.Maybe.JustIf+    Data.LookupTable+    HsDev+    HsDev.Client.Commands+    HsDev.Database.SQLite+    HsDev.Database.SQLite.Instances+    HsDev.Database.SQLite.Schema+    HsDev.Database.SQLite.Schema.TH+    HsDev.Database.SQLite.Select+    HsDev.Database.SQLite.Transaction+    HsDev.Database.Update+    HsDev.Database.Update.Types+    HsDev.Display+    HsDev.Error+    HsDev.Inspect+    HsDev.Inspect.Definitions+    HsDev.Inspect.Order+    HsDev.Inspect.Resolve+    HsDev.Inspect.Types+    HsDev.PackageDb+    HsDev.PackageDb.Types+    HsDev.Project+    HsDev.Project.Compat+    HsDev.Project.Types+    HsDev.Scan+    HsDev.Scan.Browse+    HsDev.Server.Base+    HsDev.Server.Commands+    HsDev.Server.Message+    HsDev.Server.Message.Lisp+    HsDev.Server.Types+    HsDev.Sandbox+    HsDev.Stack+    HsDev.Symbols+    HsDev.Symbols.Name+    HsDev.Symbols.Class+    HsDev.Symbols.HaskellNames+    HsDev.Symbols.Location+    HsDev.Symbols.Documented+    HsDev.Symbols.Resolve+    HsDev.Symbols.Parsed+    HsDev.Symbols.Types+    HsDev.Tools.AutoFix+    HsDev.Tools.Base+    HsDev.Tools.Cabal+    HsDev.Tools.ClearImports+    HsDev.Tools.Ghc.Base+    HsDev.Tools.Ghc.Check+    HsDev.Tools.Ghc.Compat+    HsDev.Tools.Ghc.MGhc+    HsDev.Tools.Ghc.Prelude+    HsDev.Tools.Ghc.Repl+    HsDev.Tools.Ghc.Session+    HsDev.Tools.Ghc.System+    HsDev.Tools.Ghc.Types+    HsDev.Tools.Ghc.Worker+    HsDev.Tools.Hayoo+    HsDev.Tools.HDocs+    HsDev.Tools.HLint+    HsDev.Tools.Refact+    HsDev.Tools.Tabs+    HsDev.Tools.Types+    HsDev.Types+    HsDev.Util+    HsDev.Version+    HsDev.Watcher+    HsDev.Watcher.Types+    System.Directory.Paths+    System.Directory.Watcher++  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.2.0 && < 2.8++  if impl(ghc >= 8.10) && impl(ghc < 8.11)+    build-depends:+      ghc   == 8.10.*,+      Cabal >= 3.2 && < 3.3++  if impl(ghc >= 8.8) && impl(ghc < 8.9)+    build-depends:+      ghc   == 8.8.*,+      Cabal >= 3.0 && < 3.1++  if impl(ghc >= 8.6) && impl(ghc < 8.7)+    build-depends:+      ghc   == 8.6.*,+      Cabal >= 2.4 && < 3.1++  if impl(ghc >= 8.4) && impl(ghc < 8.5)+    build-depends:+      ghc   == 8.4.*,+      Cabal == 2.2.0.1++  if impl(ghc >= 8.2) && impl(ghc < 8.3)+    build-depends:+      ghc   == 8.2.*,+      Cabal == 2.0.1.1++  if impl(ghc >= 8.0) && impl(ghc < 8.2)+    build-depends:+      ghc >= 8.0.0 && < 8.1.0,+      Cabal >= 1.24.2.0 && < 2.0++  if flag(docs)+    build-depends:+      hdocs >= 0.5.3,+      haddock-library >= 1.4.3 && < 1.10++    if impl(ghc >= 8.10) && impl(ghc < 8.11)+      build-depends:+        haddock-api >= 2.24++    if impl(ghc >= 8.8) && impl(ghc < 8.9)+      build-depends:+        haddock-api >= 2.23++    if impl(ghc >= 8.6) && impl(ghc < 8.7)+      build-depends:+        haddock-api >= 2.21 && < 2.23++    if impl(ghc >= 8.4) && impl(ghc < 8.5)+      build-depends:+        haddock-api == 2.20.*++    if impl(ghc >= 8.2) && impl(ghc < 8.3)+      build-depends:+        haddock-api == 2.18.*++    if impl(ghc >= 8.0) && impl(ghc < 8.2)+      build-depends:+        haddock-api == 2.17.*+++  if flag(hlint)+    build-depends:+      hlint >= 3.0.0 && < 3.3.0,+      ghc-lib-parser == 8.10.*++  -- Build dependency lower bound is set for GHC 8.0.1.+  -- Upper bound is set for GHC 8.4+  build-depends:+    base                              >= 4.9 && < 5,+    aeson                             >= 1.2.4.0 && < 1.6,+    aeson-pretty                      >= 0.8.2 && < 0.9,+    array                             >= 0.5.1.1 && < 0.6,+    async                             >= 2.1.1.1 && < 2.3,+    attoparsec                        >= 0.13.1.0 && < 0.14,+    bytestring                        >= 0.10.8.1 && < 0.11,+    containers                        >= 0.5.7.1 && < 0.7,+    cpphs                             >= 1.20.5 && < 1.21,+    data-default                      >= 0.7.1.1 && < 0.8,+    deepseq                           >= 1.4.2.0 && < 1.5,+    direct-sqlite                     >= 2.3.19 && < 2.4,+    directory                         >= 1.2.6.2 && < 1.4,+    exceptions                        >= 0.8.3 && < 0.11,+    filepath                          >= 1.4.1.0 && < 1.5,+    fsnotify                          >= 0.2.1 && < 0.4,+    ghc-boot                          >= 8.0.1 && < 8.11,+    ghc-paths                         >= 0.1.0.9 && < 0.2,+    haskell-names                     >= 0.9.1 && < 0.10.0,+    haskell-src-exts                  >= 1.19.1 && < 1.24.0,+    hformat                           >= 0.1.0.1 && < 0.4,+    http-client                    >= 0.5 && < 0.7,+    lens                              >= 4.14 && < 4.20,+    lifted-base                       >= 0.2.3.10 && < 0.3,+    mmorph                            >= 1.0.9 && < 1.2,+    monad-control                     >= 1.0.1.0 && < 1.1,+    monad-loops                       >= 0.4.3 && < 0.5,+    mtl                               >= 2.2.1 && < 2.3,+    network                           >= 2.8 && < 3.2,+    network-uri                      >= 2.6 && < 2.7,+    optparse-applicative              >= 0.12.1.0 && < 0.16,+    process                           >= 1.4.2.0 && < 1.7,+    regex-pcre-builtin                >= 0.94.4 && < 0.96,+    scientific                        >= 0.3.4.9 && < 0.4,+    simple-log                        >= 0.9.9 && < 0.10,+    sqlite-simple                     >= 0.4.13.0 && < 0.5,+    stm                               >= 2.4 && < 2.6,+    syb                               >= 0.6 && < 0.8,+    template-haskell                  >= 2.11.0 && < 2.17,+    text                              >= 1.2.2.2 && < 1.3,+    text-region                       >= 0.1.0.1 && < 0.4,+    time                              >= 1.6.0.1 && < 1.10,+    transformers                      >= 0.5.2.0 && < 0.6,+    transformers-base                 >= 0.4.4 && < 0.5,+    uniplate                          >= 1.6.12 && < 1.7,+    unordered-containers              >= 0.2.8.0 && < 0.3,+    vector                            >= 0.11.0.0 && < 0.13++executable hsdev+  main-is: hsdev.hs+  hs-source-dirs: tools+  default-language: Haskell2010+  ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4"++  build-depends:+    hsdev,+    base                              >= 4.9 && < 5,+    aeson                             >= 1.2.4.0 && < 1.6,+    aeson-pretty                      >= 0.8.2 && < 0.9,+    bytestring                        >= 0.10.8.1 && < 0.11,+    containers                        >= 0.5.7.1 && < 0.7,+    deepseq                           >= 1.4.2.0 && < 1.5,+    directory                         >= 1.2.6.2 && < 1.4,+    exceptions                        >= 0.8.3 && < 0.11,+    filepath                          >= 1.4.1.0 && < 1.5,+    monad-loops                       >= 0.4.3 && < 0.5,+    mtl                               >= 2.2.1 && < 2.3,+    network                           >= 2.8 && < 3.2,+    optparse-applicative              >= 0.12.1.0 && < 0.16,+    process                           >= 1.4.2.0 && < 1.7,+    text                              >= 1.2.2.2 && < 1.3,+    transformers                      >= 0.5.2.0 && < 0.6,+    unordered-containers              >= 0.2.8.0 && < 0.3++test-suite test+  main-is: Test.hs+  hs-source-dirs: tests+  default-language: Haskell2010+  ghc-options: -threaded -Wall -fno-warn-tabs+  type: exitcode-stdio-1.0+  build-depends:+    hsdev,+    base                              >= 4.9 && < 5,+    aeson                             >= 1.2.4.0 && < 1.6,+    lens-aeson                        >= 1.0 && < 1.2,+    async                             >= 2.1.1.1 && < 2.3,+    containers                        >= 0.5.7.1 && < 0.7,+    data-default                      >= 0.7.1.1 && < 0.8,+    deepseq                           >= 1.4.2.0 && < 1.5,+    directory                         >= 1.2.6.2 && < 1.4,+    filepath                          >= 1.4.1.0 && < 1.5,+    hformat                           >= 0.1.0.1 && < 0.4,+    hspec                             >= 2.2.4,+    lens                              >= 4.14 && < 4.20,+    mtl                               >= 2.2.1 && < 2.3,+    text                              >= 1.2.2.2 && < 1.3

@@ -1,9 +1,9 @@-module Control.Apply.Util (
-	(&), chain
-	) where
-
-(&) :: a -> (a -> b) -> b
-(&) = flip ($)
-
-chain :: [a -> a] -> a -> a
-chain = foldr (.) id
+module Control.Apply.Util (+	(&), chain+	) where++(&) :: a -> (a -> b) -> b+(&) = flip ($)++chain :: [a -> a] -> a -> a+chain = foldr (.) id

@@ -1,57 +1,57 @@-module Control.Concurrent.FiniteChan (
-	Chan,
-	newChan, openedChan, closedChan, doneChan, sendChan, getChan, closeChan, stopChan
-	) where
-
-import Control.Monad (void, when, liftM2)
-import Control.Monad.Loops
-import Control.Concurrent.STM
-
--- | 'Chan' is stoppable channel
-data Chan a = Chan {
-	chanOpened :: TMVar Bool,
-	chanQueue :: TQueue a }
-
--- -- | Create new channel
-newChan :: IO (Chan a)
-newChan = liftM2 Chan (newTMVarIO True) newTQueueIO
-
--- | Is channel opened
-openedChan :: Chan a -> IO Bool
-openedChan = atomically . readTMVar . chanOpened
-
--- | Is channel closed
-closedChan :: Chan a -> IO Bool
-closedChan = fmap not . openedChan
-
--- | Is channel closed and all data consumed
-doneChan :: Chan a -> IO Bool
-doneChan ch = atomically $ do
-	o <- readTMVar $ chanOpened ch
-	e <- isEmptyTQueue (chanQueue ch)
-	return $ not o && e
-
--- | Write data to channel if it is open
-sendChan :: Chan a -> a -> IO Bool
-sendChan ch v = atomically $ do
-	o <- readTMVar $ chanOpened ch
-	when o $ writeTQueue (chanQueue ch) v
-	return o
-
--- | Get data from channel
-getChan :: Chan a -> IO (Maybe a)
-getChan ch = atomically $ do
-	o <- readTMVar $ chanOpened ch
-	if o
-		then fmap Just (readTQueue (chanQueue ch))
-		else tryReadTQueue (chanQueue ch)
-
--- | Close channel
-closeChan :: Chan a -> IO ()
-closeChan ch = atomically $ void $ swapTMVar (chanOpened ch) False
-
--- | Close channel and read all messages
-stopChan :: Chan a -> IO [a]
-stopChan ch = do
-	closeChan ch
-	whileJust (getChan ch) return
+module Control.Concurrent.FiniteChan (+	Chan,+	newChan, openedChan, closedChan, doneChan, sendChan, getChan, closeChan, stopChan+	) where++import Control.Monad (void, when, liftM2)+import Control.Monad.Loops+import Control.Concurrent.STM++-- | 'Chan' is stoppable channel+data Chan a = Chan {+	chanOpened :: TMVar Bool,+	chanQueue :: TQueue a }++-- -- | Create new channel+newChan :: IO (Chan a)+newChan = liftM2 Chan (newTMVarIO True) newTQueueIO++-- | Is channel opened+openedChan :: Chan a -> IO Bool+openedChan = atomically . readTMVar . chanOpened++-- | Is channel closed+closedChan :: Chan a -> IO Bool+closedChan = fmap not . openedChan++-- | Is channel closed and all data consumed+doneChan :: Chan a -> IO Bool+doneChan ch = atomically $ do+	o <- readTMVar $ chanOpened ch+	e <- isEmptyTQueue (chanQueue ch)+	return $ not o && e++-- | Write data to channel if it is open+sendChan :: Chan a -> a -> IO Bool+sendChan ch v = atomically $ do+	o <- readTMVar $ chanOpened ch+	when o $ writeTQueue (chanQueue ch) v+	return o++-- | Get data from channel+getChan :: Chan a -> IO (Maybe a)+getChan ch = atomically $ do+	o <- readTMVar $ chanOpened ch+	if o+		then fmap Just (readTQueue (chanQueue ch))+		else tryReadTQueue (chanQueue ch)++-- | Close channel+closeChan :: Chan a -> IO ()+closeChan ch = atomically $ void $ swapTMVar (chanOpened ch) False++-- | Close channel and read all messages+stopChan :: Chan a -> IO [a]+stopChan ch = do+	closeChan ch+	whileJust (getChan ch) return

@@ -1,22 +1,22 @@-module Control.Concurrent.Util (
-	fork, timeout, sync
-	) where
-
-import Control.Concurrent
-import Control.Concurrent.Async
-import Control.Monad
-import Control.Monad.IO.Class
-
-fork :: MonadIO m => IO () -> m ()
-fork = liftIO . void . forkIO
-
-timeout :: Int -> IO a -> IO (Maybe a)
-timeout 0 act = liftM Just act
-timeout tm act = liftM (either Just (const Nothing)) $ race act (threadDelay tm)
-
-sync :: MonadIO m => (IO () -> m a) -> m a
-sync act = do
-	syncVar <- liftIO newEmptyMVar
-	r <- act $ putMVar syncVar ()
-	liftIO $ takeMVar syncVar
-	return r
+module Control.Concurrent.Util (+	fork, timeout, sync+	) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad+import Control.Monad.IO.Class++fork :: MonadIO m => IO () -> m ()+fork = liftIO . void . forkIO++timeout :: Int -> IO a -> IO (Maybe a)+timeout 0 act = liftM Just act+timeout tm act = liftM (either Just (const Nothing)) $ race act (threadDelay tm)++sync :: MonadIO m => (IO () -> m a) -> m a+sync act = do+	syncVar <- liftIO newEmptyMVar+	r <- act $ putMVar syncVar ()+	liftIO $ takeMVar syncVar+	return r

@@ -1,92 +1,92 @@-{-# LANGUAGE RankNTypes #-}
-
-module Control.Concurrent.Worker (
-	Worker(..), WorkerStopped(..),
-	startWorker, workerAlive, workerDone,
-	sendTask, stopWorker, joinWorker, syncTask,
-	inWorkerWith, inWorker,
-
-	module Control.Concurrent.Async
-	) where
-
-import Control.Concurrent.MVar
-import Control.Monad.IO.Class
-import Control.Monad.Catch
-import Control.Monad.Except
-import Data.Maybe (isNothing)
-import Data.Typeable
-
-import Control.Concurrent.FiniteChan
-import Control.Concurrent.Async
-
-data Worker m = Worker {
-	workerChan :: Chan (Async (), m ()),
-	workerTask :: MVar (Async ()) }
-
-data WorkerStopped = WorkerStopped deriving (Show, Typeable)
-
-instance Exception WorkerStopped
-
--- | Create new worker
-startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m)
-startWorker run initialize handleErrs = do
-	ch <- newChan
-	taskVar <- newEmptyMVar
-	let
-		job = onException (run $ initialize go) $ do
-			closeChan ch
-			abort
-		go = do
-			t <- fmap snd <$> liftIO (getChan ch)
-			maybe (return ()) (\f' -> handleErrs f' >> go) t
-		abort = do
-			a <- fmap fst <$> liftIO (getChan ch)
-			maybe (return ()) (\a' -> liftIO (cancel a') >> abort) a
-	async job >>= putMVar taskVar
-	return $ Worker ch taskVar
-
--- | Check whether worker alive
-workerAlive :: Worker m -> IO Bool
-workerAlive w = do
-	task <- readMVar $ workerTask w
-	isNothing <$> poll task
-
-workerDone :: Worker m -> IO Bool
-workerDone = doneChan . workerChan
-
-sendTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a)
-sendTask w act = mfix $ \async' -> do
-	var <- newEmptyMVar
-	let
-		act' = (act >>= liftIO . putMVar var . Right) `catch` onErr
-		onErr :: MonadIO m => SomeException -> m ()
-		onErr = liftIO . putMVar var . Left
-		f = do
-			p <- sendChan (workerChan w) (void async', void act')
-			unless p $ putMVar var (Left $ SomeException WorkerStopped)
-			r <- takeMVar var
-			either throwM return r
-	async f
-
--- | Close worker channel
-stopWorker :: Worker m -> IO ()
-stopWorker = closeChan . workerChan
-
--- | Stop worker and wait for it
-joinWorker :: Worker m -> IO ()
-joinWorker w = do
-	stopWorker w
-	async' <- readMVar $ workerTask w
-	void $ waitCatch async'
-
--- | Send empty task and wait until worker run it
-syncTask :: (MonadCatch m, MonadIO m) => Worker m -> IO ()
-syncTask w = sendTask w (return ()) >>= void . wait
-
--- | Run action in worker and wait for result
-inWorkerWith :: (MonadIO m, MonadCatch m, MonadIO n) => (SomeException -> n a) -> Worker m -> m a -> n a
-inWorkerWith err w act = liftIO (sendTask w act) >>= (liftIO . waitCatch >=> either err return)
-
--- | Run action in worker and wait for result
-inWorker :: (MonadIO m, MonadCatch m) => Worker m -> m a -> IO a
-inWorker w act = sendTask w act >>= liftIO . wait
+{-# LANGUAGE RankNTypes #-}++module Control.Concurrent.Worker (+	Worker(..), WorkerStopped(..),+	startWorker, workerAlive, workerDone,+	sendTask, stopWorker, joinWorker, syncTask,+	inWorkerWith, inWorker,++	module Control.Concurrent.Async+	) where++import Control.Concurrent.MVar+import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Monad.Except+import Data.Maybe (isNothing)+import Data.Typeable++import Control.Concurrent.FiniteChan+import Control.Concurrent.Async++data Worker m = Worker {+	workerChan :: Chan (Async (), m ()),+	workerTask :: MVar (Async ()) }++data WorkerStopped = WorkerStopped deriving (Show, Typeable)++instance Exception WorkerStopped++-- | Create new worker+startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m)+startWorker run initialize handleErrs = do+	ch <- newChan+	taskVar <- newEmptyMVar+	let+		job = onException (run $ initialize go) $ do+			closeChan ch+			abort+		go = do+			t <- fmap snd <$> liftIO (getChan ch)+			maybe (return ()) (\f' -> handleErrs f' >> go) t+		abort = do+			a <- fmap fst <$> liftIO (getChan ch)+			maybe (return ()) (\a' -> liftIO (cancel a') >> abort) a+	async job >>= putMVar taskVar+	return $ Worker ch taskVar++-- | Check whether worker alive+workerAlive :: Worker m -> IO Bool+workerAlive w = do+	task <- readMVar $ workerTask w+	isNothing <$> poll task++workerDone :: Worker m -> IO Bool+workerDone = doneChan . workerChan++sendTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a)+sendTask w act = mfix $ \async' -> do+	var <- newEmptyMVar+	let+		act' = (act >>= liftIO . putMVar var . Right) `catch` onErr+		onErr :: MonadIO m => SomeException -> m ()+		onErr = liftIO . putMVar var . Left+		f = do+			p <- sendChan (workerChan w) (void async', void act')+			unless p $ putMVar var (Left $ SomeException WorkerStopped)+			r <- takeMVar var+			either throwM return r+	async f++-- | Close worker channel+stopWorker :: Worker m -> IO ()+stopWorker = closeChan . workerChan++-- | Stop worker and wait for it+joinWorker :: Worker m -> IO ()+joinWorker w = do+	stopWorker w+	async' <- readMVar $ workerTask w+	void $ waitCatch async'++-- | Send empty task and wait until worker run it+syncTask :: (MonadCatch m, MonadIO m) => Worker m -> IO ()+syncTask w = sendTask w (return ()) >>= void . wait++-- | Run action in worker and wait for result+inWorkerWith :: (MonadIO m, MonadCatch m, MonadIO n) => (SomeException -> n a) -> Worker m -> m a -> n a+inWorkerWith err w act = liftIO (sendTask w act) >>= (liftIO . waitCatch >=> either err return)++-- | Run action in worker and wait for result+inWorker :: (MonadIO m, MonadCatch m) => Worker m -> m a -> IO a+inWorker w act = sendTask w act >>= liftIO . wait

@@ -1,105 +1,105 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
-
-module Data.Deps (
-	Deps(..), depsMap,
-	mapDeps,
-	dep, deps,
-	inverse,
-	DepsError(..), flatten,
-	selfDepend,
-	linearize
-	) where
-
-import Control.Lens
-import Control.Monad.State
-import Control.Monad.Except
-import Data.List (nub, intercalate)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.Semigroup
-import Data.Maybe (fromMaybe)
-
--- | Dependency map
-newtype Deps a = Deps {
-	_depsMap :: Map a [a] }
-
-depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b])
-depsMap = lens _depsMap (const Deps)
-
-instance Ord a => Semigroup (Deps a) where
-	Deps l <> Deps r = Deps $ M.unionWith nubConcat l r
-
-instance Ord a => Monoid (Deps a) where
-	mempty = Deps mempty
-	mappend (Deps l) (Deps r) = Deps $ M.unionWith nubConcat l r
-
-instance Show a => Show (Deps a) where
-	show (Deps ds) = unlines [show d ++ " -> " ++ intercalate ", " (map show s) | (d, s) <- M.toList ds]
-
-type instance Index (Deps a) = a
-type instance IxValue (Deps a) = [a]
-
-instance Ord a => Ixed (Deps a) where
-	ix k = depsMap . ix k
-
-instance Ord a => At (Deps a) where
-	at k = depsMap . at k
-
-mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b
-mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap
-
--- | Make single dependency
-dep :: a -> a -> Deps a
-dep x y = deps x [y]
-
--- | Make dependency for one target, note that order of dependencies is matter
-deps :: a -> [a] -> Deps a
-deps x ys = Deps $ M.singleton x ys
-
--- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it
-inverse :: Ord a => Deps a -> Deps a
-inverse = mconcat . map (uncurry dep) . concatMap inverse' . M.toList . _depsMap where
-	inverse' :: (a, [a]) -> [(a, a)]
-	inverse' (m, ds) = zip ds (repeat m)
-
-newtype DepsError a =
-	CyclicDeps [a]
-	-- ^ Dependency cycle, list is cycle, where last item depends on first
-		deriving (Eq, Ord, Read)
-
-instance Show a => Show (DepsError a) where
-	show (CyclicDeps c) = "dependencies forms a cycle: " ++ concat [show d ++ " -> " | d <- c] ++ "..."
-
--- | Flatten dependencies so that there will be no indirect dependencies
-flatten :: Ord a => Deps a -> Either (DepsError a) (Deps a)
-flatten s@(Deps ds) = fmap snd . flip execStateT mempty . mapM_ (flatten' s) . M.keys $ ds where
-	flatten' :: Ord a => Deps a -> a -> StateT ([a], Deps a) (Either (DepsError a)) [a]
-	flatten' s' n = do
-		path <- gets (view _1)
-		when (preview (reversed . each) path == Just n) $ throwError (CyclicDeps $ reverse path)
-		d <- gets (preview $ _2 . ix n)
-		case d of
-			Just d' -> return d'
-			Nothing -> pushPath n $ do
-				d'' <- (nub . concat . (++ [deps'])) <$> mapM (flatten' s') deps'
-				modify (over _2 $ mappend (deps n d''))
-				return d''
-				where
-					deps' = fromMaybe [] $ preview (ix n) s'
-	pushPath :: MonadState ([a], Deps a) m => a -> m b -> m b
-	pushPath p act = do
-		modify (over _1 (p:))
-		r <- act
-		modify (over _1 tail)
-		return r
-
-selfDepend :: Deps a -> Deps a
-selfDepend = Deps . M.mapWithKey (\s d -> d ++ [s]) . _depsMap
-
--- | Linearize dependencies so that all items can be processed in this order,
--- i.e. for each item all its dependencies goes before
-linearize :: Ord a => Deps a -> Either (DepsError a) [a]
-linearize = fmap (nub . concat . toListOf (depsMap . each) . selfDepend) . flatten
-
-nubConcat :: Ord a => [a] -> [a] -> [a]
-nubConcat xs ys = nub $ xs ++ ys
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}++module Data.Deps (+	Deps(..), depsMap,+	mapDeps,+	dep, deps,+	inverse,+	DepsError(..), flatten,+	selfDepend,+	linearize+	) where++import Control.Lens+import Control.Monad.State+import Control.Monad.Except+import Data.List (nub, intercalate)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Semigroup+import Data.Maybe (fromMaybe)++-- | Dependency map+newtype Deps a = Deps {+	_depsMap :: Map a [a] }++depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b])+depsMap = lens _depsMap (const Deps)++instance Ord a => Semigroup (Deps a) where+	Deps l <> Deps r = Deps $ M.unionWith nubConcat l r++instance Ord a => Monoid (Deps a) where+	mempty = Deps mempty+	mappend (Deps l) (Deps r) = Deps $ M.unionWith nubConcat l r++instance Show a => Show (Deps a) where+	show (Deps ds) = unlines [show d ++ " -> " ++ intercalate ", " (map show s) | (d, s) <- M.toList ds]++type instance Index (Deps a) = a+type instance IxValue (Deps a) = [a]++instance Ord a => Ixed (Deps a) where+	ix k = depsMap . ix k++instance Ord a => At (Deps a) where+	at k = depsMap . at k++mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b+mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap++-- | Make single dependency+dep :: a -> a -> Deps a+dep x y = deps x [y]++-- | Make dependency for one target, note that order of dependencies is matter+deps :: a -> [a] -> Deps a+deps x ys = Deps $ M.singleton x ys++-- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it+inverse :: Ord a => Deps a -> Deps a+inverse = mconcat . map (uncurry dep) . concatMap inverse' . M.toList . _depsMap where+	inverse' :: (a, [a]) -> [(a, a)]+	inverse' (m, ds) = zip ds (repeat m)++newtype DepsError a =+	CyclicDeps [a]+	-- ^ Dependency cycle, list is cycle, where last item depends on first+		deriving (Eq, Ord, Read)++instance Show a => Show (DepsError a) where+	show (CyclicDeps c) = "dependencies forms a cycle: " ++ concat [show d ++ " -> " | d <- c] ++ "..."++-- | Flatten dependencies so that there will be no indirect dependencies+flatten :: Ord a => Deps a -> Either (DepsError a) (Deps a)+flatten s@(Deps ds) = fmap snd . flip execStateT mempty . mapM_ (flatten' s) . M.keys $ ds where+	flatten' :: Ord a => Deps a -> a -> StateT ([a], Deps a) (Either (DepsError a)) [a]+	flatten' s' n = do+		path <- gets (view _1)+		when (preview (reversed . each) path == Just n) $ throwError (CyclicDeps $ reverse path)+		d <- gets (preview $ _2 . ix n)+		case d of+			Just d' -> return d'+			Nothing -> pushPath n $ do+				d'' <- (nub . concat . (++ [deps'])) <$> mapM (flatten' s') deps'+				modify (over _2 $ mappend (deps n d''))+				return d''+				where+					deps' = fromMaybe [] $ preview (ix n) s'+	pushPath :: MonadState ([a], Deps a) m => a -> m b -> m b+	pushPath p act = do+		modify (over _1 (p:))+		r <- act+		modify (over _1 tail)+		return r++selfDepend :: Deps a -> Deps a+selfDepend = Deps . M.mapWithKey (\s d -> d ++ [s]) . _depsMap++-- | Linearize dependencies so that all items can be processed in this order,+-- i.e. for each item all its dependencies goes before+linearize :: Ord a => Deps a -> Either (DepsError a) [a]+linearize = fmap (nub . concat . toListOf (depsMap . each) . selfDepend) . flatten++nubConcat :: Ord a => [a] -> [a] -> [a]+nubConcat xs ys = nub $ xs ++ ys

@@ -1,24 +1,24 @@-module Data.Help (
-	Help(..),
-	indent, indentHelp, detailed, indented
-	) where
-
-import Data.Text (Text)
-import qualified Data.Text as T
-
-class Help a where
-	brief :: a -> Text
-	help :: a -> [Text]
-
-indent :: Text -> Text
-indent = T.cons '\t'
-
-indentHelp :: [Text] -> [Text]
-indentHelp [] = []
-indentHelp (h:hs) = h : map indent hs
-
-detailed :: Help a => a -> [Text]
-detailed v = brief v : help v
-
-indented :: Help a => a -> [Text]
-indented = indentHelp . detailed
+module Data.Help (+	Help(..),+	indent, indentHelp, detailed, indented+	) where++import Data.Text (Text)+import qualified Data.Text as T++class Help a where+	brief :: a -> Text+	help :: a -> [Text]++indent :: Text -> Text+indent = T.cons '\t'++indentHelp :: [Text] -> [Text]+indentHelp [] = []+indentHelp (h:hs) = h : map indent hs++detailed :: Help a => a -> [Text]+detailed v = brief v : help v++indented :: Help a => a -> [Text]+indented = indentHelp . detailed

@@ -1,126 +1,126 @@-module Data.Lisp (
-	Lisp(..),
-	lisp,
-	encodeLisp, decodeLisp
-	) where
-
-import Prelude hiding (String, Bool)
-import qualified Prelude as P (String, Bool)
-
-import Data.Aeson (ToJSON(..), FromJSON(..), (.=))
-import qualified Data.Aeson as A
-import Data.Aeson.Types (parseMaybe, parseEither)
-import Data.ByteString.Lazy (ByteString)
-import Data.Char (isAlpha, isDigit)
-import Data.Either (partitionEithers)
-import qualified Data.HashMap.Strict as HM
-import Data.List (unfoldr)
-import Data.Scientific
-import Data.String (fromString)
-import qualified Data.Text as T (unpack)
-import qualified Data.Text.Lazy as LT (pack, unpack)
-import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8, decodeUtf8)
-import qualified Text.ParserCombinators.ReadP as R
-import Text.Read (readMaybe)
-import qualified Data.Vector as V
-
-data Lisp =
-	Null |
-	Bool P.Bool |
-	Symbol P.String |
-	String P.String |
-	Number Scientific |
-	List [Lisp]
-		deriving (Eq)
-
-readable :: Read a => Int -> R.ReadP a
-readable = R.readS_to_P . readsPrec
-
-lisp :: Int -> R.ReadP Lisp
-lisp n = R.choice [
-	do
-		s <- symbol
-		return $ case s of
-			"null" -> Null
-			"true" -> Bool True
-			"false" -> Bool False
-			_ -> Symbol s,
-	fmap String string,
-	fmap Number number,
-	fmap List list]
-	where
-		symbol :: R.ReadP P.String
-		symbol = concat <$> sequence [
-			R.option [] (pure <$> R.char ':'),
-			pure <$> R.satisfy isAlpha,
-			R.munch (\ch -> isAlpha ch || isDigit ch || ch == '-')]
-
-		string :: R.ReadP P.String
-		string = (R.<++ R.pfail) $ do
-			('\"':_) <- R.look
-			readable n
-
-		number :: R.ReadP Scientific
-		number = do
-			s <- R.munch1 (\ch -> isDigit ch || ch `elem` ['e', 'E', '.', '+', '-'])
-			maybe R.pfail return $ readMaybe s
-
-		list :: R.ReadP [Lisp]
-		list = R.between (R.char '(') (R.char ')') $ R.sepBy (lisp n) R.skipSpaces
-
-instance Read Lisp where
-	readsPrec = R.readP_to_S . lisp
-
-instance Show Lisp where
-	show Null = "null"
-	show (Bool b)
-		| b = "true"
-		| otherwise = "false"
-	show (Symbol s) = s
-	show (String s) = show s
-	show (Number n) = either show show (floatingOrInteger n :: Either Double Integer)
-	show (List vs) = "(" ++ unwords (map show vs) ++ ")"
-
-instance ToJSON Lisp where
-	toJSON Null = toJSON A.Null
-	toJSON (Bool b) = toJSON b
-	toJSON (Symbol s) = toJSON s
-	toJSON (String s) = toJSON s
-	toJSON (Number n) = toJSON n
-	toJSON (List vs)
-		| null keywords = toJSON $ map toJSON vals
-		| null vals = keywordsObject
-		| otherwise = toJSON $ map toJSON vals ++ [keywordsObject]
-		where
-			(vals, keywords) = partitionEithers $ unfoldr cutKeyword vs
-			keywordsObject = A.object [fromString (dropColon k) .= v | (k, v) <- keywords]
-
-			dropColon :: P.String -> P.String
-			dropColon (':' : s) = s
-			dropColon s = s
-
-			cutKeyword :: [Lisp] -> Maybe (Either Lisp (P.String, Lisp), [Lisp])
-			cutKeyword [] = Nothing
-			cutKeyword (Symbol s : []) = Just (Right (s, Null), [])
-			cutKeyword (Symbol s : Symbol h : hs) = Just (Right (s, Null), Symbol h : hs)
-			cutKeyword (Symbol s : h : hs) = Just (Right (s, h), hs)
-			cutKeyword (h : hs) = Just (Left h, hs)
-
-instance FromJSON Lisp where
-	parseJSON A.Null = return Null
-	parseJSON (A.Bool b) = return $ Bool b
-	parseJSON (A.String s) = return $ String $ T.unpack s
-	parseJSON (A.Number n) = return $ Number n
-	parseJSON (A.Array vs) = fmap List $ mapM parseJSON $ V.toList vs
-	parseJSON (A.Object obj) = fmap (List . concat) $ mapM (\(k, v) -> sequence [pure $ Symbol (':' : T.unpack k), parseJSON v]) $ HM.toList obj
-
-decodeLisp :: FromJSON a => ByteString -> Either P.String a
-decodeLisp str = do
-	sexp <- maybe (Left "Not a s-exp") Right . readMaybe . LT.unpack . LT.decodeUtf8 $ str
-	parseEither parseJSON $ toJSON (sexp :: Lisp)
-
-encodeLisp :: ToJSON a => a -> ByteString
-encodeLisp r = LT.encodeUtf8 . LT.pack $ maybe
-	"(:error \"can't convert to s-exp\")"
-	(show :: Lisp -> P.String)
-	(parseMaybe parseJSON (toJSON r))
+module Data.Lisp (+	Lisp(..),+	lisp,+	encodeLisp, decodeLisp+	) where++import Prelude hiding (String, Bool)+import qualified Prelude as P (String, Bool)++import Data.Aeson (ToJSON(..), FromJSON(..), (.=))+import qualified Data.Aeson as A+import Data.Aeson.Types (parseMaybe, parseEither)+import Data.ByteString.Lazy (ByteString)+import Data.Char (isAlpha, isDigit)+import Data.Either (partitionEithers)+import qualified Data.HashMap.Strict as HM+import Data.List (unfoldr)+import Data.Scientific+import Data.String (fromString)+import qualified Data.Text as T (unpack)+import qualified Data.Text.Lazy as LT (pack, unpack)+import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8, decodeUtf8)+import qualified Text.ParserCombinators.ReadP as R+import Text.Read (readMaybe)+import qualified Data.Vector as V++data Lisp =+	Null |+	Bool P.Bool |+	Symbol P.String |+	String P.String |+	Number Scientific |+	List [Lisp]+		deriving (Eq)++readable :: Read a => Int -> R.ReadP a+readable = R.readS_to_P . readsPrec++lisp :: Int -> R.ReadP Lisp+lisp n = R.choice [+	do+		s <- symbol+		return $ case s of+			"null" -> Null+			"true" -> Bool True+			"false" -> Bool False+			_ -> Symbol s,+	fmap String string,+	fmap Number number,+	fmap List list]+	where+		symbol :: R.ReadP P.String+		symbol = concat <$> sequence [+			R.option [] (pure <$> R.char ':'),+			pure <$> R.satisfy isAlpha,+			R.munch (\ch -> isAlpha ch || isDigit ch || ch == '-')]++		string :: R.ReadP P.String+		string = (R.<++ R.pfail) $ do+			('\"':_) <- R.look+			readable n++		number :: R.ReadP Scientific+		number = do+			s <- R.munch1 (\ch -> isDigit ch || ch `elem` ['e', 'E', '.', '+', '-'])+			maybe R.pfail return $ readMaybe s++		list :: R.ReadP [Lisp]+		list = R.between (R.char '(') (R.char ')') $ R.sepBy (lisp n) R.skipSpaces++instance Read Lisp where+	readsPrec = R.readP_to_S . lisp++instance Show Lisp where+	show Null = "null"+	show (Bool b)+		| b = "true"+		| otherwise = "false"+	show (Symbol s) = s+	show (String s) = show s+	show (Number n) = either show show (floatingOrInteger n :: Either Double Integer)+	show (List vs) = "(" ++ unwords (map show vs) ++ ")"++instance ToJSON Lisp where+	toJSON Null = toJSON A.Null+	toJSON (Bool b) = toJSON b+	toJSON (Symbol s) = toJSON s+	toJSON (String s) = toJSON s+	toJSON (Number n) = toJSON n+	toJSON (List vs)+		| null keywords = toJSON $ map toJSON vals+		| null vals = keywordsObject+		| otherwise = toJSON $ map toJSON vals ++ [keywordsObject]+		where+			(vals, keywords) = partitionEithers $ unfoldr cutKeyword vs+			keywordsObject = A.object [fromString (dropColon k) .= v | (k, v) <- keywords]++			dropColon :: P.String -> P.String+			dropColon (':' : s) = s+			dropColon s = s++			cutKeyword :: [Lisp] -> Maybe (Either Lisp (P.String, Lisp), [Lisp])+			cutKeyword [] = Nothing+			cutKeyword (Symbol s : []) = Just (Right (s, Null), [])+			cutKeyword (Symbol s : Symbol h : hs) = Just (Right (s, Null), Symbol h : hs)+			cutKeyword (Symbol s : h : hs) = Just (Right (s, h), hs)+			cutKeyword (h : hs) = Just (Left h, hs)++instance FromJSON Lisp where+	parseJSON A.Null = return Null+	parseJSON (A.Bool b) = return $ Bool b+	parseJSON (A.String s) = return $ String $ T.unpack s+	parseJSON (A.Number n) = return $ Number n+	parseJSON (A.Array vs) = fmap List $ mapM parseJSON $ V.toList vs+	parseJSON (A.Object obj) = fmap (List . concat) $ mapM (\(k, v) -> sequence [pure $ Symbol (':' : T.unpack k), parseJSON v]) $ HM.toList obj++decodeLisp :: FromJSON a => ByteString -> Either P.String a+decodeLisp str = do+	sexp <- maybe (Left "Not a s-exp") Right . readMaybe . LT.unpack . LT.decodeUtf8 $ str+	parseEither parseJSON $ toJSON (sexp :: Lisp)++encodeLisp :: ToJSON a => a -> ByteString+encodeLisp r = LT.encodeUtf8 . LT.pack $ maybe+	"(:error \"can't convert to s-exp\")"+	(show :: Lisp -> P.String)+	(parseMaybe parseJSON (toJSON r))

@@ -1,65 +1,65 @@-module Data.LookupTable (
-	LookupTable,
-	newLookupTable,
-	lookupTable, lookupTableM, cacheInTableM,
-	hasLookupTable,
-	cachedInTable,
-	insertTable, insertTableM, storeInTable, storeInTableM
-	) where
-
-import Control.Monad.IO.Class
-import Control.Concurrent.MVar
-import Data.Map (Map)
-import qualified Data.Map as M
-
--- | k-v table
-type LookupTable k v = MVar (Map k v)
-
-newLookupTable :: (Ord k, MonadIO m) => m (LookupTable k v)
-newLookupTable = liftIO $ newMVar mempty
-
--- | Lookup, or insert if not exists
-lookupTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v
-lookupTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> case M.lookup key tbl' of
-	Just value' -> return (tbl', value')
-	Nothing -> return (M.insert key value tbl', value)
-
--- | Lookup, or insert if not exists
-lookupTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v
-lookupTableM key mvalue tbl = do
-	mv <- hasLookupTable key tbl
-	case mv of
-		Just value -> return value
-		Nothing -> do
-			value <- mvalue
-			lookupTable key value tbl
-
--- | @lookupTableM@ with swapped args
-cacheInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v
-cacheInTableM tbl key mvalue = lookupTableM key mvalue tbl
-
--- | Just check existable
-hasLookupTable :: (Ord k, MonadIO m) => k -> LookupTable k v -> m (Maybe v)
-hasLookupTable key tbl = liftIO $ withMVar tbl $ return . M.lookup key
-
--- | Make function caching results in @LookupTable@
-cachedInTable :: (Ord k, MonadIO m) => LookupTable k v -> (k -> m v) -> k -> m v
-cachedInTable tbl fn key = cacheInTableM tbl key (fn key)
-
--- | Insert value into table and return it
-insertTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v
-insertTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> return (M.insert key value tbl', value)
-
--- | Insert value into table and return it
-insertTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v
-insertTableM key mvalue tbl = do
-	value <- mvalue
-	insertTable key value tbl
-
--- | @insertTable@ with flipped args
-storeInTable :: (Ord k, MonadIO m) => LookupTable k v -> k -> v -> m v
-storeInTable tbl key value = insertTable key value tbl
-
--- | @insertTable@ with flipped args
-storeInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v
-storeInTableM tbl key mvalue = insertTableM key mvalue tbl
+module Data.LookupTable (+	LookupTable,+	newLookupTable,+	lookupTable, lookupTableM, cacheInTableM,+	hasLookupTable,+	cachedInTable,+	insertTable, insertTableM, storeInTable, storeInTableM+	) where++import Control.Monad.IO.Class+import Control.Concurrent.MVar+import Data.Map (Map)+import qualified Data.Map as M++-- | k-v table+type LookupTable k v = MVar (Map k v)++newLookupTable :: (Ord k, MonadIO m) => m (LookupTable k v)+newLookupTable = liftIO $ newMVar mempty++-- | Lookup, or insert if not exists+lookupTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v+lookupTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> case M.lookup key tbl' of+	Just value' -> return (tbl', value')+	Nothing -> return (M.insert key value tbl', value)++-- | Lookup, or insert if not exists+lookupTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v+lookupTableM key mvalue tbl = do+	mv <- hasLookupTable key tbl+	case mv of+		Just value -> return value+		Nothing -> do+			value <- mvalue+			lookupTable key value tbl++-- | @lookupTableM@ with swapped args+cacheInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v+cacheInTableM tbl key mvalue = lookupTableM key mvalue tbl++-- | Just check existable+hasLookupTable :: (Ord k, MonadIO m) => k -> LookupTable k v -> m (Maybe v)+hasLookupTable key tbl = liftIO $ withMVar tbl $ return . M.lookup key++-- | Make function caching results in @LookupTable@+cachedInTable :: (Ord k, MonadIO m) => LookupTable k v -> (k -> m v) -> k -> m v+cachedInTable tbl fn key = cacheInTableM tbl key (fn key)++-- | Insert value into table and return it+insertTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v+insertTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> return (M.insert key value tbl', value)++-- | Insert value into table and return it+insertTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v+insertTableM key mvalue tbl = do+	value <- mvalue+	insertTable key value tbl++-- | @insertTable@ with flipped args+storeInTable :: (Ord k, MonadIO m) => LookupTable k v -> k -> v -> m v+storeInTable tbl key value = insertTable key value tbl++-- | @insertTable@ with flipped args+storeInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v+storeInTableM tbl key mvalue = insertTableM key mvalue tbl

@@ -1,19 +1,19 @@-module Data.Maybe.JustIf (
-	justIf,
-	whenJust, whenJustM
-	) where
-
-import Control.Monad
-
--- | Return @Just@ if True
-justIf :: a -> Bool -> Maybe a
-x `justIf` True = Just x
-_ `justIf` False = Nothing
-
--- | Calls function when value is @Just@
-whenJust :: Applicative m => Maybe a -> (a -> m b) -> m ()
-whenJust v fn = maybe (pure ()) (void . fn) v
-
--- | Calls function when monad returns @Just@
-whenJustM :: Monad m => m (Maybe a) -> (a -> m b) -> m ()
-whenJustM mv fn = mv >>= (`whenJust` fn)
+module Data.Maybe.JustIf (+	justIf,+	whenJust, whenJustM+	) where++import Control.Monad++-- | Return @Just@ if True+justIf :: a -> Bool -> Maybe a+x `justIf` True = Just x+_ `justIf` False = Nothing++-- | Calls function when value is @Just@+whenJust :: Applicative m => Maybe a -> (a -> m b) -> m ()+whenJust v fn = maybe (pure ()) (void . fn) v++-- | Calls function when monad returns @Just@+whenJustM :: Monad m => m (Maybe a) -> (a -> m b) -> m ()+whenJustM mv fn = mv >>= (`whenJust` fn)

@@ -1,31 +1,31 @@-module HsDev (
-	module Data.Default,
-	module System.Directory.Paths,
-
-	module HsDev.Types,
-	module HsDev.Error,
-	module HsDev.Server.Base,
-	module HsDev.Server.Commands,
-	module HsDev.Client.Commands,
-	module HsDev.Inspect,
-	module HsDev.Project,
-	module HsDev.Scan,
-	module HsDev.Symbols,
-	module HsDev.Symbols.Resolve,
-	module HsDev.Util
-	) where
-
-import Data.Default
-import System.Directory.Paths
-
-import HsDev.Types
-import HsDev.Error
-import HsDev.Server.Base
-import HsDev.Server.Commands
-import HsDev.Client.Commands
-import HsDev.Inspect
-import HsDev.Project
-import HsDev.Scan
-import HsDev.Symbols
-import HsDev.Symbols.Resolve
-import HsDev.Util
+module HsDev (+	module Data.Default,+	module System.Directory.Paths,++	module HsDev.Types,+	module HsDev.Error,+	module HsDev.Server.Base,+	module HsDev.Server.Commands,+	module HsDev.Client.Commands,+	module HsDev.Inspect,+	module HsDev.Project,+	module HsDev.Scan,+	module HsDev.Symbols,+	module HsDev.Symbols.Resolve,+	module HsDev.Util+	) where++import Data.Default+import System.Directory.Paths++import HsDev.Types+import HsDev.Error+import HsDev.Server.Base+import HsDev.Server.Commands+import HsDev.Client.Commands+import HsDev.Inspect+import HsDev.Project+import HsDev.Scan+import HsDev.Symbols+import HsDev.Symbols.Resolve+import HsDev.Util

@@ -1,715 +1,715 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeOperators, TypeApplications #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module HsDev.Client.Commands (
-	runClient, runCommand
-	) where
-
-import Control.Arrow (second)
-import Control.Concurrent.MVar
-import Control.Exception (displayException)
-import Control.Lens hiding ((.=), (<.>))
-import Control.Monad
-import Control.Monad.Morph
-import Control.Monad.Except
-import Control.Monad.Reader
-import qualified Control.Monad.State as State
-import Control.Monad.Catch (try, catch, bracket, SomeException(..))
-import Data.Aeson hiding (Result, Error)
-import Data.List
-import Data.Maybe
-import qualified Data.Map.Strict as M
-import Data.Text (Text, pack, unpack)
-import qualified Data.Text as T (append, null)
-import System.Directory
-import System.FilePath
-import qualified System.Log.Simple as Log
-import qualified System.Log.Simple.Base as Log
-import Text.Read (readMaybe)
-
-import Data.Maybe.JustIf
-import qualified System.Directory.Watcher as W
-import System.Directory.Paths
-import Text.Format
-import HsDev.Error
-import HsDev.Database.SQLite as SQLite
-import HsDev.Inspect (preload, asModule)
-import HsDev.Scan (upToDate, getFileContents)
-import HsDev.Server.Message as M
-import HsDev.Server.Types
-import HsDev.Sandbox hiding (findSandbox)
-import qualified HsDev.Sandbox as S (findSandbox)
-import HsDev.Symbols
-import qualified HsDev.Tools.AutoFix as AutoFix
-import qualified HsDev.Tools.Cabal as Cabal
-import HsDev.Tools.Ghc.Session
-import HsDev.Tools.Ghc.Worker (clearTargets)
-import qualified HsDev.Tools.Ghc.Compat as Compat
-import qualified HsDev.Tools.Ghc.Check as Check
-import qualified HsDev.Tools.Ghc.Types as Types
-import qualified HsDev.Tools.Hayoo as Hayoo
-import qualified HsDev.Tools.HDocs as HDocs
-import qualified HsDev.Tools.HLint as HLint
-import qualified HsDev.Tools.Types as Tools
-import HsDev.Util
-import HsDev.Watcher
-
-import qualified HsDev.Database.Update as Update
-
-runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result
-runClient copts = mapServerM toResult . runClientM where
-	toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result
-	toResult act = liftM errorToResult $ runReaderT (try (try act)) copts
-	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b
-	mapServerM f = ServerM . mapReaderT f . runServerM
-	errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result
-	errorToResult = either (Error . UnhandledError . displayException) (either Error (Result . toJSON))
-
-toValue :: (ToJSON a, Monad m) => m a -> m Value
-toValue = fmap toJSON
-
-runCommand :: ServerMonadBase m => Command -> ClientM m Value
-runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]
-runCommand (Listen (Just l)) = case Log.level (pack l) of
-	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
-	Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)
-runCommand (Listen Nothing) = toValue $ do
-	serverListen >>= mapM_ (commandNotify . Notification . toJSON)
-runCommand (SetLogLevel l) = case Log.level (pack l) of
-	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
-	Just lev -> toValue $ do
-		lev' <- serverSetLogLevel lev
-		Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev
-		Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev
-runCommand (Scan projs cabal sboxes fs paths' btool ghcs' docs' infer') = toValue $ do
-	sboxes' <- getSandboxes sboxes
-	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
-		[Update.scanCabal ghcs' | cabal],
-		map (Update.scanSandbox ghcs') sboxes',
-		[Update.scanFiles (zip fs (repeat ghcs'))],
-		map (Update.scanProject ghcs' btool) projs,
-		map (Update.scanDirectory ghcs') paths']
-runCommand (ScanProject proj tool deps) = toValue $ updateProcess def [
-	(if deps then Update.scanProjectStack else Update.scanProject) [] tool proj]
-runCommand (ScanFile fpath tool scanProj deps) = toValue $ updateProcess def [
-	Update.scanFile [] fpath tool scanProj deps]
-runCommand (ScanPackageDbs pdbs) = toValue $ updateProcess def [
-	Update.scanPackageDbStack [] pdbs]
-runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts
-runCommand (RefineDocs projs fs)
-	| HDocs.hdocsSupported = toValue $ updateProcess def $ return $ do
-		projects <- traverse findProject projs
-		projMods <- liftM concat $ forM projects $ \proj -> do
-			ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.docs') is null"
-				(Only $ proj ^. projectCabal)
-			p <- SQLite.loadProject (proj ^. projectCabal)
-			return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms
-		fileMods <- liftM concat $ forM fs $ \f ->
-			loadModules "select id from modules where file == ? and json_extract(tags, '$.docs') is null"
-				(Only f)
-		Update.scanDocs $ projMods ++ fileMods
-	| otherwise = hsdevError $ OtherError "docs not supported"
-runCommand (InferTypes projs fs) = toValue $ updateProcess def $ return $ do
-	projects <- traverse findProject projs
-	projMods <- liftM concat $ forM projects $ \proj -> do
-		ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.types') is null"
-			(Only $ proj ^. projectCabal)
-		p <- SQLite.loadProject (proj ^. projectCabal)
-		return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms
-	fileMods <- liftM concat $ forM fs $ \f ->
-		loadModules "select id from modules where file == ? and json_extract(tags, '$.types') is null"
-			(Only f)
-	Update.inferModTypes $ projMods ++ fileMods
-runCommand (Remove projs cabal sboxes files) = toValue $ withSqlConnection $ SQLite.transaction_ SQLite.Immediate $ do
-	let
-		-- We can safely remove package-db from db iff doesn't used by some of other package-dbs
-		-- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db
-		-- We also can't remove stack snapshot package-db if there are some local package-db not yet removed
-		canRemove pdbs = do
-			from' <- State.get
-			return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from'
-		-- Remove top of package-db stack if possible
-		removePackageDb' pdbs = do
-			can <- canRemove pdbs
-			when can $ do
-				State.modify (delete pdbs)
-				ms <- liftM (map fromOnly) $ query_
-					"select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;"
-				removePackageDb (topPackageDb pdbs)
-				mapM_ SQLite.removeModule ms
-				whenJustM (askSession sessionWatcher) $ \w ->
-					liftIO $ unwatchPackageDb w $ topPackageDb pdbs
-		-- Remove package-db stack when possible
-		removePackageDbStack = mapM_ removePackageDb' . packageDbStacks
-	projects <- traverse findProject projs
-	sboxes' <- getSandboxes sboxes
-	forM_ projects $ \proj -> do
-		ms <- liftM (map fromOnly) $ query "select id from modules where cabal == ?;" (Only $ proj ^. projectCabal)
-		SQLite.removeProject proj
-		mapM_ SQLite.removeModule ms
-		whenJustM (askSession sessionWatcher) $ \w ->
-			liftIO $ unwatchProject w proj
-
-	allPdbs <- liftM (map fromOnly) $ query_ @(Only PackageDb) "select package_db from package_dbs;"
-	dbPDbs <- inSessionGhc $ mapM restorePackageDbStack allPdbs
-	flip State.evalStateT dbPDbs $ do
-		when cabal $ removePackageDbStack userDb
-		forM_ sboxes' $ \sbox -> do
-			pdbs <- lift $ inSessionGhc $ sandboxPackageDbStack sbox
-			removePackageDbStack pdbs
-
-	forM_ files $ \file -> do
-		ms <- query @_ @(ModuleId :. Only Int)
-			(toQuery $ mconcat [
-				qModuleId,
-				select_ ["mu.id"],
-				where_ ["mu.file == ?"]])
-			(Only file)
-		forM_ ms $ \(m :. Only i) -> do
-			SQLite.removeModule i
-			whenJustM (askSession sessionWatcher) $ \w ->
-				liftIO . unwatchModule w $ (m ^. moduleLocation)
-runCommand RemoveAll = toValue $ do
-	SQLite.purge
-	whenJustM (askSession sessionWatcher) $ \w -> do
-		wdirs <- liftIO $ readMVar (W.watcherDirs w)
-		liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir
-runCommand InfoPackages = toValue $
-	query_ @ModulePackage "select package_name, package_version from package_dbs;"
-runCommand InfoProjects = toValue $ do
-	ps <- query_ @(Only Path) "select cabal from projects;"
-	mapM (SQLite.loadProject . fromOnly) ps
-runCommand InfoSandboxes = toValue $ do
-	rs <- query_ @(Only PackageDb) "select distinct package_db from package_dbs;"
-	return [pdb | Only pdb <- rs]
-runCommand (InfoSymbol sq filters True _) = toValue $ do
-	let
-		(conds, params) = targetFilters "m" (Just "s") filters
-	queryNamed @SymbolId
-		(toQuery $ mconcat [
-			qSymbolId,
-			where_ ["s.name like :pattern escape '\\'"],
-			where_ conds])
-		([":pattern" := likePattern sq] ++ params)
-runCommand (InfoSymbol sq filters False _) = toValue $ do
-	let
-		(conds, params) = targetFilters "m" (Just "s") filters
-	queryNamed @Symbol
-		(toQuery $ mconcat [
-			qSymbol,
-			where_ ["s.name like :pattern escape '\\'"],
-			where_ conds])
-		([":pattern" := likePattern sq] ++ params)
-runCommand (InfoModule sq filters h _) = toValue $ do
-	let
-		(conds, params) = targetFilters "mu" Nothing filters
-	rs <- queryNamed @(Only Int :. ModuleId)
-		(toQuery $ mconcat [
-			select_ ["mu.id"],
-			qModuleId,
-			where_ ["mu.name like :pattern escape '\\'"],
-			where_ conds])
-		([":pattern" := likePattern sq] ++ params)
-	if h
-		then return (toJSON $ map (\(_ :. m) -> m) rs)
-		else liftM toJSON $ forM rs $ \(Only mid :. mheader) -> do
-			[(docs, fixities)] <- query @_ @(Maybe Text, Maybe Value) "select m.docs, m.fixities from modules as m where (m.id == ?);"
-				(Only mid)
-			let
-				fixities' = fromMaybe [] (fixities >>= fromJSON')
-			imports' <- query @_ @Import (toQuery $ mconcat [
-				qImport "i",
-				where_ ["i.module_id = ?"]])
-				(Only mid)
-			exports' <- query @_ @Symbol (toQuery $ mconcat [
-				qSymbol,
-				from_ ["exports as e"],
-				where_ ["e.module_id == ?", "e.symbol_id == s.id"]])
-				(Only mid)
-			return $ Module mheader docs imports' exports' fixities' mempty Nothing
-runCommand (InfoProject (Left projName)) = toValue $ findProject projName
-runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject (view path projPath)
-runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandboxes sandbox'
-runCommand (Lookup nm fpath) = toValue $
-	fmap (map (\(s :. m) -> ImportedSymbol s m)) $ query @_ @(Symbol :. ModuleId) (toQuery $ mconcat [
-		qSymbol,
-		qModuleId,
-		from_ ["projects_modules_scope as pms", "modules as srcm", "exports as e"],
-		where_ [
-			"pms.cabal is srcm.cabal",
-			"srcm.file = ?",
-			"pms.module_id = e.module_id",
-			"m.id = s.module_id",
-			"s.id = e.symbol_id",
-			"e.module_id = mu.id",
-			"s.name = ?"]])
-		(fpath ^. path, nm)
-runCommand (Whois nm fpath) = toValue $ do
-	let
-		q = nameModule $ toName nm
-		ident = nameIdent $ toName nm
-	query @_ @Symbol (toQuery $ mconcat [
-		qSymbol,
-		from_ ["modules as srcm", "scopes as sc"],
-		where_ [
-			"srcm.id == sc.module_id",
-			"s.id == sc.symbol_id",
-			"srcm.file == ?",
-			"sc.qualifier is ?",
-			"sc.name == ?"]])
-		(fpath ^. path, q, ident)
-runCommand (Whoat l c fpath) = toValue $ do
-	rs <- query @_ @Symbol (toQuery $ mconcat [
-		qSymbol,
-		from_ ["names as n", "modules as srcm"],
-		where_ [
-			"srcm.id == n.module_id",
-			"m.name == n.resolved_module",
-			"s.name == n.resolved_name",
-			"s.what == n.resolved_what",
-			"s.id == n.symbol_id",
-			"srcm.file == ?",
-			"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])
-		(fpath ^. path, l, c)
-	locals <- do
-		defs <- query @_ @(ModuleId :. (Text, Int, Int, Maybe Text)) (toQuery $ mconcat [
-			qModuleId,
-			select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type"],
-			from_ ["names as n"],
-			where_ [
-				"mu.id == n.module_id",
-				"n.def_line is not null",
-				"n.def_column is not null",
-				"mu.file == ?",
-				"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])
-			(fpath ^. path, l, c)
-		return [
-			Symbol {
-				_symbolId = SymbolId nm mid,
-				_symbolDocs = Nothing,
-				_symbolPosition = Just (Position defLine defColumn),
-				_symbolInfo = Function ftype
-			} | (mid :. (nm, defLine, defColumn, ftype)) <- defs]
-	return $ rs ++ locals
-runCommand (ResolveScopeModules sq fpath) = toValue $ do
-	pids <- query @_ @(Only (Maybe Path)) "select m.cabal from modules as m where (m.file == ?);"
-		(Only $ fpath ^. path)
-	case pids of
-		[] -> hsdevError $ OtherError $ "module at {} not found" ~~ fpath
-		[Only proj] -> query @_ @ModuleId (toQuery $ mconcat [
-			qModuleId,
-			from_ ["projects_modules_scope as msc"],
-			where_ [
-				"msc.module_id == mu.id",
-				"msc.cabal is ?",
-				"mu.name like ? escape '\\'"]])
-			(proj, likePattern sq)
-		_ -> fail "Impossible happened: several projects for one module"
-runCommand (ResolveScope sq fpath) = toValue $
-	query @_ @(Scoped SymbolId) (toQuery $ mconcat [
-		qSymbolId,
-		select_ ["sc.qualifier"],
-		from_ ["scopes as sc", "modules as srcm"],
-		where_ [
-			"srcm.id == sc.module_id",
-			"sc.symbol_id == s.id",
-			"srcm.file == ?",
-			"s.name like ? escape '\\'"]])
-		(fpath ^. path, likePattern sq)
-runCommand (FindUsages l c fpath) = toValue $ do
-	us <- do
-		sids <- query @_ @(Only (Maybe Int)) (toQuery $ mconcat [
-			select_ ["n.symbol_id"],
-			from_ ["names as n", "modules as srcm"],
-			where_ [
-				"n.module_id == srcm.id",
-				"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)",
-				"srcm.file = ?"]])
-			(l, c, fpath)
-		when (length sids > 1) $ Log.sendLog Log.Warning $ "multiple symbols found at location {0}:{1}:{2}" ~~ fpath ~~ l ~~ c
-		let
-			msid = join $ fmap fromOnly $ listToMaybe sids
-		query @_ @SymbolUsage (toQuery $ mconcat [
-			qSymbol,
-			select_ ["n.qualifier"],
-			qModuleId,
-			select_ ["n.line", "n.column", "n.line_to", "n.column_to"],
-			from_ ["names as n"],
-			where_ [
-				"n.symbol_id == ?",
-				"s.id == n.symbol_id",
-				"mu.id == n.module_id"]])
-			(Only msid)
-	locals <- do
-		defs <- query @_ @(ModuleId :. Only Text :. Position :. Only (Maybe Text) :. Region) (toQuery $ mconcat [
-			qModuleId,
-			select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type", "n.line", "n.column", "n.line_to", "n.column_to"],
-			from_ ["names as n", "names as defn"],
-			where_ [
-				"n.module_id = mu.id",
-				"n.def_line = defn.def_line",
-				"n.def_column = defn.def_column",
-				"defn.module_id = mu.id",
-				"(?, ?) between (defn.line, defn.column) and (defn.line_to, defn.column_to)",
-				"mu.file = ?"]])
-			(l, c, fpath ^. path)
-		return $ do
-			(mid :. Only nm :. defPos :. Only ftype :. useRgn) <- defs
-			let
-				sym = Symbol {
-					_symbolId = SymbolId nm mid,
-					_symbolDocs = Nothing,
-					_symbolPosition = Just defPos,
-					_symbolInfo = Function ftype }
-			return $ SymbolUsage sym Nothing mid useRgn
-	return $ us ++ locals
-runCommand (Complete input True fpath) = toValue $
-	query @_ @Symbol (toQuery $ mconcat [
-		qSymbol,
-		from_ ["modules as srcm", "exports as e"],
-		where_ [
-			"e.module_id in (select srcm.id union select module_id from projects_modules_scope where (((cabal is null) and (srcm.cabal is null)) or (cabal == srcm.cabal)))",
-			"s.id == e.symbol_id",
-			"msrc.file == ?",
-			"s.name like ? escape '\\'"]])
-		(fpath ^. path, likePattern (SearchQuery input SearchPrefix))
-runCommand (Complete input False fpath) = toValue $
-	query @_ @(Scoped Symbol) (toQuery $ mconcat [
-		qSymbol,
-		select_ ["c.qualifier"],
-		from_ ["completions as c", "modules as srcm"],
-		where_ [
-			"c.module_id == srcm.id",
-			"c.symbol_id == s.id",
-			"srcm.file == ?",
-			"c.completion like ? escape '\\'"]])
-		(fpath ^. path, likePattern (SearchQuery input SearchPrefix))
-runCommand (Hayoo hq p ps) = do
-	m <- askSession sessionHTTPManager
-	toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
-		(mapMaybe Hayoo.hayooAsSymbol . Hayoo.resultResult) $
-		liftIO $ hsdevLift $ Hayoo.hayoo m hq (Just i)
-runCommand (CabalList packages') = toValue $ liftIO $ hsdevLift $ Cabal.cabalList $ map unpack packages'
-runCommand (UnresolvedSymbols fs) = toValue $ liftM concat $ forM fs $ \f -> do
-	rs <- query @_ @(Maybe String, String, Int, Int) "select n.qualifier, n.name, n.line, n.column from modules as m, names as n where (m.id == n.module_id) and (m.file == ?) and (n.resolve_error is not null);"
-		(Only $ f ^. path)
-	return $ map (\(m, nm, line, column) -> object [
-		"qualifier" .= m,
-		"name" .= nm,
-		"line" .= line,
-		"column" .= column]) rs
-runCommand (Lint fs lints) = toValue $ liftM concat $ forM fs $ \fsrc -> do
-	FileSource f c <- getUpdateFileContents fsrc
-	liftIO $ hsdevLift $ HLint.hlint lints (view path f) c
-runCommand (Check fs ghcs' clear) = toValue $ Log.scope "check" $
-	liftM concat $ mapM (runCheck ghcs' clear) fs
-runCommand (CheckLint fs ghcs' lints clear) = toValue $ do
-	fs' <- mapM getUpdateFileContents fs
-	checkMsgs <- liftM concat $ mapM (runCheck ghcs' clear) fs'
-	lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint lints (view path f) c) fs'
-	return $ checkMsgs ++ lintMsgs
-runCommand (Types fs ghcs' clear) = toValue $ do
-	liftM concat $ forM fs $ \fsrc@(FileSource file msrc) -> do
-		mcached' <- getCached file msrc
-		FileSource _ msrc' <- getUpdateFileContents fsrc
-		maybe (updateTypes file msrc') return mcached'
-	where
-		getCached :: ServerMonadBase m => Path -> Maybe Text -> ClientM m (Maybe [Tools.Note Types.TypedExpr])
-		getCached _ (Just _) = return Nothing
-		getCached file' Nothing = do
-			actual' <- sourceUpToDate file'
-			mid <- query @_ @((Bool, Int) :. ModuleId)
-				(toQuery $ mconcat [
-					select_ ["json_extract(tags, '$.types') is 1", "mu.id"],
-					qModuleId,
-					where_ ["mu.file = ?"]])
-				(Only file')
-			when (length mid > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ file'
-			when (null mid) $ hsdevError $ NotInspected $ FileModule file' Nothing
-			let
-				[(hasTypes', mid') :. modId] = mid
-			if actual' && hasTypes'
-				then do
-					types' <- query @_ @(Region :. Types.TypedExpr) "select line, column, line_to, column_to, expr, type from types where module_id = ?;" (Only mid')
-					liftM Just $ forM types' $ \(rgn :. texpr) -> return Tools.Note {
-						Tools._noteSource = modId ^. moduleLocation,
-						Tools._noteRegion = rgn,
-						Tools._noteLevel = Nothing,
-						Tools._note = set Types.typedExpr Nothing texpr }
-				else return Nothing
-
-		updateTypes file msrc = do
-			sess <- getSession
-			m <- setFileSourceSession ghcs' file
-			types' <- inSessionGhc $ do
-				when clear clearTargets
-				Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $
-					Types.fileTypes m msrc
-			updateProcess def [Update.setModTypes (m ^. moduleId) types']
-			return $ set (each . Tools.note . Types.typedExpr) Nothing types'
-runCommand (AutoFix ns) = toValue $ return $ AutoFix.corrections ns
-runCommand (Refactor ns rest isPure) = toValue $ do
-	files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns
-	let
-		runFix file = do
-			unless isPure $ do
-				liftIO $ readFileUtf8 (view path file) >>= writeFileUtf8 (view path file) . AutoFix.refact fixRefacts'
-			return newCorrs'
-			where
-				findCorrs :: Path -> [Tools.Note AutoFix.Refact] -> [Tools.Note AutoFix.Refact]
-				findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))
-				fixCorrs' = findCorrs file ns
-				upCorrs' = findCorrs file rest
-				fixRefacts' = fixCorrs' ^.. each . Tools.note
-				newCorrs' = AutoFix.update fixRefacts' upCorrs'
-	liftM concat $ mapM runFix files
-runCommand (Rename nm newName mloc fpath) = toValue $ do
-	m <- refineSourceModule fpath
-	let
-		mname = m ^. moduleId . moduleName
-		makeNote loc r = Tools.Note {
-			Tools._noteSource = loc,
-			Tools._noteRegion = r,
-			Tools._noteLevel = Nothing,
-			Tools._note = AutoFix.Refact "rename" (AutoFix.replace (AutoFix.fromRegion r) newName) }
-
-	msum [
-		do
-			topRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and ((n.def_line is not null and n.def_column is not null) or (n.def_line == ? and n.def_column == ?)) and n.symbol_id is not null;" (
-				mname,
-				nm,
-				fmap fst mloc,
-				fmap snd mloc)
-			guard (not $ null topRegions)
-			let
-				defRenames = map (makeNote (m ^. moduleId . moduleLocation)) topRegions
-			usageRenames <- do
-				usageRegions <- query @_ @(Only Path :. Region) "select m.file, n.line, n.column, n.line_to, n.column_to from names as n, modules as m where n.module_id == m.id and m.file is not null and n.resolved_module == ? and n.resolved_name == ?;" (
-					mname,
-					nm)
-				return $ map (\(Only p :. r) -> makeNote (FileModule p Nothing) r) usageRegions
-			return $ ordNub (defRenames ++ usageRenames),
-		do
-			localRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and n.def_line == ? and n.def_column == ? and n.symbol_id is null;" (
-				mname,
-				nm,
-				fmap fst mloc,
-				fmap snd mloc)
-			return $ map (makeNote (m ^. moduleId . moduleLocation)) localRegions]
-runCommand (GhcEval exprs mfile) = toValue $ do
-	mfile' <- traverse getUpdateFileContents mfile
-	case mfile' of
-		Nothing -> inSessionGhc ghciSession
-		Just (FileSource f mcts) -> do
-			m <- setFileSourceSession [] f
-			inSessionGhc $ interpretModule m mcts
-	inSessionGhc $ mapM (tryRepl . evaluate) exprs
-runCommand (GhcType exprs mfile) = toValue $ do
-	mfile' <- traverse getUpdateFileContents mfile
-	case mfile' of
-		Nothing -> inSessionGhc ghciSession
-		Just (FileSource f mcts) -> do
-			m <- setFileSourceSession [] f
-			inSessionGhc $ interpretModule m mcts
-	inSessionGhc $ mapM (tryRepl . expressionType) exprs
-runCommand Langs = toValue $ return Compat.languages
-runCommand Flags = toValue $ return ["-f" ++ prefix ++ f |
-	f <- Compat.flags,
-	prefix <- ["", "no-"]]
-runCommand (Link hold) = toValue $ commandLink >> when hold commandHold
-runCommand StopGhc = toValue $ do
-	inSessionGhc $ do
-		ms <- findSessionBy (const True)
-		forM_ ms $ \s -> do
-			Log.sendLog Log.Trace $ "stopping session: {}" ~~ view sessionKey s
-			deleteSession $ view sessionKey s
-runCommand Exit = toValue serverExit
-
-
-targetFilter :: Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam])
-targetFilter mtable _ (TargetProject proj) = (
-	"{t}.cabal in (select cabal from projects where name == :project or cabal == :project)" ~~ ("t" ~% mtable),
-	[":project" := proj])
-targetFilter mtable _ (TargetFile f) = ("{t}.file == :file" ~~ ("t" ~% mtable), [":file" := f])
-targetFilter mtable Nothing (TargetModule nm) = ("{t}.name == :module_name" ~~ ("t" ~% mtable), [":module_name" := nm])
-targetFilter mtable (Just stable) (TargetModule nm) = (
-	"({t}.name == :module_name) or ({s}.id in (select e.symbol_id from exports as e, modules as em where e.module_id == em.id and em.name == :module_name))"
-		~~ ("t" ~% mtable)
-		~~ ("s" ~% stable),
-	[":module_name" := nm])
-targetFilter mtable _ (TargetPackage p) = (tpl ~~ ("t" ~% mtable), params) where
-	pkg = fromMaybe (mkPackage p) (readMaybe (unpack p))
-	tpl
-		| T.null (pkg ^. packageVersion) = "{t}.package_name == :package_name"
-		| otherwise = "{t}.package_name == :package_name and {t}.package_version == :package_version"
-	params
-		| T.null (pkg ^. packageVersion) = [pname]
-		| otherwise = [pname, pver]
-	pname = ":package_name" := (pkg ^. packageName)
-	pver = ":package_version" := (pkg ^. packageVersion)
-targetFilter mtable _ TargetInstalled = ("{t}.package_name is not null" ~~ ("t" ~% mtable), [])
-targetFilter mtable _ TargetSourced = ("{t}.file is not null" ~~ ("t" ~% mtable), [])
-targetFilter mtable _ TargetStandalone = ("{t}.file is not null and {t}.cabal is null" ~~ ("t" ~% mtable), [])
-
-targetFilters :: Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])
-targetFilters mtable stable = second concat . unzip . map (targetFilter mtable stable)
-
-likePattern :: SearchQuery -> Text
-likePattern (SearchQuery input stype) = case stype of
-	SearchExact -> escapedInput
-	SearchPrefix -> escapedInput `T.append` "%"
-	SearchInfix -> "%" `T.append` escapedInput `T.append` "%"
-	SearchSuffix -> "%" `T.append` escapedInput
-	where
-		escapedInput = escapeLike input
-
-instance ToJSON Log.Message where
-	toJSON m = object [
-		"time" .= Log.messageTime m,
-		"level" .= show (Log.messageLevel m),
-		"component" .= show (Log.messageComponent m),
-		"scope" .= show (Log.messageScope m),
-		"text" .= Log.messageText m]
-
-instance FromJSON Log.Message where
-	parseJSON = withObject "log-message" $ \v -> Log.Message <$>
-		(v .:: "time") <*>
-		((v .:: "level") >>= maybe (fail "invalid level") return . readMaybe) <*>
-		(read <$> (v .:: "component")) <*>
-		(read <$> (v .:: "scope")) <*>
-		(v .:: "text")
-
-
--- | Run check
-runCheck :: CommandMonad m => [String] -> Bool -> FileSource -> m [Tools.Note Tools.OutputMessage]
-runCheck ghcs' clear = getUpdateFileContents >=> check' where
-	check' (FileSource file mcts) = Log.scope "run-check" $ do
-		Log.sendLog Log.Trace $ "setting file source session for {}" ~~ file
-		sess <- getSession
-		m <- setFileSourceSession ghcs' file
-		Log.sendLog Log.Trace "file source session set"
-		ns <- inSessionGhc $ do
-			when clear clearTargets
-			Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $
-				Check.check m mcts
-		if null ns
-			then do
-				inSessionUpdater $ return () -- wait until cache updated
-				ns' <- Update.cachedWarnings [m ^. moduleId . moduleLocation]
-				unless (null ns') $
-					Log.sendLog Log.Trace $ "returning {} cached warnings for {}" ~~ length ns' ~~ file
-				return ns'
-			else return ns
-
--- Helper functions
-
--- | Canonicalize paths
-findPath :: (CommandMonad m, Paths a) => a -> m a
-findPath = paths findPath' where
-	findPath' :: CommandMonad m => FilePath -> m FilePath
-	findPath' f = do
-		r <- commandRoot
-		liftIO $ canonicalizePath (normalise $ if isRelative f then r </> f else f)
-
--- | Find sandbox by path
-findSandbox :: CommandMonad m => Path -> m Sandbox
-findSandbox fpath = do
-	fpath' <- findPath fpath
-	sbox <- liftIO $ S.findSandbox fpath'
-	maybe (hsdevError $ FileNotFound fpath') return sbox
-
--- | Check if source file up to date
-sourceUpToDate :: CommandMonad m => Path -> m Bool
-sourceUpToDate fpath = do
-	fpath' <- findPath fpath
-	insps <- query @_ @Inspection "select inspection_time, inspection_opts from modules where file = ?;" (Only fpath')
-	when (length insps > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'
-	maybe
-		(return False)
-		(upToDate (FileModule fpath' Nothing) [])
-		(listToMaybe insps)
-
--- | Get source file
--- refineSourceFile :: CommandMonad m => Path -> m Path
--- refineSourceFile fpath = do
--- 	fpath' <- findPath fpath
--- 	fs <- liftM (map fromOnly) $ query "select file from modules where file == ?;" (Only fpath')
--- 	case fs of
--- 		[] -> hsdevError (NotInspected $ FileModule fpath' Nothing)
--- 		(f:_) -> do
--- 			when (length fs > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'
--- 			return f
-
--- | Get module by source
-refineSourceModule :: CommandMonad m => Path -> m Module
-refineSourceModule fpath = do
-	fpath' <- findPath fpath
-	ids <- query "select id, cabal from modules where file == ?;" (Only fpath')
-	case ids of
-		[] -> hsdevError (NotInspected $ FileModule fpath' Nothing)
-		((i, mcabal):_) -> do
-			when (length ids > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'
-			m <- SQLite.loadModule i
-			case mcabal of
-				Nothing -> do
-					[insp] <- query @_ @Inspection "select inspection_time, inspection_opts from modules where id = ?;" (Only i)
-					fresh' <- upToDate (m ^. moduleId . moduleLocation) [] insp
-					if fresh'
-						then return m
-						else do
-							defs <- askSession sessionDefines
-							mcts <- fmap (fmap snd) $ getFileContents fpath'
-							ip' <- runInspect (m ^. moduleId . moduleLocation) $ preload (m ^. moduleId . moduleName) defs [] mcts
-							case ip' ^? inspected of
-								Just p' -> return $ set moduleImports (p' ^. asModule . moduleImports) m
-								Nothing -> return m
-				Just cabal' -> do
-					proj' <- SQLite.loadProject cabal'
-					return $ set (moduleId . moduleLocation . moduleProject) (Just proj') m
-
--- | Get update file contents
-getUpdateFileContents :: CommandMonad m => FileSource -> m FileSource
-getUpdateFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath)
-getUpdateFileContents fcts@(FileSource fpath mcts) = do
-	serverSetFileContents fpath mcts
-	return fcts
-
--- | Set session by source
-setFileSourceSession :: CommandMonad m => [String] -> Path -> m Module
-setFileSourceSession opts fpath = do
-	m <- refineSourceModule fpath
-	inSessionGhc $ targetSession opts m
-	return m
-
--- | Ensure package exists
--- refinePackage :: CommandMonad m => Text -> m Text
--- refinePackage pkg = do
--- 	[(Only exists)] <- query "select count(*) > 0 from package_dbs where package_name == ?;" (Only pkg)
--- 	when (not exists) $ hsdevError (PackageNotFound pkg)
--- 	return pkg
-
--- | Get list of enumerated sandboxes
-getSandboxes :: CommandMonad m => [Path] -> m [Sandbox]
-getSandboxes = traverse (findPath >=> findSandbox)
-
--- | Find project by name or path
-findProject :: CommandMonad m => Text -> m Project
-findProject proj = do
-	proj' <- liftM addCabal $ findPath proj
-	ps <- liftM (map fromOnly) $ query "select cabal from projects where (cabal == ?) or (name == ?);" (view path proj', proj)
-	case ps of
-		[] -> hsdevError $ ProjectNotFound proj
-		_ -> SQLite.loadProject (head ps)
-	where
-		addCabal p
-			| takeExtension (view path p) == ".cabal" = p
-			| otherwise = over path (\p' -> p' </> (takeBaseName p' <.> "cabal")) p
-
--- | Run DB update action
-updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM IO ()] -> ClientM m ()
-updateProcess uopts acts = hoist liftIO $ do
-	copts <- getOptions
-	inSessionUpdater $ hoist (flip runReaderT copts) $ runClientM $ mapM_ (Update.runUpdate uopts . runAct) acts
-	where
-		runAct act = catch act onError
-		onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError)
+{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeOperators, TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module HsDev.Client.Commands (+	runClient, runCommand+	) where++import Control.Arrow (second)+import Control.Concurrent.MVar+import Control.Exception (displayException)+import Control.Lens hiding ((.=), (<.>))+import Control.Monad+import Control.Monad.Morph+import Control.Monad.Except+import Control.Monad.Reader+import qualified Control.Monad.State as State+import Control.Monad.Catch (try, catch, bracket, SomeException(..))+import Data.Aeson hiding (Result, Error)+import Data.List+import Data.Maybe+import qualified Data.Map.Strict as M+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T (append, null)+import System.Directory+import System.FilePath+import qualified System.Log.Simple as Log+import qualified System.Log.Simple.Base as Log+import Text.Read (readMaybe)++import Data.Maybe.JustIf+import qualified System.Directory.Watcher as W+import System.Directory.Paths+import Text.Format+import HsDev.Error+import HsDev.Database.SQLite as SQLite+import HsDev.Inspect (preload, asModule)+import HsDev.Scan (upToDate, getFileContents)+import HsDev.Server.Message as M+import HsDev.Server.Types+import HsDev.Sandbox hiding (findSandbox)+import qualified HsDev.Sandbox as S (findSandbox)+import HsDev.Symbols+import qualified HsDev.Tools.AutoFix as AutoFix+import qualified HsDev.Tools.Cabal as Cabal+import HsDev.Tools.Ghc.Session+import HsDev.Tools.Ghc.Worker (clearTargets)+import qualified HsDev.Tools.Ghc.Compat as Compat+import qualified HsDev.Tools.Ghc.Check as Check+import qualified HsDev.Tools.Ghc.Types as Types+import qualified HsDev.Tools.Hayoo as Hayoo+import qualified HsDev.Tools.HDocs as HDocs+import qualified HsDev.Tools.HLint as HLint+import qualified HsDev.Tools.Types as Tools+import HsDev.Util+import HsDev.Watcher++import qualified HsDev.Database.Update as Update++runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result+runClient copts = mapServerM toResult . runClientM where+	toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result+	toResult act = liftM errorToResult $ runReaderT (try (try act)) copts+	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b+	mapServerM f = ServerM . mapReaderT f . runServerM+	errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result+	errorToResult = either (Error . UnhandledError . displayException) (either Error (Result . toJSON))++toValue :: (ToJSON a, Monad m) => m a -> m Value+toValue = fmap toJSON++runCommand :: ServerMonadBase m => Command -> ClientM m Value+runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]+runCommand (Listen (Just l)) = case Log.level (pack l) of+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l+	Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)+runCommand (Listen Nothing) = toValue $ do+	serverListen >>= mapM_ (commandNotify . Notification . toJSON)+runCommand (SetLogLevel l) = case Log.level (pack l) of+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l+	Just lev -> toValue $ do+		lev' <- serverSetLogLevel lev+		Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev+		Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev+runCommand (Scan projs cabal sboxes fs paths' btool ghcs' docs' infer') = toValue $ do+	sboxes' <- getSandboxes sboxes+	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [+		[Update.scanCabal ghcs' | cabal],+		map (Update.scanSandbox ghcs') sboxes',+		[Update.scanFiles (zip fs (repeat ghcs'))],+		map (Update.scanProject ghcs' btool) projs,+		map (Update.scanDirectory ghcs') paths']+runCommand (ScanProject proj tool deps) = toValue $ updateProcess def [+	(if deps then Update.scanProjectStack else Update.scanProject) [] tool proj]+runCommand (ScanFile fpath tool scanProj deps) = toValue $ updateProcess def [+	Update.scanFile [] fpath tool scanProj deps]+runCommand (ScanPackageDbs pdbs) = toValue $ updateProcess def [+	Update.scanPackageDbStack [] pdbs]+runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts+runCommand (RefineDocs projs fs)+	| HDocs.hdocsSupported = toValue $ updateProcess def $ return $ do+		projects <- traverse findProject projs+		projMods <- liftM concat $ forM projects $ \proj -> do+			ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.docs') is null"+				(Only $ proj ^. projectCabal)+			p <- SQLite.loadProject (proj ^. projectCabal)+			return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms+		fileMods <- liftM concat $ forM fs $ \f ->+			loadModules "select id from modules where file == ? and json_extract(tags, '$.docs') is null"+				(Only f)+		Update.scanDocs $ projMods ++ fileMods+	| otherwise = hsdevError $ OtherError "docs not supported"+runCommand (InferTypes projs fs) = toValue $ updateProcess def $ return $ do+	projects <- traverse findProject projs+	projMods <- liftM concat $ forM projects $ \proj -> do+		ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.types') is null"+			(Only $ proj ^. projectCabal)+		p <- SQLite.loadProject (proj ^. projectCabal)+		return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms+	fileMods <- liftM concat $ forM fs $ \f ->+		loadModules "select id from modules where file == ? and json_extract(tags, '$.types') is null"+			(Only f)+	Update.inferModTypes $ projMods ++ fileMods+runCommand (Remove projs cabal sboxes files) = toValue $ withSqlConnection $ SQLite.transaction_ SQLite.Immediate $ do+	let+		-- We can safely remove package-db from db iff doesn't used by some of other package-dbs+		-- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db+		-- We also can't remove stack snapshot package-db if there are some local package-db not yet removed+		canRemove pdbs = do+			from' <- State.get+			return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from'+		-- Remove top of package-db stack if possible+		removePackageDb' pdbs = do+			can <- canRemove pdbs+			when can $ do+				State.modify (delete pdbs)+				ms <- liftM (map fromOnly) $ query_+					"select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;"+				removePackageDb (topPackageDb pdbs)+				mapM_ SQLite.removeModule ms+				whenJustM (askSession sessionWatcher) $ \w ->+					liftIO $ unwatchPackageDb w $ topPackageDb pdbs+		-- Remove package-db stack when possible+		removePackageDbStack = mapM_ removePackageDb' . packageDbStacks+	projects <- traverse findProject projs+	sboxes' <- getSandboxes sboxes+	forM_ projects $ \proj -> do+		ms <- liftM (map fromOnly) $ query "select id from modules where cabal == ?;" (Only $ proj ^. projectCabal)+		SQLite.removeProject proj+		mapM_ SQLite.removeModule ms+		whenJustM (askSession sessionWatcher) $ \w ->+			liftIO $ unwatchProject w proj++	allPdbs <- liftM (map fromOnly) $ query_ @(Only PackageDb) "select package_db from package_dbs;"+	dbPDbs <- inSessionGhc $ mapM restorePackageDbStack allPdbs+	flip State.evalStateT dbPDbs $ do+		when cabal $ removePackageDbStack userDb+		forM_ sboxes' $ \sbox -> do+			pdbs <- lift $ inSessionGhc $ sandboxPackageDbStack sbox+			removePackageDbStack pdbs++	forM_ files $ \file -> do+		ms <- query @_ @(ModuleId :. Only Int)+			(toQuery $ mconcat [+				qModuleId,+				select_ ["mu.id"],+				where_ ["mu.file == ?"]])+			(Only file)+		forM_ ms $ \(m :. Only i) -> do+			SQLite.removeModule i+			whenJustM (askSession sessionWatcher) $ \w ->+				liftIO . unwatchModule w $ (m ^. moduleLocation)+runCommand RemoveAll = toValue $ do+	SQLite.purge+	whenJustM (askSession sessionWatcher) $ \w -> do+		wdirs <- liftIO $ readMVar (W.watcherDirs w)+		liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir+runCommand InfoPackages = toValue $+	query_ @ModulePackage "select package_name, package_version from package_dbs;"+runCommand InfoProjects = toValue $ do+	ps <- query_ @(Only Path) "select cabal from projects;"+	mapM (SQLite.loadProject . fromOnly) ps+runCommand InfoSandboxes = toValue $ do+	rs <- query_ @(Only PackageDb) "select distinct package_db from package_dbs;"+	return [pdb | Only pdb <- rs]+runCommand (InfoSymbol sq filters True _) = toValue $ do+	let+		(conds, params) = targetFilters "m" (Just "s") filters+	queryNamed @SymbolId+		(toQuery $ mconcat [+			qSymbolId,+			where_ ["s.name like :pattern escape '\\'"],+			where_ conds])+		([":pattern" := likePattern sq] ++ params)+runCommand (InfoSymbol sq filters False _) = toValue $ do+	let+		(conds, params) = targetFilters "m" (Just "s") filters+	queryNamed @Symbol+		(toQuery $ mconcat [+			qSymbol,+			where_ ["s.name like :pattern escape '\\'"],+			where_ conds])+		([":pattern" := likePattern sq] ++ params)+runCommand (InfoModule sq filters h _) = toValue $ do+	let+		(conds, params) = targetFilters "mu" Nothing filters+	rs <- queryNamed @(Only Int :. ModuleId)+		(toQuery $ mconcat [+			select_ ["mu.id"],+			qModuleId,+			where_ ["mu.name like :pattern escape '\\'"],+			where_ conds])+		([":pattern" := likePattern sq] ++ params)+	if h+		then return (toJSON $ map (\(_ :. m) -> m) rs)+		else liftM toJSON $ forM rs $ \(Only mid :. mheader) -> do+			[(docs, fixities)] <- query @_ @(Maybe Text, Maybe Value) "select m.docs, m.fixities from modules as m where (m.id == ?);"+				(Only mid)+			let+				fixities' = fromMaybe [] (fixities >>= fromJSON')+			imports' <- query @_ @Import (toQuery $ mconcat [+				qImport "i",+				where_ ["i.module_id = ?"]])+				(Only mid)+			exports' <- query @_ @Symbol (toQuery $ mconcat [+				qSymbol,+				from_ ["exports as e"],+				where_ ["e.module_id == ?", "e.symbol_id == s.id"]])+				(Only mid)+			return $ Module mheader docs imports' exports' fixities' mempty Nothing+runCommand (InfoProject (Left projName)) = toValue $ findProject projName+runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject (view path projPath)+runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandboxes sandbox'+runCommand (Lookup nm fpath) = toValue $+	fmap (map (\(s :. m) -> ImportedSymbol s m)) $ query @_ @(Symbol :. ModuleId) (toQuery $ mconcat [+		qSymbol,+		qModuleId,+		from_ ["projects_modules_scope as pms", "modules as srcm", "exports as e"],+		where_ [+			"pms.cabal is srcm.cabal",+			"srcm.file = ?",+			"pms.module_id = e.module_id",+			"m.id = s.module_id",+			"s.id = e.symbol_id",+			"e.module_id = mu.id",+			"s.name = ?"]])+		(fpath ^. path, nm)+runCommand (Whois nm fpath) = toValue $ do+	let+		q = nameModule $ toName nm+		ident = nameIdent $ toName nm+	query @_ @Symbol (toQuery $ mconcat [+		qSymbol,+		from_ ["modules as srcm", "scopes as sc"],+		where_ [+			"srcm.id == sc.module_id",+			"s.id == sc.symbol_id",+			"srcm.file == ?",+			"sc.qualifier is ?",+			"sc.name == ?"]])+		(fpath ^. path, q, ident)+runCommand (Whoat l c fpath) = toValue $ do+	rs <- query @_ @Symbol (toQuery $ mconcat [+		qSymbol,+		from_ ["names as n", "modules as srcm"],+		where_ [+			"srcm.id == n.module_id",+			"m.name == n.resolved_module",+			"s.name == n.resolved_name",+			"s.what == n.resolved_what",+			"s.id == n.symbol_id",+			"srcm.file == ?",+			"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])+		(fpath ^. path, l, c)+	locals <- do+		defs <- query @_ @(ModuleId :. (Text, Int, Int, Maybe Text)) (toQuery $ mconcat [+			qModuleId,+			select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type"],+			from_ ["names as n"],+			where_ [+				"mu.id == n.module_id",+				"n.def_line is not null",+				"n.def_column is not null",+				"mu.file == ?",+				"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])+			(fpath ^. path, l, c)+		return [+			Symbol {+				_symbolId = SymbolId nm mid,+				_symbolDocs = Nothing,+				_symbolPosition = Just (Position defLine defColumn),+				_symbolInfo = Function ftype+			} | (mid :. (nm, defLine, defColumn, ftype)) <- defs]+	return $ rs ++ locals+runCommand (ResolveScopeModules sq fpath) = toValue $ do+	pids <- query @_ @(Only (Maybe Path)) "select m.cabal from modules as m where (m.file == ?);"+		(Only $ fpath ^. path)+	case pids of+		[] -> hsdevError $ OtherError $ "module at {} not found" ~~ fpath+		[Only proj] -> query @_ @ModuleId (toQuery $ mconcat [+			qModuleId,+			from_ ["projects_modules_scope as msc"],+			where_ [+				"msc.module_id == mu.id",+				"msc.cabal is ?",+				"mu.name like ? escape '\\'"]])+			(proj, likePattern sq)+		_ -> fail "Impossible happened: several projects for one module"+runCommand (ResolveScope sq fpath) = toValue $+	query @_ @(Scoped SymbolId) (toQuery $ mconcat [+		qSymbolId,+		select_ ["sc.qualifier"],+		from_ ["scopes as sc", "modules as srcm"],+		where_ [+			"srcm.id == sc.module_id",+			"sc.symbol_id == s.id",+			"srcm.file == ?",+			"s.name like ? escape '\\'"]])+		(fpath ^. path, likePattern sq)+runCommand (FindUsages l c fpath) = toValue $ do+	us <- do+		sids <- query @_ @(Only (Maybe Int)) (toQuery $ mconcat [+			select_ ["n.symbol_id"],+			from_ ["names as n", "modules as srcm"],+			where_ [+				"n.module_id == srcm.id",+				"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)",+				"srcm.file = ?"]])+			(l, c, fpath)+		when (length sids > 1) $ Log.sendLog Log.Warning $ "multiple symbols found at location {0}:{1}:{2}" ~~ fpath ~~ l ~~ c+		let+			msid = join $ fmap fromOnly $ listToMaybe sids+		query @_ @SymbolUsage (toQuery $ mconcat [+			qSymbol,+			select_ ["n.qualifier"],+			qModuleId,+			select_ ["n.line", "n.column", "n.line_to", "n.column_to"],+			from_ ["names as n"],+			where_ [+				"n.symbol_id == ?",+				"s.id == n.symbol_id",+				"mu.id == n.module_id"]])+			(Only msid)+	locals <- do+		defs <- query @_ @(ModuleId :. Only Text :. Position :. Only (Maybe Text) :. Region) (toQuery $ mconcat [+			qModuleId,+			select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type", "n.line", "n.column", "n.line_to", "n.column_to"],+			from_ ["names as n", "names as defn"],+			where_ [+				"n.module_id = mu.id",+				"n.def_line = defn.def_line",+				"n.def_column = defn.def_column",+				"defn.module_id = mu.id",+				"(?, ?) between (defn.line, defn.column) and (defn.line_to, defn.column_to)",+				"mu.file = ?"]])+			(l, c, fpath ^. path)+		return $ do+			(mid :. Only nm :. defPos :. Only ftype :. useRgn) <- defs+			let+				sym = Symbol {+					_symbolId = SymbolId nm mid,+					_symbolDocs = Nothing,+					_symbolPosition = Just defPos,+					_symbolInfo = Function ftype }+			return $ SymbolUsage sym Nothing mid useRgn+	return $ us ++ locals+runCommand (Complete input True fpath) = toValue $+	query @_ @Symbol (toQuery $ mconcat [+		qSymbol,+		from_ ["modules as srcm", "exports as e"],+		where_ [+			"e.module_id in (select srcm.id union select module_id from projects_modules_scope where (((cabal is null) and (srcm.cabal is null)) or (cabal == srcm.cabal)))",+			"s.id == e.symbol_id",+			"msrc.file == ?",+			"s.name like ? escape '\\'"]])+		(fpath ^. path, likePattern (SearchQuery input SearchPrefix))+runCommand (Complete input False fpath) = toValue $+	query @_ @(Scoped Symbol) (toQuery $ mconcat [+		qSymbol,+		select_ ["c.qualifier"],+		from_ ["completions as c", "modules as srcm"],+		where_ [+			"c.module_id == srcm.id",+			"c.symbol_id == s.id",+			"srcm.file == ?",+			"c.completion like ? escape '\\'"]])+		(fpath ^. path, likePattern (SearchQuery input SearchPrefix))+runCommand (Hayoo hq p ps) = do+	m <- askSession sessionHTTPManager+	toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM+		(mapMaybe Hayoo.hayooAsSymbol . Hayoo.resultResult) $+		liftIO $ hsdevLift $ Hayoo.hayoo m hq (Just i)+runCommand (CabalList packages') = toValue $ liftIO $ hsdevLift $ Cabal.cabalList $ map unpack packages'+runCommand (UnresolvedSymbols fs) = toValue $ liftM concat $ forM fs $ \f -> do+	rs <- query @_ @(Maybe String, String, Int, Int) "select n.qualifier, n.name, n.line, n.column from modules as m, names as n where (m.id == n.module_id) and (m.file == ?) and (n.resolve_error is not null);"+		(Only $ f ^. path)+	return $ map (\(m, nm, line, column) -> object [+		"qualifier" .= m,+		"name" .= nm,+		"line" .= line,+		"column" .= column]) rs+runCommand (Lint fs lints) = toValue $ liftM concat $ forM fs $ \fsrc -> do+	FileSource f c <- getUpdateFileContents fsrc+	liftIO $ hsdevLift $ HLint.hlint lints (view path f) c+runCommand (Check fs ghcs' clear) = toValue $ Log.scope "check" $+	liftM concat $ mapM (runCheck ghcs' clear) fs+runCommand (CheckLint fs ghcs' lints clear) = toValue $ do+	fs' <- mapM getUpdateFileContents fs+	checkMsgs <- liftM concat $ mapM (runCheck ghcs' clear) fs'+	lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint lints (view path f) c) fs'+	return $ checkMsgs ++ lintMsgs+runCommand (Types fs ghcs' clear) = toValue $ do+	liftM concat $ forM fs $ \fsrc@(FileSource file msrc) -> do+		mcached' <- getCached file msrc+		FileSource _ msrc' <- getUpdateFileContents fsrc+		maybe (updateTypes file msrc') return mcached'+	where+		getCached :: ServerMonadBase m => Path -> Maybe Text -> ClientM m (Maybe [Tools.Note Types.TypedExpr])+		getCached _ (Just _) = return Nothing+		getCached file' Nothing = do+			actual' <- sourceUpToDate file'+			mid <- query @_ @((Bool, Int) :. ModuleId)+				(toQuery $ mconcat [+					select_ ["json_extract(tags, '$.types') is 1", "mu.id"],+					qModuleId,+					where_ ["mu.file = ?"]])+				(Only file')+			when (length mid > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ file'+			when (null mid) $ hsdevError $ NotInspected $ FileModule file' Nothing+			let+				[(hasTypes', mid') :. modId] = mid+			if actual' && hasTypes'+				then do+					types' <- query @_ @(Region :. Types.TypedExpr) "select line, column, line_to, column_to, expr, type from types where module_id = ?;" (Only mid')+					liftM Just $ forM types' $ \(rgn :. texpr) -> return Tools.Note {+						Tools._noteSource = modId ^. moduleLocation,+						Tools._noteRegion = rgn,+						Tools._noteLevel = Nothing,+						Tools._note = set Types.typedExpr Nothing texpr }+				else return Nothing++		updateTypes file msrc = do+			sess <- getSession+			m <- setFileSourceSession ghcs' file+			types' <- inSessionGhc $ do+				when clear clearTargets+				Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $+					Types.fileTypes m msrc+			updateProcess def [Update.setModTypes (m ^. moduleId) types']+			return $ set (each . Tools.note . Types.typedExpr) Nothing types'+runCommand (AutoFix ns) = toValue $ return $ AutoFix.corrections ns+runCommand (Refactor ns rest isPure) = toValue $ do+	files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns+	let+		runFix file = do+			unless isPure $ do+				liftIO $ readFileUtf8 (view path file) >>= writeFileUtf8 (view path file) . AutoFix.refact fixRefacts'+			return newCorrs'+			where+				findCorrs :: Path -> [Tools.Note AutoFix.Refact] -> [Tools.Note AutoFix.Refact]+				findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))+				fixCorrs' = findCorrs file ns+				upCorrs' = findCorrs file rest+				fixRefacts' = fixCorrs' ^.. each . Tools.note+				newCorrs' = AutoFix.update fixRefacts' upCorrs'+	liftM concat $ mapM runFix files+runCommand (Rename nm newName mloc fpath) = toValue $ do+	m <- refineSourceModule fpath+	let+		mname = m ^. moduleId . moduleName+		makeNote loc r = Tools.Note {+			Tools._noteSource = loc,+			Tools._noteRegion = r,+			Tools._noteLevel = Nothing,+			Tools._note = AutoFix.Refact "rename" (AutoFix.replace (AutoFix.fromRegion r) newName) }++	msum [+		do+			topRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and ((n.def_line is not null and n.def_column is not null) or (n.def_line == ? and n.def_column == ?)) and n.symbol_id is not null;" (+				mname,+				nm,+				fmap fst mloc,+				fmap snd mloc)+			guard (not $ null topRegions)+			let+				defRenames = map (makeNote (m ^. moduleId . moduleLocation)) topRegions+			usageRenames <- do+				usageRegions <- query @_ @(Only Path :. Region) "select m.file, n.line, n.column, n.line_to, n.column_to from names as n, modules as m where n.module_id == m.id and m.file is not null and n.resolved_module == ? and n.resolved_name == ?;" (+					mname,+					nm)+				return $ map (\(Only p :. r) -> makeNote (FileModule p Nothing) r) usageRegions+			return $ ordNub (defRenames ++ usageRenames),+		do+			localRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and n.def_line == ? and n.def_column == ? and n.symbol_id is null;" (+				mname,+				nm,+				fmap fst mloc,+				fmap snd mloc)+			return $ map (makeNote (m ^. moduleId . moduleLocation)) localRegions]+runCommand (GhcEval exprs mfile) = toValue $ do+	mfile' <- traverse getUpdateFileContents mfile+	case mfile' of+		Nothing -> inSessionGhc ghciSession+		Just (FileSource f mcts) -> do+			m <- setFileSourceSession [] f+			inSessionGhc $ interpretModule m mcts+	inSessionGhc $ mapM (tryRepl . evaluate) exprs+runCommand (GhcType exprs mfile) = toValue $ do+	mfile' <- traverse getUpdateFileContents mfile+	case mfile' of+		Nothing -> inSessionGhc ghciSession+		Just (FileSource f mcts) -> do+			m <- setFileSourceSession [] f+			inSessionGhc $ interpretModule m mcts+	inSessionGhc $ mapM (tryRepl . expressionType) exprs+runCommand Langs = toValue $ return Compat.languages+runCommand Flags = toValue $ return ["-f" ++ prefix ++ f |+	f <- Compat.flags,+	prefix <- ["", "no-"]]+runCommand (Link hold) = toValue $ commandLink >> when hold commandHold+runCommand StopGhc = toValue $ do+	inSessionGhc $ do+		ms <- findSessionBy (const True)+		forM_ ms $ \s -> do+			Log.sendLog Log.Trace $ "stopping session: {}" ~~ view sessionKey s+			deleteSession $ view sessionKey s+runCommand Exit = toValue serverExit+++targetFilter :: Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam])+targetFilter mtable _ (TargetProject proj) = (+	"{t}.cabal in (select cabal from projects where name == :project or cabal == :project)" ~~ ("t" ~% mtable),+	[":project" := proj])+targetFilter mtable _ (TargetFile f) = ("{t}.file == :file" ~~ ("t" ~% mtable), [":file" := f])+targetFilter mtable Nothing (TargetModule nm) = ("{t}.name == :module_name" ~~ ("t" ~% mtable), [":module_name" := nm])+targetFilter mtable (Just stable) (TargetModule nm) = (+	"({t}.name == :module_name) or ({s}.id in (select e.symbol_id from exports as e, modules as em where e.module_id == em.id and em.name == :module_name))"+		~~ ("t" ~% mtable)+		~~ ("s" ~% stable),+	[":module_name" := nm])+targetFilter mtable _ (TargetPackage p) = (tpl ~~ ("t" ~% mtable), params) where+	pkg = fromMaybe (mkPackage p) (readMaybe (unpack p))+	tpl+		| T.null (pkg ^. packageVersion) = "{t}.package_name == :package_name"+		| otherwise = "{t}.package_name == :package_name and {t}.package_version == :package_version"+	params+		| T.null (pkg ^. packageVersion) = [pname]+		| otherwise = [pname, pver]+	pname = ":package_name" := (pkg ^. packageName)+	pver = ":package_version" := (pkg ^. packageVersion)+targetFilter mtable _ TargetInstalled = ("{t}.package_name is not null" ~~ ("t" ~% mtable), [])+targetFilter mtable _ TargetSourced = ("{t}.file is not null" ~~ ("t" ~% mtable), [])+targetFilter mtable _ TargetStandalone = ("{t}.file is not null and {t}.cabal is null" ~~ ("t" ~% mtable), [])++targetFilters :: Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])+targetFilters mtable stable = second concat . unzip . map (targetFilter mtable stable)++likePattern :: SearchQuery -> Text+likePattern (SearchQuery input stype) = case stype of+	SearchExact -> escapedInput+	SearchPrefix -> escapedInput `T.append` "%"+	SearchInfix -> "%" `T.append` escapedInput `T.append` "%"+	SearchSuffix -> "%" `T.append` escapedInput+	where+		escapedInput = escapeLike input++instance ToJSON Log.Message where+	toJSON m = object [+		"time" .= Log.messageTime m,+		"level" .= show (Log.messageLevel m),+		"component" .= show (Log.messageComponent m),+		"scope" .= show (Log.messageScope m),+		"text" .= Log.messageText m]++instance FromJSON Log.Message where+	parseJSON = withObject "log-message" $ \v -> Log.Message <$>+		(v .:: "time") <*>+		((v .:: "level") >>= maybe (fail "invalid level") return . readMaybe) <*>+		(read <$> (v .:: "component")) <*>+		(read <$> (v .:: "scope")) <*>+		(v .:: "text")+++-- | Run check+runCheck :: CommandMonad m => [String] -> Bool -> FileSource -> m [Tools.Note Tools.OutputMessage]+runCheck ghcs' clear = getUpdateFileContents >=> check' where+	check' (FileSource file mcts) = Log.scope "run-check" $ do+		Log.sendLog Log.Trace $ "setting file source session for {}" ~~ file+		sess <- getSession+		m <- setFileSourceSession ghcs' file+		Log.sendLog Log.Trace "file source session set"+		ns <- inSessionGhc $ do+			when clear clearTargets+			Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $+				Check.check m mcts+		if null ns+			then do+				inSessionUpdater $ return () -- wait until cache updated+				ns' <- Update.cachedWarnings [m ^. moduleId . moduleLocation]+				unless (null ns') $+					Log.sendLog Log.Trace $ "returning {} cached warnings for {}" ~~ length ns' ~~ file+				return ns'+			else return ns++-- Helper functions++-- | Canonicalize paths+findPath :: (CommandMonad m, Paths a) => a -> m a+findPath = paths findPath' where+	findPath' :: CommandMonad m => FilePath -> m FilePath+	findPath' f = do+		r <- commandRoot+		liftIO $ canonicalizePath (normalise $ if isRelative f then r </> f else f)++-- | Find sandbox by path+findSandbox :: CommandMonad m => Path -> m Sandbox+findSandbox fpath = do+	fpath' <- findPath fpath+	sbox <- liftIO $ S.findSandbox fpath'+	maybe (hsdevError $ FileNotFound fpath') return sbox++-- | Check if source file up to date+sourceUpToDate :: CommandMonad m => Path -> m Bool+sourceUpToDate fpath = do+	fpath' <- findPath fpath+	insps <- query @_ @Inspection "select inspection_time, inspection_opts from modules where file = ?;" (Only fpath')+	when (length insps > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'+	maybe+		(return False)+		(upToDate (FileModule fpath' Nothing) [])+		(listToMaybe insps)++-- | Get source file+-- refineSourceFile :: CommandMonad m => Path -> m Path+-- refineSourceFile fpath = do+-- 	fpath' <- findPath fpath+-- 	fs <- liftM (map fromOnly) $ query "select file from modules where file == ?;" (Only fpath')+-- 	case fs of+-- 		[] -> hsdevError (NotInspected $ FileModule fpath' Nothing)+-- 		(f:_) -> do+-- 			when (length fs > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'+-- 			return f++-- | Get module by source+refineSourceModule :: CommandMonad m => Path -> m Module+refineSourceModule fpath = do+	fpath' <- findPath fpath+	ids <- query "select id, cabal from modules where file == ?;" (Only fpath')+	case ids of+		[] -> hsdevError (NotInspected $ FileModule fpath' Nothing)+		((i, mcabal):_) -> do+			when (length ids > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'+			m <- SQLite.loadModule i+			case mcabal of+				Nothing -> do+					[insp] <- query @_ @Inspection "select inspection_time, inspection_opts from modules where id = ?;" (Only i)+					fresh' <- upToDate (m ^. moduleId . moduleLocation) [] insp+					if fresh'+						then return m+						else do+							defs <- askSession sessionDefines+							mcts <- fmap (fmap snd) $ getFileContents fpath'+							ip' <- runInspect (m ^. moduleId . moduleLocation) $ preload (m ^. moduleId . moduleName) defs [] mcts+							case ip' ^? inspected of+								Just p' -> return $ set moduleImports (p' ^. asModule . moduleImports) m+								Nothing -> return m+				Just cabal' -> do+					proj' <- SQLite.loadProject cabal'+					return $ set (moduleId . moduleLocation . moduleProject) (Just proj') m++-- | Get update file contents+getUpdateFileContents :: CommandMonad m => FileSource -> m FileSource+getUpdateFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath)+getUpdateFileContents fcts@(FileSource fpath mcts) = do+	serverSetFileContents fpath mcts+	return fcts++-- | Set session by source+setFileSourceSession :: CommandMonad m => [String] -> Path -> m Module+setFileSourceSession opts fpath = do+	m <- refineSourceModule fpath+	inSessionGhc $ targetSession opts m+	return m++-- | Ensure package exists+-- refinePackage :: CommandMonad m => Text -> m Text+-- refinePackage pkg = do+-- 	[(Only exists)] <- query "select count(*) > 0 from package_dbs where package_name == ?;" (Only pkg)+-- 	when (not exists) $ hsdevError (PackageNotFound pkg)+-- 	return pkg++-- | Get list of enumerated sandboxes+getSandboxes :: CommandMonad m => [Path] -> m [Sandbox]+getSandboxes = traverse (findPath >=> findSandbox)++-- | Find project by name or path+findProject :: CommandMonad m => Text -> m Project+findProject proj = do+	proj' <- liftM addCabal $ findPath proj+	ps <- liftM (map fromOnly) $ query "select cabal from projects where (cabal == ?) or (name == ?);" (view path proj', proj)+	case ps of+		[] -> hsdevError $ ProjectNotFound proj+		_ -> SQLite.loadProject (head ps)+	where+		addCabal p+			| takeExtension (view path p) == ".cabal" = p+			| otherwise = over path (\p' -> p' </> (takeBaseName p' <.> "cabal")) p++-- | Run DB update action+updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM IO ()] -> ClientM m ()+updateProcess uopts acts = hoist liftIO $ do+	copts <- getOptions+	inSessionUpdater $ hoist (flip runReaderT copts) $ runClientM $ mapM_ (Update.runUpdate uopts . runAct) acts+	where+		runAct act = catch act onError+		onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError)

@@ -1,501 +1,501 @@-{-# LANGUAGE OverloadedStrings, TypeOperators, TypeApplications #-}
-
-module HsDev.Database.SQLite (
-	initialize, purge,
-	privateMemory, sharedMemory,
-	query, query_, queryNamed, execute, execute_, executeMany, executeNamed,
-	withTemporaryTable,
-	updatePackageDb, removePackageDb, insertPackageDb,
-	updateProject, removeProject, insertProject, insertBuildInfo,
-	removeModuleContents, removeModule,
-	lookupModuleLocation, lookupModule,
-	lookupSymbol,
-	lastRow,
-
-	loadModule, loadModules,
-	loadProject,
-
-	updateModules, upsertModules,
-
-	-- * Utils
-	lookupId,
-	escapeLike,
-
-	-- * Reexports
-	module Database.SQLite.Simple,
-	module HsDev.Database.SQLite.Select,
-	module HsDev.Database.SQLite.Instances,
-	module HsDev.Database.SQLite.Transaction
-	) where
-
-import Control.Lens hiding ((.=))
-import Control.Monad
-import Control.Monad.Catch
-import Control.Monad.IO.Class
-import Data.Aeson hiding (Error)
-import Data.List (intercalate)
-import Data.Maybe
-import Data.String
-import qualified Data.Set as S
-import Data.Text (Text)
-import qualified Data.Text as T
-import Database.SQLite.Simple hiding (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)
-import qualified Database.SQLite.Simple as SQL (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)
-import Distribution.Text (display)
-import Language.Haskell.Extension ()
-import System.Directory
-import System.Log.Simple
-import Text.Format
-
-import System.Directory.Paths
-
-import HsDev.Database.SQLite.Instances
-import HsDev.Database.SQLite.Schema
-import HsDev.Database.SQLite.Select
-import HsDev.Database.SQLite.Transaction
-import qualified HsDev.Display as Display
-import HsDev.Error
-import HsDev.PackageDb.Types
-import HsDev.Project.Types
-import HsDev.Symbols (hasTag)
-import HsDev.Symbols.Types hiding (loadProject)
-import HsDev.Server.Types
-import HsDev.Util
-
--- | Open new connection and set some pragmas
-new :: String -> IO Connection
-new p = do
-	conn <- open p
-	SQL.execute_ conn "pragma case_sensitive_like = true;"
-	SQL.execute_ conn "pragma synchronous = off;"
-	SQL.execute_ conn "pragma journal_mode = memory;"
-	return conn
-
--- | Initialize database
-initialize :: String -> IO Connection
-initialize p = do
-	conn <- new p
-	[Only hasTables] <- SQL.query_ conn "select count(*) > 0 from sqlite_master where type == 'table';"
-	goodVersion <- if hasTables
-		then do
-			[Only equalVersion] <- SQL.query conn "select sum(json(value) == json(?)) > 0 from hsdev where option == 'version';" (Only $ toJSON version)
-			return equalVersion
-		else return True
-	let
-		start
-			| not goodVersion = do
-					close conn
-					removeFile p
-					conn' <- new p
-					initDb conn'
-			| not hasTables = initDb conn
-			| otherwise = return conn
-		initDb conn' = SQL.withTransaction conn' $ do
-			mapM_ (SQL.execute_ conn') commands
-			SQL.execute @(Text, Value) conn' "insert into hsdev values (?, ?);" ("version", toJSON version)
-			return conn'
-	start
-
-purge :: SessionMonad m => m ()
-purge = do
-	tables <- query_ @(Only String) "select name from sqlite_master where type == 'table';"
-	forM_ tables $ \(Only table) ->
-		execute_ $ fromString $ "delete from {};" ~~ table
-
--- | Private memory for db
-privateMemory :: String
-privateMemory = ":memory:"
-
--- | Shared db in memory
-sharedMemory :: String
-sharedMemory = "file::memory:?cache=shared"
-
--- | Retries for simple queries
-retried :: (MonadIO m, MonadCatch m) => m a -> m a
-retried = retry def
-
-query :: (ToRow q, FromRow r, SessionMonad m) => Query -> q -> m [r]
-query q' params = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.query conn q' params
-
-query_ :: (FromRow r, SessionMonad m) => Query -> m [r]
-query_ q' = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.query_ conn q'
-
-queryNamed :: (FromRow r, SessionMonad m) => Query -> [NamedParam] -> m [r]
-queryNamed q' ps' = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.queryNamed conn q' ps'
-
-execute :: (ToRow q, SessionMonad m) => Query -> q -> m ()
-execute q' params = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.execute conn q' params
-
-execute_ :: SessionMonad m => Query -> m ()
-execute_ q' = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.execute_ conn q'
-
-executeMany :: (ToRow q, SessionMonad m) => Query -> [q] -> m ()
-executeMany q' params = do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.executeMany conn q' params
-
-executeNamed :: SessionMonad m => Query -> [NamedParam] -> m ()
-executeNamed q' ps' = do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.executeNamed conn q' ps'
-
-withTemporaryTable :: SessionMonad m => String -> [String] -> m a -> m a
-withTemporaryTable tableName columns = bracket_ createTable dropTable where
-	createTable = execute_ $ fromString $ "create temporary table {} ({});" ~~ tableName ~~ (intercalate ", " columns)
-	dropTable = execute_ $ fromString $ "drop table {};" ~~ tableName
-
-updatePackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()
-updatePackageDb pdb pkgs = scope "update-package-db" $ transaction_ Immediate $ do
-	sendLog Trace $ "update package-db: {}" ~~ Display.display pdb
-	removePackageDb pdb
-	insertPackageDb pdb pkgs
-
-removePackageDb :: SessionMonad m => PackageDb -> m ()
-removePackageDb pdb = scope "remove-package-db" $
-	execute "delete from package_dbs where package_db == ?;" (Only pdb)
-
-insertPackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()
-insertPackageDb pdb pkgs = scope "insert-package-db" $ forM_ pkgs $ \pkg ->
-	execute
-		"insert into package_dbs (package_db, package_name, package_version) values (?, ?, ?);"
-		(pdb, pkg ^. packageName, pkg ^. packageVersion)
-
-updateProject :: SessionMonad m => Project -> m ()
-updateProject proj = scope "update-project" $ transaction_ Immediate $ do
-	sendLog Trace $ "update project: {}" ~~ Display.display proj
-	removeProject proj
-	insertProject proj
-
-removeProject :: SessionMonad m => Project -> m ()
-removeProject proj = scope "remove-project" $ do
-	projId <- query @_ @(Only Int) "select id from projects where cabal == ?;" (Only $ proj ^. projectCabal)
-	case projId of
-		[] -> return ()
-		pids -> do
-			when (length pids > 1) $
-				sendLog Warning $ "multiple projects for cabal {} found" ~~ (proj ^. projectCabal)
-			forM_ pids $ \pid -> do
-				bids <- query @_ @(Only Int) "select build_info_id from targets where project_id == ?;" pid
-				execute "delete from projects where id == ?;" pid
-				execute "delete from libraries where project_id == ?;" pid
-				execute "delete from executables where project_id == ?;" pid
-				execute "delete from tests where project_id == ?;" pid
-				forM_ bids $ \bid -> execute "delete from build_infos where id == ?;" bid
-
-insertProject :: SessionMonad m => Project -> m ()
-insertProject proj = scope "insert-project" $ do
-	execute "insert into projects (name, cabal, version, build_tool, package_db_stack) values (?, ?, ?, ?, ?);" proj
-	projId <- lastRow
-
-	forM_ (proj ^? projectDescription . _Just . projectLibrary . _Just) $ \lib -> do
-		buildInfoId <- insertBuildInfo $ lib ^. libraryBuildInfo
-		execute "insert into libraries (project_id, modules, build_info_id) values (?, ?, ?);"
-			(projId, encode $ lib ^. libraryModules, buildInfoId)
-
-	forM_ (proj ^.. projectDescription . _Just . projectExecutables . each) $ \exe -> do
-		buildInfoId <- insertBuildInfo $ exe ^. executableBuildInfo
-		execute "insert into executables (project_id, name, path, build_info_id) values (?, ?, ?, ?);"
-			(projId, exe ^. executableName, exe ^. executablePath . path, buildInfoId)
-
-	forM_ (proj ^.. projectDescription . _Just . projectTests . each) $ \test -> do
-		buildInfoId <- insertBuildInfo $ test ^. testBuildInfo
-		execute "insert into tests (project_id, name, enabled, main, build_info_id) values (?, ?, ?, ?, ?);"
-			(projId, test ^. testName, test ^. testEnabled, test ^? testMain . _Just . path, buildInfoId)
-
-insertBuildInfo :: SessionMonad m => Info -> m Int
-insertBuildInfo info = scope "insert-build-info" $ do
-	execute "insert into build_infos (depends, language, extensions, ghc_options, source_dirs, other_modules) values (?, ?, ?, ?, ?, ?);" (
-			encode $ info ^. infoDepends,
-			fmap display $ info ^. infoLanguage,
-			encode $ map display $ info ^. infoExtensions,
-			encode $ info ^. infoGHCOptions,
-			encode $ info ^.. infoSourceDirs . each . path,
-			encode $ info ^. infoOtherModules)
-	lastRow
-
-removeModuleContents :: SessionMonad m => Int -> m ()
-removeModuleContents mid = scope "remove-module-contents" $ do
-	execute "delete from imports where module_id = ?;" (Only mid)
-	execute "delete from exports where module_id = ?;" (Only mid)
-	execute "delete from scopes where module_id = ?;" (Only mid)
-	execute "delete from names where module_id = ?;" (Only mid)
-	execute "delete from types where module_id = ?;" (Only mid)
-	execute "delete from symbols where module_id = ?;" (Only mid)
-
-removeModule :: SessionMonad m => Int -> m ()
-removeModule mid = scope "remove-module" $ do
-	removeModuleContents mid
-	execute "delete from modules where id == ?;" (Only mid)
-
-upsertModules :: SessionMonad m => [InspectedModule] -> m [Int]
-upsertModules ims = scope "upsert-modules" $ bracket_ initTemp removeTemp $ do
-	executeMany "insert into upserted_modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ map moduleData ims
-	execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location));"
-	execute_ "insert or replace into modules (id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is not null;"
-	execute_ "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is null;"
-	execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location)) where id is null;"
-
-	liftM (map fromOnly) $ query_ "select id from upserted_modules order by rowid;"
-	where
-		initTemp :: SessionMonad m => m ()
-		initTemp = do
-			execute_ "create temporary table upserted_modules as select * from modules where 0;"
-			execute_ "create index upserted_modules_id_index on upserted_modules (id);"
-
-		removeTemp :: SessionMonad m => m ()
-		removeTemp = execute_ "drop table if exists upserted_modules;"
-
-		moduleData im = (
-			im ^? inspectedKey . moduleFile . path,
-			im ^? inspectedKey . moduleProject . _Just . projectCabal,
-			fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs),
-			im ^? inspectedKey . modulePackage . packageName,
-			im ^? inspectedKey . modulePackage . packageVersion,
-			im ^? inspectedKey . installedModuleName,
-			im ^? inspectedKey . installedModuleExposed,
-			im ^? inspectedKey . otherLocationName)
-			:. (
-			msum [im ^? inspected . moduleId . moduleName, im ^? inspectedKey . installedModuleName],
-			im ^? inspected . moduleDocs,
-			fmap encode $ im ^? inspected . moduleFixities,
-			encode $ asDict $ im ^. inspectionTags,
-			fmap show $ im ^? inspectionResult . _Left)
-			:.
-			fromMaybe InspectionNone (im ^? inspection)
-		asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags]
-
-lookupModuleLocation :: SessionMonad m => ModuleLocation -> m (Maybe Int)
-lookupModuleLocation m = do
-	mids <- queryNamed "select id from modules where (file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location);" [
-		":file" := m ^? moduleFile . path,
-		":package_name" := m ^? modulePackage . packageName,
-		":package_version" := m ^? modulePackage . packageVersion,
-		":installed_name" := m ^? installedModuleName,
-		":other_location" := m ^? otherLocationName]
-	when (length mids > 1) $ sendLog Warning  $ "different modules with location: {}" ~~ Display.display m
-	return $ listToMaybe [mid | Only mid <- mids]
-
-lookupModule :: SessionMonad m => ModuleId -> m (Maybe Int)
-lookupModule m = do
-	mids <- queryNamed "select id from modules where ((name is null and :name is null) or name = :name) and ((file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location));" [
-		":name" := m ^. moduleName,
-		":file" := m ^? moduleLocation . moduleFile . path,
-		":package_name" := m ^? moduleLocation . modulePackage . packageName,
-		":package_version" := m ^? moduleLocation . modulePackage . packageVersion,
-		":installed_name" := m ^? moduleLocation . installedModuleName,
-		":other_location" := m ^? moduleLocation . otherLocationName]
-	when (length mids > 1) $ sendLog Warning  $ "different modules with same name and location: {}" ~~ (m ^. moduleName)
-	return $ listToMaybe [mid | Only mid <- mids]
-
-lookupSymbol :: SessionMonad m => Int -> SymbolId -> m (Maybe Int)
-lookupSymbol mid sym = do
-	sids <- query "select id from symbols where name == ? and module_id == ?;" (
-		sym ^. symbolName,
-		mid)
-	when (length sids > 1) $ sendLog Warning $ "different symbols with same module id: {}.{}" ~~ show mid ~~ (sym ^. symbolName)
-	return $ listToMaybe [sid | Only sid <- sids]
-
-lastRow :: SessionMonad m => m Int
-lastRow = do
-	[Only i] <- query_ "select last_insert_rowid();"
-	return i
-
-loadModule :: SessionMonad m => Int -> m Module
-loadModule mid = scope "load-module" $ do
-	ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int))
-		(toQuery $ mconcat [
-			qModuleId,
-			select_ ["mu.docs", "mu.fixities", "mu.id"],
-			where_ [fromString "mu.id == ?"]])
-		(Only mid)
-	case ms of
-		[] -> sqlFailure $ "module with id {} not found" ~~ mid
-		mods@((mid' :. (mdocs, mfixities, _)):_) -> do
-			when (length mods > 1) $ sendLog Warning $ "multiple modules with same id = {} found" ~~ mid
-			syms <- query @_ @Symbol
-				(toQuery $ mconcat [
-					qSymbol,
-					from_ ["exports as e"],
-					where_ ["e.module_id == ?", "e.symbol_id == s.id"]])
-				(Only mid)
-			imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid)
-			return Module {
-				_moduleId = mid',
-				_moduleDocs = mdocs,
-				_moduleImports = imps,
-				_moduleExports = syms,
-				_moduleFixities = fromMaybe [] (mfixities >>= fromJSON'),
-				_moduleScope = mempty,
-				_moduleSource = Nothing }
-
-loadModules :: (SessionMonad m, ToRow q) => String -> q -> m [Module]
-loadModules selectExpr args = scope "load-modules" $ do
-	ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int))
-		(toQuery $ mconcat [
-			qModuleId,
-			select_ ["mu.docs", "mu.fixities", "mu.id"],
-			where_ [fromString $ "mu.id in (" ++ selectExpr ++ ")"]])
-		args
-	forM ms $ \(mid' :. (mdocs, mfixities, mid)) -> do
-		syms <- query @_ @Symbol
-			(toQuery $ mconcat [
-				qSymbol,
-				from_ ["exports as e"],
-				where_ ["e.module_id == ?", "e.symbol_id == s.id"]])
-			(Only mid)
-		imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid)
-		return Module {
-			_moduleId = mid',
-			_moduleDocs = mdocs,
-			_moduleImports = imps,
-			_moduleExports = syms,
-			_moduleFixities = fromMaybe [] (mfixities >>= fromJSON'),
-			_moduleScope = mempty,
-			_moduleSource = Nothing }
-
-loadProject :: SessionMonad m => Path -> m Project
-loadProject cabal = scope "load-project" $ do
-	projs <- query @_ @(Only Int :. Project) "select id, name, cabal, version, build_tool, package_db_stack from projects where cabal == ?;" (Only $ view path cabal)
-	(Only pid :. proj) <- case projs of
-		[] -> sqlFailure $ "project with cabal {} not found" ~~ view path cabal
-		_ -> do
-			when (length projs > 1) $ sendLog Warning $ "multiple projects with same cabal = {} found" ~~ view path cabal
-			return $ head projs
-
-	libs <- query
-		(toQuery $ mconcat [
-			select_ ["lib.modules"],
-			from_ ["libraries as lib"],
-			qBuildInfo,
-			where_ [
-				"lib.build_info_id == bi.id",
-				"lib.project_id == ?"]])
-			(Only pid)
-
-	exes <- query
-		(toQuery $ mconcat [
-			select_ ["exe.name", "exe.path"],
-			from_ ["executables as exe"],
-			qBuildInfo,
-			where_ [
-				"exe.build_info_id == bi.id",
-				"exe.project_id == ?"]])
-			(Only pid)
-
-	tests <- query
-		(toQuery $ mconcat [
-			select_ ["tst.name", "tst.enabled", "tst.main"],
-			from_ ["tests as tst"],
-			qBuildInfo,
-			where_ [
-				"tst.build_info_id == bi.id",
-				"tst.project_id == ?"]])
-			(Only pid)
-
-	return $
-		set (projectDescription . _Just . projectLibrary) (listToMaybe libs) .
-		set (projectDescription . _Just . projectExecutables) exes .
-		set (projectDescription . _Just . projectTests) tests $
-		proj
-
--- | Update a bunch of modules
-updateModules :: SessionMonad m => [InspectedModule] -> m ()
-updateModules ims = scope "update-modules" $ do
-	ids <- upsertModules ims
-	updateModulesSymbols $ zip ids ims
-
--- | Update symbols of bunch of modules
-updateModulesSymbols :: SessionMonad m => [(Int, InspectedModule)] -> m ()
-updateModulesSymbols ims = scope "update-modules" $ timer "updated modules" $ bracket_ initTemps dropTemps $ do
-	initUpdatedIds ims
-
-	removeModulesContents
-	transaction_ Immediate $ insertModulesDefs ims
-	transaction_ Immediate $ insertModulesExports ims
-	where
-		initTemps :: SessionMonad m => m ()
-		initTemps = execute_ "create temporary table updated_ids (id integer not null, cabal text, module text not null, only_header int not null, dirty int not null);"
-
-		dropTemps :: SessionMonad m => m ()
-		dropTemps = execute_ "drop table if exists updated_ids;" 
-
-		initUpdatedIds :: SessionMonad m => [(Int, InspectedModule)] -> m ()
-		initUpdatedIds imods = transaction_ Immediate $ do
-			execute_ "create unique index updated_ids_id_index on updated_ids (id);"
-			execute_ "create index updated_ids_module_index on updated_ids (module);"
-			executeMany "insert into updated_ids (id, cabal, module, only_header, dirty) values (?, ?, ?, ?, ?);" $ do
-				(mid, im) <- imods
-				return (
-					mid,
-					im ^? inspectedKey . moduleProject . _Just . projectCabal,
-					im ^?! inspected . moduleId . moduleName,
-					hasTag OnlyHeaderTag im,
-					hasTag DirtyTag im)
-
-		removeModulesContents :: SessionMonad m => m ()
-		removeModulesContents = scope "remove-modules-contents" $ do
-			transaction_ Immediate $ do
-				execute_ "delete from symbols where module_id in (select id from updated_ids where not only_header or not dirty);"
-				execute_ "update symbols set line = null, column = null where module_id in (select id from updated_ids where only_header and dirty);"
-				execute_ "delete from imports where module_id in (select id from updated_ids);"
-				execute_ "delete from exports where module_id in (select id from updated_ids);"
-
-			transaction_ Immediate $ execute_ "delete from scopes where module_id in (select id from updated_ids);"
-			transaction_ Immediate $ execute_ "delete from names where module_id in (select id from updated_ids);"
-			transaction_ Immediate $ execute_ "delete from types where module_id in (select id from updated_ids);"
-
-		insertModulesDefs :: SessionMonad m => [(Int, InspectedModule)] -> m ()
-		insertModulesDefs imods = executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do
-			(mid, im) <- imods
-			m <- im ^.. inspected
-			sym <- m ^. moduleExports
-			guard (sym ^. symbolId . symbolModule == m ^. moduleId)
-			return $ (
-				sym ^. symbolId . symbolName,
-				mid,
-				sym ^. symbolDocs,
-				sym ^? symbolPosition . _Just . positionLine,
-				sym ^? symbolPosition . _Just . positionColumn)
-				:. (sym ^. symbolInfo)
-
-		insertModulesExports :: SessionMonad m => [(Int, InspectedModule)] -> m ()
-		insertModulesExports imods = executeMany "insert into exports (module_id, symbol_id) select ?, s.id from modules as m, symbols as s where ((? = m.file) or (? = m.package_name and ? = m.package_version and ? = m.installed_name) or (? = m.other_location)) and s.module_id = m.id and ? = s.name and ? = s.what;" $ do
-			(mid, im) <- imods
-			m <- im ^.. inspected
-			sym <- m ^. moduleExports
-			return $
-				(Only mid) :.
-				mkLocationId (sym ^. symbolId . symbolModule) :.
-				(sym ^. symbolId . symbolName, symbolType sym)
-
-		mkLocationId m' = (
-			m' ^? moduleLocation . moduleFile,
-			m' ^? moduleLocation . modulePackage . packageName,
-			m' ^? moduleLocation . modulePackage . packageVersion,
-			m' ^? moduleLocation . installedModuleName,
-			m' ^? moduleLocation . otherLocationName)
-
-
-escapeLike :: Text -> Text
-escapeLike = T.replace "%" "\\%" . T.replace "_" "\\_" . T.replace "\\" "\\\\"
-
--- Util
-
-sqlFailure :: SessionMonad m => Text -> m a
-sqlFailure msg = do
-	sendLog Error msg
-	hsdevError $ SQLiteError $ T.unpack msg
-
-lookupId :: SessionMonad m => ModuleLocation -> m Int
-lookupId = lookupModuleLocation >=> maybe err return where
-	err = hsdevError $ SQLiteError "module not exist in db"
+{-# LANGUAGE OverloadedStrings, TypeOperators, TypeApplications #-}++module HsDev.Database.SQLite (+	initialize, purge,+	privateMemory, sharedMemory,+	query, query_, queryNamed, execute, execute_, executeMany, executeNamed,+	withTemporaryTable,+	updatePackageDb, removePackageDb, insertPackageDb,+	updateProject, removeProject, insertProject, insertBuildInfo,+	removeModuleContents, removeModule,+	lookupModuleLocation, lookupModule,+	lookupSymbol,+	lastRow,++	loadModule, loadModules,+	loadProject,++	updateModules, upsertModules,++	-- * Utils+	lookupId,+	escapeLike,++	-- * Reexports+	module Database.SQLite.Simple,+	module HsDev.Database.SQLite.Select,+	module HsDev.Database.SQLite.Instances,+	module HsDev.Database.SQLite.Transaction+	) where++import Control.Lens hiding ((.=))+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Aeson hiding (Error)+import Data.List (intercalate)+import Data.Maybe+import Data.String+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Database.SQLite.Simple hiding (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)+import qualified Database.SQLite.Simple as SQL (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)+import Distribution.Text (display)+import Language.Haskell.Extension ()+import System.Directory+import System.Log.Simple+import Text.Format++import System.Directory.Paths++import HsDev.Database.SQLite.Instances+import HsDev.Database.SQLite.Schema+import HsDev.Database.SQLite.Select+import HsDev.Database.SQLite.Transaction+import qualified HsDev.Display as Display+import HsDev.Error+import HsDev.PackageDb.Types+import HsDev.Project.Types+import HsDev.Symbols (hasTag)+import HsDev.Symbols.Types hiding (loadProject)+import HsDev.Server.Types+import HsDev.Util++-- | Open new connection and set some pragmas+new :: String -> IO Connection+new p = do+	conn <- open p+	SQL.execute_ conn "pragma case_sensitive_like = true;"+	SQL.execute_ conn "pragma synchronous = off;"+	SQL.execute_ conn "pragma journal_mode = memory;"+	return conn++-- | Initialize database+initialize :: String -> IO Connection+initialize p = do+	conn <- new p+	[Only hasTables] <- SQL.query_ conn "select count(*) > 0 from sqlite_master where type == 'table';"+	goodVersion <- if hasTables+		then do+			[Only equalVersion] <- SQL.query conn "select sum(json(value) == json(?)) > 0 from hsdev where option == 'version';" (Only $ toJSON version)+			return equalVersion+		else return True+	let+		start+			| not goodVersion = do+					close conn+					removeFile p+					conn' <- new p+					initDb conn'+			| not hasTables = initDb conn+			| otherwise = return conn+		initDb conn' = SQL.withTransaction conn' $ do+			mapM_ (SQL.execute_ conn') commands+			SQL.execute @(Text, Value) conn' "insert into hsdev values (?, ?);" ("version", toJSON version)+			return conn'+	start++purge :: SessionMonad m => m ()+purge = do+	tables <- query_ @(Only String) "select name from sqlite_master where type == 'table';"+	forM_ tables $ \(Only table) ->+		execute_ $ fromString $ "delete from {};" ~~ table++-- | Private memory for db+privateMemory :: String+privateMemory = ":memory:"++-- | Shared db in memory+sharedMemory :: String+sharedMemory = "file::memory:?cache=shared"++-- | Retries for simple queries+retried :: (MonadIO m, MonadCatch m) => m a -> m a+retried = retry def++query :: (ToRow q, FromRow r, SessionMonad m) => Query -> q -> m [r]+query q' params = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.query conn q' params++query_ :: (FromRow r, SessionMonad m) => Query -> m [r]+query_ q' = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.query_ conn q'++queryNamed :: (FromRow r, SessionMonad m) => Query -> [NamedParam] -> m [r]+queryNamed q' ps' = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.queryNamed conn q' ps'++execute :: (ToRow q, SessionMonad m) => Query -> q -> m ()+execute q' params = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.execute conn q' params++execute_ :: SessionMonad m => Query -> m ()+execute_ q' = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.execute_ conn q'++executeMany :: (ToRow q, SessionMonad m) => Query -> [q] -> m ()+executeMany q' params = do+	conn <- serverSqlDatabase+	liftIO $ SQL.executeMany conn q' params++executeNamed :: SessionMonad m => Query -> [NamedParam] -> m ()+executeNamed q' ps' = do+	conn <- serverSqlDatabase+	liftIO $ SQL.executeNamed conn q' ps'++withTemporaryTable :: SessionMonad m => String -> [String] -> m a -> m a+withTemporaryTable tableName columns = bracket_ createTable dropTable where+	createTable = execute_ $ fromString $ "create temporary table {} ({});" ~~ tableName ~~ (intercalate ", " columns)+	dropTable = execute_ $ fromString $ "drop table {};" ~~ tableName++updatePackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()+updatePackageDb pdb pkgs = scope "update-package-db" $ transaction_ Immediate $ do+	sendLog Trace $ "update package-db: {}" ~~ Display.display pdb+	removePackageDb pdb+	insertPackageDb pdb pkgs++removePackageDb :: SessionMonad m => PackageDb -> m ()+removePackageDb pdb = scope "remove-package-db" $+	execute "delete from package_dbs where package_db == ?;" (Only pdb)++insertPackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()+insertPackageDb pdb pkgs = scope "insert-package-db" $ forM_ pkgs $ \pkg ->+	execute+		"insert into package_dbs (package_db, package_name, package_version) values (?, ?, ?);"+		(pdb, pkg ^. packageName, pkg ^. packageVersion)++updateProject :: SessionMonad m => Project -> m ()+updateProject proj = scope "update-project" $ transaction_ Immediate $ do+	sendLog Trace $ "update project: {}" ~~ Display.display proj+	removeProject proj+	insertProject proj++removeProject :: SessionMonad m => Project -> m ()+removeProject proj = scope "remove-project" $ do+	projId <- query @_ @(Only Int) "select id from projects where cabal == ?;" (Only $ proj ^. projectCabal)+	case projId of+		[] -> return ()+		pids -> do+			when (length pids > 1) $+				sendLog Warning $ "multiple projects for cabal {} found" ~~ (proj ^. projectCabal)+			forM_ pids $ \pid -> do+				bids <- query @_ @(Only Int) "select build_info_id from targets where project_id == ?;" pid+				execute "delete from projects where id == ?;" pid+				execute "delete from libraries where project_id == ?;" pid+				execute "delete from executables where project_id == ?;" pid+				execute "delete from tests where project_id == ?;" pid+				forM_ bids $ \bid -> execute "delete from build_infos where id == ?;" bid++insertProject :: SessionMonad m => Project -> m ()+insertProject proj = scope "insert-project" $ do+	execute "insert into projects (name, cabal, version, build_tool, package_db_stack) values (?, ?, ?, ?, ?);" proj+	projId <- lastRow++	forM_ (proj ^? projectDescription . _Just . projectLibrary . _Just) $ \lib -> do+		buildInfoId <- insertBuildInfo $ lib ^. libraryBuildInfo+		execute "insert into libraries (project_id, modules, build_info_id) values (?, ?, ?);"+			(projId, encode $ lib ^. libraryModules, buildInfoId)++	forM_ (proj ^.. projectDescription . _Just . projectExecutables . each) $ \exe -> do+		buildInfoId <- insertBuildInfo $ exe ^. executableBuildInfo+		execute "insert into executables (project_id, name, path, build_info_id) values (?, ?, ?, ?);"+			(projId, exe ^. executableName, exe ^. executablePath . path, buildInfoId)++	forM_ (proj ^.. projectDescription . _Just . projectTests . each) $ \test -> do+		buildInfoId <- insertBuildInfo $ test ^. testBuildInfo+		execute "insert into tests (project_id, name, enabled, main, build_info_id) values (?, ?, ?, ?, ?);"+			(projId, test ^. testName, test ^. testEnabled, test ^? testMain . _Just . path, buildInfoId)++insertBuildInfo :: SessionMonad m => Info -> m Int+insertBuildInfo info = scope "insert-build-info" $ do+	execute "insert into build_infos (depends, language, extensions, ghc_options, source_dirs, other_modules) values (?, ?, ?, ?, ?, ?);" (+			encode $ info ^. infoDepends,+			fmap display $ info ^. infoLanguage,+			encode $ map display $ info ^. infoExtensions,+			encode $ info ^. infoGHCOptions,+			encode $ info ^.. infoSourceDirs . each . path,+			encode $ info ^. infoOtherModules)+	lastRow++removeModuleContents :: SessionMonad m => Int -> m ()+removeModuleContents mid = scope "remove-module-contents" $ do+	execute "delete from imports where module_id = ?;" (Only mid)+	execute "delete from exports where module_id = ?;" (Only mid)+	execute "delete from scopes where module_id = ?;" (Only mid)+	execute "delete from names where module_id = ?;" (Only mid)+	execute "delete from types where module_id = ?;" (Only mid)+	execute "delete from symbols where module_id = ?;" (Only mid)++removeModule :: SessionMonad m => Int -> m ()+removeModule mid = scope "remove-module" $ do+	removeModuleContents mid+	execute "delete from modules where id == ?;" (Only mid)++upsertModules :: SessionMonad m => [InspectedModule] -> m [Int]+upsertModules ims = scope "upsert-modules" $ bracket_ initTemp removeTemp $ do+	executeMany "insert into upserted_modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ map moduleData ims+	execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location));"+	execute_ "insert or replace into modules (id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is not null;"+	execute_ "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is null;"+	execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location)) where id is null;"++	liftM (map fromOnly) $ query_ "select id from upserted_modules order by rowid;"+	where+		initTemp :: SessionMonad m => m ()+		initTemp = do+			execute_ "create temporary table upserted_modules as select * from modules where 0;"+			execute_ "create index upserted_modules_id_index on upserted_modules (id);"++		removeTemp :: SessionMonad m => m ()+		removeTemp = execute_ "drop table if exists upserted_modules;"++		moduleData im = (+			im ^? inspectedKey . moduleFile . path,+			im ^? inspectedKey . moduleProject . _Just . projectCabal,+			fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs),+			im ^? inspectedKey . modulePackage . packageName,+			im ^? inspectedKey . modulePackage . packageVersion,+			im ^? inspectedKey . installedModuleName,+			im ^? inspectedKey . installedModuleExposed,+			im ^? inspectedKey . otherLocationName)+			:. (+			msum [im ^? inspected . moduleId . moduleName, im ^? inspectedKey . installedModuleName],+			im ^? inspected . moduleDocs,+			fmap encode $ im ^? inspected . moduleFixities,+			encode $ asDict $ im ^. inspectionTags,+			fmap show $ im ^? inspectionResult . _Left)+			:.+			fromMaybe InspectionNone (im ^? inspection)+		asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags]++lookupModuleLocation :: SessionMonad m => ModuleLocation -> m (Maybe Int)+lookupModuleLocation m = do+	mids <- queryNamed "select id from modules where (file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location);" [+		":file" := m ^? moduleFile . path,+		":package_name" := m ^? modulePackage . packageName,+		":package_version" := m ^? modulePackage . packageVersion,+		":installed_name" := m ^? installedModuleName,+		":other_location" := m ^? otherLocationName]+	when (length mids > 1) $ sendLog Warning  $ "different modules with location: {}" ~~ Display.display m+	return $ listToMaybe [mid | Only mid <- mids]++lookupModule :: SessionMonad m => ModuleId -> m (Maybe Int)+lookupModule m = do+	mids <- queryNamed "select id from modules where ((name is null and :name is null) or name = :name) and ((file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location));" [+		":name" := m ^. moduleName,+		":file" := m ^? moduleLocation . moduleFile . path,+		":package_name" := m ^? moduleLocation . modulePackage . packageName,+		":package_version" := m ^? moduleLocation . modulePackage . packageVersion,+		":installed_name" := m ^? moduleLocation . installedModuleName,+		":other_location" := m ^? moduleLocation . otherLocationName]+	when (length mids > 1) $ sendLog Warning  $ "different modules with same name and location: {}" ~~ (m ^. moduleName)+	return $ listToMaybe [mid | Only mid <- mids]++lookupSymbol :: SessionMonad m => Int -> SymbolId -> m (Maybe Int)+lookupSymbol mid sym = do+	sids <- query "select id from symbols where name == ? and module_id == ?;" (+		sym ^. symbolName,+		mid)+	when (length sids > 1) $ sendLog Warning $ "different symbols with same module id: {}.{}" ~~ show mid ~~ (sym ^. symbolName)+	return $ listToMaybe [sid | Only sid <- sids]++lastRow :: SessionMonad m => m Int+lastRow = do+	[Only i] <- query_ "select last_insert_rowid();"+	return i++loadModule :: SessionMonad m => Int -> m Module+loadModule mid = scope "load-module" $ do+	ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int))+		(toQuery $ mconcat [+			qModuleId,+			select_ ["mu.docs", "mu.fixities", "mu.id"],+			where_ [fromString "mu.id == ?"]])+		(Only mid)+	case ms of+		[] -> sqlFailure $ "module with id {} not found" ~~ mid+		mods@((mid' :. (mdocs, mfixities, _)):_) -> do+			when (length mods > 1) $ sendLog Warning $ "multiple modules with same id = {} found" ~~ mid+			syms <- query @_ @Symbol+				(toQuery $ mconcat [+					qSymbol,+					from_ ["exports as e"],+					where_ ["e.module_id == ?", "e.symbol_id == s.id"]])+				(Only mid)+			imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid)+			return Module {+				_moduleId = mid',+				_moduleDocs = mdocs,+				_moduleImports = imps,+				_moduleExports = syms,+				_moduleFixities = fromMaybe [] (mfixities >>= fromJSON'),+				_moduleScope = mempty,+				_moduleSource = Nothing }++loadModules :: (SessionMonad m, ToRow q) => String -> q -> m [Module]+loadModules selectExpr args = scope "load-modules" $ do+	ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int))+		(toQuery $ mconcat [+			qModuleId,+			select_ ["mu.docs", "mu.fixities", "mu.id"],+			where_ [fromString $ "mu.id in (" ++ selectExpr ++ ")"]])+		args+	forM ms $ \(mid' :. (mdocs, mfixities, mid)) -> do+		syms <- query @_ @Symbol+			(toQuery $ mconcat [+				qSymbol,+				from_ ["exports as e"],+				where_ ["e.module_id == ?", "e.symbol_id == s.id"]])+			(Only mid)+		imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid)+		return Module {+			_moduleId = mid',+			_moduleDocs = mdocs,+			_moduleImports = imps,+			_moduleExports = syms,+			_moduleFixities = fromMaybe [] (mfixities >>= fromJSON'),+			_moduleScope = mempty,+			_moduleSource = Nothing }++loadProject :: SessionMonad m => Path -> m Project+loadProject cabal = scope "load-project" $ do+	projs <- query @_ @(Only Int :. Project) "select id, name, cabal, version, build_tool, package_db_stack from projects where cabal == ?;" (Only $ view path cabal)+	(Only pid :. proj) <- case projs of+		[] -> sqlFailure $ "project with cabal {} not found" ~~ view path cabal+		_ -> do+			when (length projs > 1) $ sendLog Warning $ "multiple projects with same cabal = {} found" ~~ view path cabal+			return $ head projs++	libs <- query+		(toQuery $ mconcat [+			select_ ["lib.modules"],+			from_ ["libraries as lib"],+			qBuildInfo,+			where_ [+				"lib.build_info_id == bi.id",+				"lib.project_id == ?"]])+			(Only pid)++	exes <- query+		(toQuery $ mconcat [+			select_ ["exe.name", "exe.path"],+			from_ ["executables as exe"],+			qBuildInfo,+			where_ [+				"exe.build_info_id == bi.id",+				"exe.project_id == ?"]])+			(Only pid)++	tests <- query+		(toQuery $ mconcat [+			select_ ["tst.name", "tst.enabled", "tst.main"],+			from_ ["tests as tst"],+			qBuildInfo,+			where_ [+				"tst.build_info_id == bi.id",+				"tst.project_id == ?"]])+			(Only pid)++	return $+		set (projectDescription . _Just . projectLibrary) (listToMaybe libs) .+		set (projectDescription . _Just . projectExecutables) exes .+		set (projectDescription . _Just . projectTests) tests $+		proj++-- | Update a bunch of modules+updateModules :: SessionMonad m => [InspectedModule] -> m ()+updateModules ims = scope "update-modules" $ do+	ids <- upsertModules ims+	updateModulesSymbols $ zip ids ims++-- | Update symbols of bunch of modules+updateModulesSymbols :: SessionMonad m => [(Int, InspectedModule)] -> m ()+updateModulesSymbols ims = scope "update-modules" $ timer "updated modules" $ bracket_ initTemps dropTemps $ do+	initUpdatedIds ims++	removeModulesContents+	transaction_ Immediate $ insertModulesDefs ims+	transaction_ Immediate $ insertModulesExports ims+	where+		initTemps :: SessionMonad m => m ()+		initTemps = execute_ "create temporary table updated_ids (id integer not null, cabal text, module text not null, only_header int not null, dirty int not null);"++		dropTemps :: SessionMonad m => m ()+		dropTemps = execute_ "drop table if exists updated_ids;" ++		initUpdatedIds :: SessionMonad m => [(Int, InspectedModule)] -> m ()+		initUpdatedIds imods = transaction_ Immediate $ do+			execute_ "create unique index updated_ids_id_index on updated_ids (id);"+			execute_ "create index updated_ids_module_index on updated_ids (module);"+			executeMany "insert into updated_ids (id, cabal, module, only_header, dirty) values (?, ?, ?, ?, ?);" $ do+				(mid, im) <- imods+				return (+					mid,+					im ^? inspectedKey . moduleProject . _Just . projectCabal,+					im ^?! inspected . moduleId . moduleName,+					hasTag OnlyHeaderTag im,+					hasTag DirtyTag im)++		removeModulesContents :: SessionMonad m => m ()+		removeModulesContents = scope "remove-modules-contents" $ do+			transaction_ Immediate $ do+				execute_ "delete from symbols where module_id in (select id from updated_ids where not only_header or not dirty);"+				execute_ "update symbols set line = null, column = null where module_id in (select id from updated_ids where only_header and dirty);"+				execute_ "delete from imports where module_id in (select id from updated_ids);"+				execute_ "delete from exports where module_id in (select id from updated_ids);"++			transaction_ Immediate $ execute_ "delete from scopes where module_id in (select id from updated_ids);"+			transaction_ Immediate $ execute_ "delete from names where module_id in (select id from updated_ids);"+			transaction_ Immediate $ execute_ "delete from types where module_id in (select id from updated_ids);"++		insertModulesDefs :: SessionMonad m => [(Int, InspectedModule)] -> m ()+		insertModulesDefs imods = executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do+			(mid, im) <- imods+			m <- im ^.. inspected+			sym <- m ^. moduleExports+			guard (sym ^. symbolId . symbolModule == m ^. moduleId)+			return $ (+				sym ^. symbolId . symbolName,+				mid,+				sym ^. symbolDocs,+				sym ^? symbolPosition . _Just . positionLine,+				sym ^? symbolPosition . _Just . positionColumn)+				:. (sym ^. symbolInfo)++		insertModulesExports :: SessionMonad m => [(Int, InspectedModule)] -> m ()+		insertModulesExports imods = executeMany "insert into exports (module_id, symbol_id) select ?, s.id from modules as m, symbols as s where ((? = m.file) or (? = m.package_name and ? = m.package_version and ? = m.installed_name) or (? = m.other_location)) and s.module_id = m.id and ? = s.name and ? = s.what;" $ do+			(mid, im) <- imods+			m <- im ^.. inspected+			sym <- m ^. moduleExports+			return $+				(Only mid) :.+				mkLocationId (sym ^. symbolId . symbolModule) :.+				(sym ^. symbolId . symbolName, symbolType sym)++		mkLocationId m' = (+			m' ^? moduleLocation . moduleFile,+			m' ^? moduleLocation . modulePackage . packageName,+			m' ^? moduleLocation . modulePackage . packageVersion,+			m' ^? moduleLocation . installedModuleName,+			m' ^? moduleLocation . otherLocationName)+++escapeLike :: Text -> Text+escapeLike = T.replace "%" "\\%" . T.replace "_" "\\_" . T.replace "\\" "\\\\"++-- Util++sqlFailure :: SessionMonad m => Text -> m a+sqlFailure msg = do+	sendLog Error msg+	hsdevError $ SQLiteError $ T.unpack msg++lookupId :: SessionMonad m => ModuleLocation -> m Int+lookupId = lookupModuleLocation >=> maybe err return where+	err = hsdevError $ SQLiteError "module not exist in db"

@@ -1,370 +1,370 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeApplications #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module HsDev.Database.SQLite.Instances (
-	JSON(..)
-	) where
-
-import Control.Lens ((^.), (^?), _Just)
-import Data.Aeson as A hiding (Error)
-import Data.Maybe
-import Data.Foldable
-import Data.Time.Clock.POSIX
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.ByteString.Lazy as L
-import Database.SQLite.Simple
-import Database.SQLite.Simple.ToField
-import Database.SQLite.Simple.FromField
-import Language.Haskell.Extension
-import qualified Language.Haskell.Names as N
-import qualified Language.Haskell.Exts as H
-import Text.Format
-
-import System.Directory.Paths
-import HsDev.Display
-import HsDev.Symbols.Name
-import HsDev.Symbols.Location
-import HsDev.Symbols.Types
-import HsDev.Tools.Ghc.Types
-import HsDev.Tools.Types
-import HsDev.Util
-
-instance ToField Value where
-	toField = SQLBlob . L.toStrict . encode
-
-instance FromField Value where
-	fromField fld = case fieldData fld of
-		SQLText s -> either fail return . eitherDecode . L.fromStrict . T.encodeUtf8 $ s
-		SQLBlob s -> either fail return . eitherDecode . L.fromStrict $ s
-		_ -> fail "invalid json field type"
-
-newtype JSON a = JSON { getJSON :: a }
-	deriving (Eq, Ord, Read, Show)
-
-instance ToJSON a => ToField (JSON a) where
-	toField = SQLBlob . L.toStrict . encode . getJSON
-
-instance FromJSON a => FromField (JSON a) where
-	fromField fld = case fieldData fld of
-		SQLText s -> either fail (return . JSON) . eitherDecode . L.fromStrict . T.encodeUtf8 $ s
-		SQLBlob s -> either fail (return . JSON) . eitherDecode . L.fromStrict $ s
-		_ -> fail "invalid json field type"
-
-instance FromRow Position where
-	fromRow = Position <$> field <*> field
-
-instance ToRow Position where
-	toRow (Position l c) = [toField l, toField c]
-
-instance FromRow Region where
-	fromRow = Region <$> fromRow <*> fromRow
-
-instance ToRow Region where
-	toRow (Region f t) = toRow f ++ toRow t
-
-instance FromRow ModulePackage where
-	fromRow = ModulePackage <$> field <*> (fromMaybe T.empty <$> field)
-
-instance ToRow ModulePackage where
-	toRow (ModulePackage name ver) = [toField name, toField ver]
-
-instance FromRow ModuleLocation where
-	fromRow = do
-		file <- field
-		cabal <- field
-		dirs <- field
-		pname <- field
-		pver <- field
-		iname <- field
-		iexposed <- field
-		other <- field
-
-		maybe mzero return $ msum [
-			FileModule <$> file <*> pure (project <$> cabal),
-			InstalledModule <$> maybe (pure []) fromJSON' dirs <*> (ModulePackage <$> pname <*> pver) <*> iname <*> iexposed,
-			OtherLocation <$> other,
-			pure NoLocation]
-
-instance ToRow ModuleLocation where
-	toRow mloc = [
-		toField $ mloc ^? moduleFile,
-		toField $ mloc ^? moduleProject . _Just . projectCabal,
-		toField $ fmap toJSON $ mloc ^? moduleInstallDirs,
-		toField $ mloc ^? modulePackage . packageName,
-		toField $ mloc ^? modulePackage . packageVersion,
-		toField $ mloc ^? installedModuleName,
-		toField $ mloc ^? installedModuleExposed,
-		toField $ mloc ^? otherLocationName]
-
-instance FromRow ModuleId where
-	fromRow = ModuleId <$> field <*> fromRow
-
-instance ToRow ModuleId where
-	toRow mid = toField (mid ^. moduleName) : toRow (mid ^. moduleLocation)
-
-instance FromRow Import where
-	fromRow = Import <$> fromRow <*> field <*> field <*> field
-
-instance ToRow Import where
-	toRow (Import p n q a) = toRow p ++ [toField n, toField q, toField a]
-
-instance FromRow SymbolId where
-	fromRow = SymbolId <$> field <*> fromRow
-
-instance ToRow SymbolId where
-	toRow (SymbolId nm mid) = toField nm : toRow mid
-
-instance FromRow SymbolInfo where
-	fromRow = do
-		what <- field @String
-		ty <- field
-		parent <- field
-		ctors <- field
-		args <- field
-		ctx <- field
-		assoc <- field
-		patTy <- field
-		patCtor <- field
-		maybe mzero return $ case what of
-			"function" -> return $ Function ty
-			"method" -> Method <$> pure ty <*> parent
-			"selector" -> Selector <$> pure ty <*> parent <*> (fromJSON' =<< ctors)
-			"ctor" -> Constructor <$> (fromJSON' =<< args) <*> parent
-			"type" -> Type <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)
-			"newtype" -> NewType <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)
-			"data" -> Data <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)
-			"class" -> Class <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)
-			"type-family" -> TypeFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc
-			"data-family" -> DataFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc
-			"pat-ctor" -> PatConstructor <$> (fromJSON' =<< args) <*> pure patTy
-			"pat-selector" -> PatSelector <$> pure ty <*> pure patTy <*> patCtor
-			_ -> Nothing
-
-instance ToRow SymbolInfo where
-	toRow si = [
-		toField $ symbolInfoType si,
-		toField $ si ^? functionType . _Just,
-		toField $ msum [si ^? parentClass, si ^? parentType],
-		toField $ toJSON $ si ^? selectorConstructors,
-		toField $ toJSON $ si ^? typeArgs,
-		toField $ toJSON $ si ^? typeContext,
-		toField $ si ^? familyAssociate . _Just,
-		toField $ si ^? patternType . _Just,
-		toField $ si ^? patternConstructor]
-
-instance FromRow Symbol where
-	fromRow = Symbol <$> fromRow <*> field <*> pos <*> fromRow where
-		pos = do
-			line <- field
-			column <- field
-			return $ Position <$> line <*> column
-
-instance ToRow Symbol where
-	toRow sym = concat [
-		toRow (sym ^. symbolId),
-		[toField $ sym ^. symbolDocs],
-		maybe [SQLNull, SQLNull] toRow (sym ^. symbolPosition),
-		toRow (sym ^. symbolInfo)]
-
-instance FromRow a => FromRow (Scoped a) where
-	fromRow = flip Scoped <$> fromRow <*> field
-
-instance ToRow a => ToRow (Scoped a) where
-	toRow (Scoped q s) = toRow s ++ [toField q]
-
-instance ToField BuildTool where
-	toField CabalTool = toField @String "cabal"
-	toField StackTool = toField @String "stack"
-
-instance FromField BuildTool where
-	fromField = fromField @String >=> fromStr where
-		fromStr "cabal" = return CabalTool
-		fromStr "stack" = return StackTool
-		fromStr _ = mzero
-
-instance ToRow Sandbox where
-	toRow (Sandbox t p) = [toField t, toField p]
-
-instance FromRow Sandbox where
-	fromRow = Sandbox <$> field <*> field
-
-instance ToRow Project where
-	toRow (Project name _ cabal pdesc t dbs) = [toField name, toField cabal, toField $ pdesc ^? _Just . projectVersion, toField t, toField dbs]
-
-instance FromRow Project where
-	fromRow = do
-		name <- field
-		cabal <- field
-		ver <- field
-		tool <- field
-		dbs <- field
-		return $ Project name (takeDir cabal) cabal (fmap (\v -> ProjectDescription v Nothing [] []) ver) tool dbs
-
-instance FromRow Library where
-	fromRow = do
-		mods <- field >>= maybe mzero return . fromJSON'
-		binfo <- fromRow
-		return $ Library mods binfo
-
-instance FromRow Executable where
-	fromRow = Executable <$> field <*> field <*> fromRow
-
-instance FromRow Test where
-	fromRow = Test <$> field <*> field <*> field <*> fromRow
-
-instance FromRow Info where
-	fromRow = Info <$>
-		(field >>= maybe mzero return . fromJSON') <*>
-		field <*>
-		(field >>= maybe mzero return . fromJSON') <*>
-		(field >>= maybe mzero return . fromJSON') <*>
-		(field >>= maybe mzero return . fromJSON') <*>
-		(field >>= maybe mzero return . fromJSON')
-
-instance FromField Language where
-	fromField fld = case fieldData fld of
-		SQLText txt -> parseDT "Language" (T.unpack txt)
-		_ -> mzero
-
-instance ToField PackageDb where
-	toField GlobalDb = toField ("global-db" :: String)
-	toField UserDb = toField ("user-db" :: String)
-	toField (PackageDb p) = toField ("package-db:" ++ T.unpack p)
-
-instance FromField PackageDb where
-	fromField fld = do
-		s <- fromField fld
-		case s of
-			"global-db" -> return GlobalDb
-			"user-db" -> return UserDb
-			_ -> case T.stripPrefix "package-db:" s of
-				Just p' -> return $ PackageDb p'
-				Nothing -> mzero
-
-instance ToField PackageDbStack where
-	toField = toField . toJSON . packageDbs
-
-instance FromField PackageDbStack where
-	fromField = fromField >=> maybe mzero (return . mkPackageDbStack) . fromJSON'
-
-instance FromRow SymbolUsage where
-	fromRow = SymbolUsage <$> fromRow <*> field <*> fromRow <*> fromRow
-
-instance FromField POSIXTime where
-	fromField = fmap (fromRational . toRational @Double) . fromField
-
-instance ToField POSIXTime where
-	toField = toField . fromRational @Double . toRational
-
-instance FromRow Inspection where
-	fromRow = do
-		tm <- field
-		opts <- field
-		case (tm, opts) of
-			(Nothing, Nothing) -> return InspectionNone
-			(_, Just opts') -> InspectionAt (fromMaybe 0 tm) <$>
-				maybe mzero return (fromJSON' opts')
-			(Just _, Nothing) -> mzero
-
-instance ToRow Inspection where
-	toRow InspectionNone = [SQLNull, SQLNull]
-	toRow (InspectionAt tm opts) = [
-		if tm == 0 then SQLNull else toField tm,
-		toField $ toJSON opts]
-
-instance FromRow TypedExpr where
-	fromRow = TypedExpr <$> field <*> field
-
-instance ToRow TypedExpr where
-	toRow (TypedExpr e t) = [toField e, toField t]
-
-instance FromField (H.Name ()) where
-	fromField = fmap toName_ . fromField
-
-instance ToField (H.Name ()) where
-	toField = toField . fromName_
-
-instance FromField (H.ModuleName ()) where
-	fromField = fmap toModuleName_ . fromField
-
-instance ToField (H.ModuleName ()) where
-	toField = toField . fromModuleName_
-
-instance FromRow N.Symbol where
-	fromRow = do
-		what <- field @T.Text
-		mname <- field
-		name <- field
-		parent <- field
-		ctors <- do
-			ctorsJson <- field
-			return $ fmap (map toName_) (ctorsJson >>= fromJSON')
-		assoc <- field
-		patType <- field
-		patCtor <- field
-		let
-			m = toModuleName_ mname
-			n = toName_ name
-		maybe mzero return $ case what of
-			"function" -> return $ N.Value m n
-			"method" -> N.Method m n <$> parent
-			"selector" -> N.Selector m n <$> parent <*> ctors
-			"ctor" -> N.Constructor m n <$> parent
-			"type" -> return $ N.Type m n
-			"newtype" -> return $ N.NewType m n
-			"data" -> return $ N.Data m n
-			"class" -> return $ N.Class m n
-			"type-family" -> return $ N.TypeFam m n assoc
-			"data-family" -> return $ N.DataFam m n assoc
-			"pat-ctor" -> return $ N.PatternConstructor m n patType
-			"pat-selector" -> N.PatternSelector m n patType <$> patCtor
-			_ -> Nothing
-
-instance ToRow N.Symbol where
-	toRow = padNulls 8 . toRow' where
-		toRow' (N.Value m n) = mk "function" [toField m, toField n]
-		toRow' (N.Method m n p) = mk "method" [toField m, toField n, toField p]
-		toRow' (N.Selector m n p cs) = mk "selector" [toField m, toField n, toField p, toField $ toJSON (map fromName_ cs)]
-		toRow' (N.Constructor m n p) = mk "ctor" [toField m, toField n, toField p]
-		toRow' (N.Type m n) = mk "type" [toField m, toField n]
-		toRow' (N.NewType m n) = mk "newtype" [toField m, toField n]
-		toRow' (N.Data m n) = mk "data" [toField m, toField n]
-		toRow' (N.Class m n) = mk "class" [toField m, toField n]
-		toRow' (N.TypeFam m n assoc) = mk "type-family" [toField m, toField n, SQLNull, SQLNull, toField assoc]
-		toRow' (N.DataFam m n assoc) = mk "data-family" [toField m, toField n, SQLNull, SQLNull, toField assoc]
-		toRow' (N.PatternConstructor m n pty) = mk "pat-ctor" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty]
-		toRow' (N.PatternSelector m n pty pctor) = mk "pat-selector" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty, toField pctor]
-
-		mk :: T.Text -> [SQLData] -> [SQLData]
-		mk what = (toField what :)
-		padNulls n fs = fs ++ replicate (n - length fs) SQLNull
-
-instance FromField Severity where
-	fromField fld = do
-		s <- fromField @String fld
-		msum [
-			guard (s == "error") >> return Error,
-			guard (s == "warning") >> return Warning,
-			guard (s == "hint") >> return Hint]
-
-instance ToField Severity where
-	toField Error = toField @String "error"
-	toField Warning = toField @String "warning"
-	toField Hint = toField @String "hint"
-
-instance FromRow OutputMessage where
-	fromRow = OutputMessage <$> field <*> field
-
-instance ToRow OutputMessage where
-	toRow (OutputMessage msg suggest) = [toField msg, toField suggest]
-
-instance FromRow a => FromRow (Note a) where
-	fromRow = Note <$> (FileModule <$> field <*> pure Nothing) <*> fromRow <*> field <*> fromRow
-
-instance ToRow a => ToRow (Note a) where
-	toRow (Note mloc rgn sev n) = concat [
-		[toField $ mloc ^? moduleFile],
-		toRow rgn,
-		[toField sev],
-		toRow n]
+{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsDev.Database.SQLite.Instances (+	JSON(..)+	) where++import Control.Lens ((^.), (^?), _Just)+import Data.Aeson as A hiding (Error)+import Data.Maybe+import Data.Foldable+import Data.Time.Clock.POSIX+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Lazy as L+import Database.SQLite.Simple+import Database.SQLite.Simple.ToField+import Database.SQLite.Simple.FromField+import Language.Haskell.Extension+import qualified Language.Haskell.Names as N+import qualified Language.Haskell.Exts as H+import Text.Format++import System.Directory.Paths+import HsDev.Display+import HsDev.Symbols.Name+import HsDev.Symbols.Location+import HsDev.Symbols.Types+import HsDev.Tools.Ghc.Types+import HsDev.Tools.Types+import HsDev.Util++instance ToField Value where+	toField = SQLBlob . L.toStrict . encode++instance FromField Value where+	fromField fld = case fieldData fld of+		SQLText s -> either fail return . eitherDecode . L.fromStrict . T.encodeUtf8 $ s+		SQLBlob s -> either fail return . eitherDecode . L.fromStrict $ s+		_ -> fail "invalid json field type"++newtype JSON a = JSON { getJSON :: a }+	deriving (Eq, Ord, Read, Show)++instance ToJSON a => ToField (JSON a) where+	toField = SQLBlob . L.toStrict . encode . getJSON++instance FromJSON a => FromField (JSON a) where+	fromField fld = case fieldData fld of+		SQLText s -> either fail (return . JSON) . eitherDecode . L.fromStrict . T.encodeUtf8 $ s+		SQLBlob s -> either fail (return . JSON) . eitherDecode . L.fromStrict $ s+		_ -> fail "invalid json field type"++instance FromRow Position where+	fromRow = Position <$> field <*> field++instance ToRow Position where+	toRow (Position l c) = [toField l, toField c]++instance FromRow Region where+	fromRow = Region <$> fromRow <*> fromRow++instance ToRow Region where+	toRow (Region f t) = toRow f ++ toRow t++instance FromRow ModulePackage where+	fromRow = ModulePackage <$> field <*> (fromMaybe T.empty <$> field)++instance ToRow ModulePackage where+	toRow (ModulePackage name ver) = [toField name, toField ver]++instance FromRow ModuleLocation where+	fromRow = do+		file <- field+		cabal <- field+		dirs <- field+		pname <- field+		pver <- field+		iname <- field+		iexposed <- field+		other <- field++		maybe mzero return $ msum [+			FileModule <$> file <*> pure (project <$> cabal),+			InstalledModule <$> maybe (pure []) fromJSON' dirs <*> (ModulePackage <$> pname <*> pver) <*> iname <*> iexposed,+			OtherLocation <$> other,+			pure NoLocation]++instance ToRow ModuleLocation where+	toRow mloc = [+		toField $ mloc ^? moduleFile,+		toField $ mloc ^? moduleProject . _Just . projectCabal,+		toField $ fmap toJSON $ mloc ^? moduleInstallDirs,+		toField $ mloc ^? modulePackage . packageName,+		toField $ mloc ^? modulePackage . packageVersion,+		toField $ mloc ^? installedModuleName,+		toField $ mloc ^? installedModuleExposed,+		toField $ mloc ^? otherLocationName]++instance FromRow ModuleId where+	fromRow = ModuleId <$> field <*> fromRow++instance ToRow ModuleId where+	toRow mid = toField (mid ^. moduleName) : toRow (mid ^. moduleLocation)++instance FromRow Import where+	fromRow = Import <$> fromRow <*> field <*> field <*> field++instance ToRow Import where+	toRow (Import p n q a) = toRow p ++ [toField n, toField q, toField a]++instance FromRow SymbolId where+	fromRow = SymbolId <$> field <*> fromRow++instance ToRow SymbolId where+	toRow (SymbolId nm mid) = toField nm : toRow mid++instance FromRow SymbolInfo where+	fromRow = do+		what <- field @String+		ty <- field+		parent <- field+		ctors <- field+		args <- field+		ctx <- field+		assoc <- field+		patTy <- field+		patCtor <- field+		maybe mzero return $ case what of+			"function" -> return $ Function ty+			"method" -> Method <$> pure ty <*> parent+			"selector" -> Selector <$> pure ty <*> parent <*> (fromJSON' =<< ctors)+			"ctor" -> Constructor <$> (fromJSON' =<< args) <*> parent+			"type" -> Type <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)+			"newtype" -> NewType <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)+			"data" -> Data <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)+			"class" -> Class <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx)+			"type-family" -> TypeFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc+			"data-family" -> DataFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc+			"pat-ctor" -> PatConstructor <$> (fromJSON' =<< args) <*> pure patTy+			"pat-selector" -> PatSelector <$> pure ty <*> pure patTy <*> patCtor+			_ -> Nothing++instance ToRow SymbolInfo where+	toRow si = [+		toField $ symbolInfoType si,+		toField $ si ^? functionType . _Just,+		toField $ msum [si ^? parentClass, si ^? parentType],+		toField $ toJSON $ si ^? selectorConstructors,+		toField $ toJSON $ si ^? typeArgs,+		toField $ toJSON $ si ^? typeContext,+		toField $ si ^? familyAssociate . _Just,+		toField $ si ^? patternType . _Just,+		toField $ si ^? patternConstructor]++instance FromRow Symbol where+	fromRow = Symbol <$> fromRow <*> field <*> pos <*> fromRow where+		pos = do+			line <- field+			column <- field+			return $ Position <$> line <*> column++instance ToRow Symbol where+	toRow sym = concat [+		toRow (sym ^. symbolId),+		[toField $ sym ^. symbolDocs],+		maybe [SQLNull, SQLNull] toRow (sym ^. symbolPosition),+		toRow (sym ^. symbolInfo)]++instance FromRow a => FromRow (Scoped a) where+	fromRow = flip Scoped <$> fromRow <*> field++instance ToRow a => ToRow (Scoped a) where+	toRow (Scoped q s) = toRow s ++ [toField q]++instance ToField BuildTool where+	toField CabalTool = toField @String "cabal"+	toField StackTool = toField @String "stack"++instance FromField BuildTool where+	fromField = fromField @String >=> fromStr where+		fromStr "cabal" = return CabalTool+		fromStr "stack" = return StackTool+		fromStr _ = mzero++instance ToRow Sandbox where+	toRow (Sandbox t p) = [toField t, toField p]++instance FromRow Sandbox where+	fromRow = Sandbox <$> field <*> field++instance ToRow Project where+	toRow (Project name _ cabal pdesc t dbs) = [toField name, toField cabal, toField $ pdesc ^? _Just . projectVersion, toField t, toField dbs]++instance FromRow Project where+	fromRow = do+		name <- field+		cabal <- field+		ver <- field+		tool <- field+		dbs <- field+		return $ Project name (takeDir cabal) cabal (fmap (\v -> ProjectDescription v Nothing [] []) ver) tool dbs++instance FromRow Library where+	fromRow = do+		mods <- field >>= maybe mzero return . fromJSON'+		binfo <- fromRow+		return $ Library mods binfo++instance FromRow Executable where+	fromRow = Executable <$> field <*> field <*> fromRow++instance FromRow Test where+	fromRow = Test <$> field <*> field <*> field <*> fromRow++instance FromRow Info where+	fromRow = Info <$>+		(field >>= maybe mzero return . fromJSON') <*>+		field <*>+		(field >>= maybe mzero return . fromJSON') <*>+		(field >>= maybe mzero return . fromJSON') <*>+		(field >>= maybe mzero return . fromJSON') <*>+		(field >>= maybe mzero return . fromJSON')++instance FromField Language where+	fromField fld = case fieldData fld of+		SQLText txt -> parseDT "Language" (T.unpack txt)+		_ -> mzero++instance ToField PackageDb where+	toField GlobalDb = toField ("global-db" :: String)+	toField UserDb = toField ("user-db" :: String)+	toField (PackageDb p) = toField ("package-db:" ++ T.unpack p)++instance FromField PackageDb where+	fromField fld = do+		s <- fromField fld+		case s of+			"global-db" -> return GlobalDb+			"user-db" -> return UserDb+			_ -> case T.stripPrefix "package-db:" s of+				Just p' -> return $ PackageDb p'+				Nothing -> mzero++instance ToField PackageDbStack where+	toField = toField . toJSON . packageDbs++instance FromField PackageDbStack where+	fromField = fromField >=> maybe mzero (return . mkPackageDbStack) . fromJSON'++instance FromRow SymbolUsage where+	fromRow = SymbolUsage <$> fromRow <*> field <*> fromRow <*> fromRow++instance FromField POSIXTime where+	fromField = fmap (fromRational . toRational @Double) . fromField++instance ToField POSIXTime where+	toField = toField . fromRational @Double . toRational++instance FromRow Inspection where+	fromRow = do+		tm <- field+		opts <- field+		case (tm, opts) of+			(Nothing, Nothing) -> return InspectionNone+			(_, Just opts') -> InspectionAt (fromMaybe 0 tm) <$>+				maybe mzero return (fromJSON' opts')+			(Just _, Nothing) -> mzero++instance ToRow Inspection where+	toRow InspectionNone = [SQLNull, SQLNull]+	toRow (InspectionAt tm opts) = [+		if tm == 0 then SQLNull else toField tm,+		toField $ toJSON opts]++instance FromRow TypedExpr where+	fromRow = TypedExpr <$> field <*> field++instance ToRow TypedExpr where+	toRow (TypedExpr e t) = [toField e, toField t]++instance FromField (H.Name ()) where+	fromField = fmap toName_ . fromField++instance ToField (H.Name ()) where+	toField = toField . fromName_++instance FromField (H.ModuleName ()) where+	fromField = fmap toModuleName_ . fromField++instance ToField (H.ModuleName ()) where+	toField = toField . fromModuleName_++instance FromRow N.Symbol where+	fromRow = do+		what <- field @T.Text+		mname <- field+		name <- field+		parent <- field+		ctors <- do+			ctorsJson <- field+			return $ fmap (map toName_) (ctorsJson >>= fromJSON')+		assoc <- field+		patType <- field+		patCtor <- field+		let+			m = toModuleName_ mname+			n = toName_ name+		maybe mzero return $ case what of+			"function" -> return $ N.Value m n+			"method" -> N.Method m n <$> parent+			"selector" -> N.Selector m n <$> parent <*> ctors+			"ctor" -> N.Constructor m n <$> parent+			"type" -> return $ N.Type m n+			"newtype" -> return $ N.NewType m n+			"data" -> return $ N.Data m n+			"class" -> return $ N.Class m n+			"type-family" -> return $ N.TypeFam m n assoc+			"data-family" -> return $ N.DataFam m n assoc+			"pat-ctor" -> return $ N.PatternConstructor m n patType+			"pat-selector" -> N.PatternSelector m n patType <$> patCtor+			_ -> Nothing++instance ToRow N.Symbol where+	toRow = padNulls 8 . toRow' where+		toRow' (N.Value m n) = mk "function" [toField m, toField n]+		toRow' (N.Method m n p) = mk "method" [toField m, toField n, toField p]+		toRow' (N.Selector m n p cs) = mk "selector" [toField m, toField n, toField p, toField $ toJSON (map fromName_ cs)]+		toRow' (N.Constructor m n p) = mk "ctor" [toField m, toField n, toField p]+		toRow' (N.Type m n) = mk "type" [toField m, toField n]+		toRow' (N.NewType m n) = mk "newtype" [toField m, toField n]+		toRow' (N.Data m n) = mk "data" [toField m, toField n]+		toRow' (N.Class m n) = mk "class" [toField m, toField n]+		toRow' (N.TypeFam m n assoc) = mk "type-family" [toField m, toField n, SQLNull, SQLNull, toField assoc]+		toRow' (N.DataFam m n assoc) = mk "data-family" [toField m, toField n, SQLNull, SQLNull, toField assoc]+		toRow' (N.PatternConstructor m n pty) = mk "pat-ctor" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty]+		toRow' (N.PatternSelector m n pty pctor) = mk "pat-selector" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty, toField pctor]++		mk :: T.Text -> [SQLData] -> [SQLData]+		mk what = (toField what :)+		padNulls n fs = fs ++ replicate (n - length fs) SQLNull++instance FromField Severity where+	fromField fld = do+		s <- fromField @String fld+		msum [+			guard (s == "error") >> return Error,+			guard (s == "warning") >> return Warning,+			guard (s == "hint") >> return Hint]++instance ToField Severity where+	toField Error = toField @String "error"+	toField Warning = toField @String "warning"+	toField Hint = toField @String "hint"++instance FromRow OutputMessage where+	fromRow = OutputMessage <$> field <*> field++instance ToRow OutputMessage where+	toRow (OutputMessage msg suggest) = [toField msg, toField suggest]++instance FromRow a => FromRow (Note a) where+	fromRow = Note <$> (FileModule <$> field <*> pure Nothing) <*> fromRow <*> field <*> fromRow++instance ToRow a => ToRow (Note a) where+	toRow (Note mloc rgn sev n) = concat [+		[toField $ mloc ^? moduleFile],+		toRow rgn,+		[toField sev],+		toRow n]

@@ -1,25 +1,25 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
-
-module HsDev.Database.SQLite.Schema (
-	schema, commands
-	) where
-
-import qualified Data.Text as T
-import Data.List (unfoldr)
-import Database.SQLite.Simple (Query(..))
-
-import HsDev.Database.SQLite.Schema.TH
-
-schema :: T.Text
-schema = T.pack $schemaExp
-
-commands :: [Query]
-commands = map (Query . T.unlines) . unfoldr takeStmt . T.lines $ schema where
-	takeStmt :: [T.Text] -> Maybe ([T.Text], [T.Text])
-	takeStmt ls = case break endsStmt ls of
-		(_, []) -> Nothing
-		(hs, t:ts) -> Just (hs ++ [t], ts)
-	comment :: T.Text -> Bool
-	comment t = "-- " `T.isPrefixOf` T.strip t
-	endsStmt :: T.Text -> Bool
-	endsStmt t = not (comment t) && ";" `T.isSuffixOf` T.strip t
+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}++module HsDev.Database.SQLite.Schema (+	schema, commands+	) where++import qualified Data.Text as T+import Data.List (unfoldr)+import Database.SQLite.Simple (Query(..))++import HsDev.Database.SQLite.Schema.TH++schema :: T.Text+schema = T.pack $schemaExp++commands :: [Query]+commands = map (Query . T.unlines) . unfoldr takeStmt . T.lines $ schema where+	takeStmt :: [T.Text] -> Maybe ([T.Text], [T.Text])+	takeStmt ls = case break endsStmt ls of+		(_, []) -> Nothing+		(hs, t:ts) -> Just (hs ++ [t], ts)+	comment :: T.Text -> Bool+	comment t = "-- " `T.isPrefixOf` T.strip t+	endsStmt :: T.Text -> Bool+	endsStmt t = not (comment t) && ";" `T.isSuffixOf` T.strip t

@@ -1,16 +1,16 @@-{-# LANGUAGE TemplateHaskell #-}
-
-module HsDev.Database.SQLite.Schema.TH (
-	schemaExp
-	) where
-
-import System.Directory
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax
-
-schemaExp :: ExpQ
-schemaExp = do
-	schemaFile <- runIO $ canonicalizePath "data/hsdev.sql"
-	addDependentFile schemaFile
-	s <- runIO (readFile "data/hsdev.sql")
-	[e| s |]
+{-# LANGUAGE TemplateHaskell, PackageImports #-}++module HsDev.Database.SQLite.Schema.TH (+	schemaExp+	) where++import System.Directory+import "template-haskell" Language.Haskell.TH+import "template-haskell" Language.Haskell.TH.Syntax++schemaExp :: ExpQ+schemaExp = do+	schemaFile <- runIO $ canonicalizePath "data/hsdev.sql"+	addDependentFile schemaFile+	s <- runIO (readFile "data/hsdev.sql")+	[e| s |]

@@ -1,159 +1,159 @@-{-# LANGUAGE OverloadedStrings, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-
-module HsDev.Database.SQLite.Select (
-	Select(..), select_, from_, where_, buildQuery, toQuery,
-	qSymbolId, qSymbol, qModuleLocation, qModuleId, qImport, qBuildInfo,
-	qNSymbol, qNote
-	) where
-
-import Data.String
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Semigroup
-import Database.SQLite.Simple
-import Text.Format
-
-data Select a = Select {
-	selectColumns :: [a],
-	selectTables :: [a],
-	selectConditions :: [a] }
-		deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)
-
-instance Semigroup (Select a) where
-	Select lc lt lcond <> Select rc rt rcond = Select
-		(lc <> rc)
-		(lt <> rt)
-		(lcond <> rcond)
-
-instance Monoid (Select a) where
-	mempty = Select mempty mempty mempty
-	mappend l r = l <> r
-
-select_ :: [a] -> Select a
-select_ cols = Select cols [] []
-
-from_ :: [a] -> Select a
-from_ tbls = Select [] tbls []
-
-where_ :: [a] -> Select a
-where_ = Select [] []
-
-buildQuery :: Select Text -> String
-buildQuery (Select cols tables conds) = "select {} from {} where {}"
-	~~ T.intercalate ", " cols
-	~~ T.intercalate ", " tables
-	~~ T.intercalate " and " (map (\cond -> T.concat ["(", cond, ")"]) conds)
-
-toQuery :: Select Text -> Query
-toQuery = fromString . buildQuery
-
-qSymbolId :: Select Text
-qSymbolId = mconcat [
-	select_ [
-		"s.name",
-		"m.name",
-		"m.file",
-		"m.cabal",
-		"m.install_dirs",
-		"m.package_name",
-		"m.package_version",
-		"m.installed_name",
-		"m.exposed",
-		"m.other_location"],
-	from_ ["modules as m", "symbols as s"],
-	where_ ["m.id == s.module_id"]]
-
-qSymbol :: Select Text
-qSymbol = mconcat [
-	qSymbolId,
-	select_ [
-		"s.docs",
-		"s.line",
-		"s.column",
-		"s.what",
-		"s.type",
-		"s.parent",
-		"s.constructors",
-		"s.args",
-		"s.context",
-		"s.associate",
-		"s.pat_type",
-		"s.pat_constructor"]]
-
-qModuleLocation :: Text -> Select Text
-qModuleLocation ml = template ["ml" ~% ml] [
-	select_ [
-		"{ml}.file",
-		"{ml}.cabal",
-		"{ml}.install_dirs",
-		"{ml}.package_name",
-		"{ml}.package_version",
-		"{ml}.installed_name",
-		"{ml}.exposed",
-		"{ml}.other_location"],
-	from_ ["modules as {ml}"]]
-
-qModuleId :: Select Text
-qModuleId = mconcat [
-	select_ [
-		"mu.name",
-		"mu.file",
-		"mu.cabal",
-		"mu.install_dirs",
-		"mu.package_name",
-		"mu.package_version",
-		"mu.installed_name",
-		"mu.exposed",
-		"mu.other_location"],
-	from_ ["modules as mu"],
-	where_ ["mu.name is not null"]]
-
-qImport :: Text -> Select Text
-qImport i = template ["i" ~% i] [
-	select_ [
-		"{i}.line", "{i}.column",
-		"{i}.module_name",
-		"{i}.qualified",
-		"{i}.alias"],
-	from_ ["imports as {i}"]]
-
-qBuildInfo :: Select Text
-qBuildInfo = mconcat [
-	select_ [
-		"bi.depends",
-		"bi.language",
-		"bi.extensions",
-		"bi.ghc_options",
-		"bi.source_dirs",
-		"bi.other_modules"],
-	from_ ["build_infos as bi"]]
-
--- | Symbol from haskell-names
-qNSymbol :: Text -> Text -> Select Text
-qNSymbol m s = template ["m" ~% m, "s" ~% s] [
-	select_ [
-		"{s}.what",
-		"{m}.name",
-		"{s}.name",
-		"{s}.parent",
-		"{s}.constructors",
-		"{s}.associate",
-		"{s}.pat_type",
-		"{s}.pat_constructor"],
-	from_ ["symbols as {s}", "modules as {m}"],
-	where_ ["{m}.id = {s}.module_id"]]
-
-qNote :: Text -> Text -> Select Text
-qNote m n = template ["m" ~% m, "n" ~% n] [
-	select_ [
-		"{m}.file",
-		"{n}.line", "{n}.column", "{n}.line_to", "{n}.column_to",
-		"{n}.severity",
-		"{n}.message", "{n}.suggestion"],
-	from_ ["modules as {m}", "messages as {n}"],
-	where_ [
-		"{m}.file is not null",
-		"{n}.module_id = {m}.id"]]
-
-template :: [FormatArg] -> [Select Text] -> Select Text
-template args = fmap ((`formats` args) . T.unpack) . mconcat
+{-# LANGUAGE OverloadedStrings, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++module HsDev.Database.SQLite.Select (+	Select(..), select_, from_, where_, buildQuery, toQuery,+	qSymbolId, qSymbol, qModuleLocation, qModuleId, qImport, qBuildInfo,+	qNSymbol, qNote+	) where++import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Semigroup+import Database.SQLite.Simple+import Text.Format++data Select a = Select {+	selectColumns :: [a],+	selectTables :: [a],+	selectConditions :: [a] }+		deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)++instance Semigroup (Select a) where+	Select lc lt lcond <> Select rc rt rcond = Select+		(lc <> rc)+		(lt <> rt)+		(lcond <> rcond)++instance Monoid (Select a) where+	mempty = Select mempty mempty mempty+	mappend l r = l <> r++select_ :: [a] -> Select a+select_ cols = Select cols [] []++from_ :: [a] -> Select a+from_ tbls = Select [] tbls []++where_ :: [a] -> Select a+where_ = Select [] []++buildQuery :: Select Text -> String+buildQuery (Select cols tables conds) = "select {} from {} where {}"+	~~ T.intercalate ", " cols+	~~ T.intercalate ", " tables+	~~ T.intercalate " and " (map (\cond -> T.concat ["(", cond, ")"]) conds)++toQuery :: Select Text -> Query+toQuery = fromString . buildQuery++qSymbolId :: Select Text+qSymbolId = mconcat [+	select_ [+		"s.name",+		"m.name",+		"m.file",+		"m.cabal",+		"m.install_dirs",+		"m.package_name",+		"m.package_version",+		"m.installed_name",+		"m.exposed",+		"m.other_location"],+	from_ ["modules as m", "symbols as s"],+	where_ ["m.id == s.module_id"]]++qSymbol :: Select Text+qSymbol = mconcat [+	qSymbolId,+	select_ [+		"s.docs",+		"s.line",+		"s.column",+		"s.what",+		"s.type",+		"s.parent",+		"s.constructors",+		"s.args",+		"s.context",+		"s.associate",+		"s.pat_type",+		"s.pat_constructor"]]++qModuleLocation :: Text -> Select Text+qModuleLocation ml = template ["ml" ~% ml] [+	select_ [+		"{ml}.file",+		"{ml}.cabal",+		"{ml}.install_dirs",+		"{ml}.package_name",+		"{ml}.package_version",+		"{ml}.installed_name",+		"{ml}.exposed",+		"{ml}.other_location"],+	from_ ["modules as {ml}"]]++qModuleId :: Select Text+qModuleId = mconcat [+	select_ [+		"mu.name",+		"mu.file",+		"mu.cabal",+		"mu.install_dirs",+		"mu.package_name",+		"mu.package_version",+		"mu.installed_name",+		"mu.exposed",+		"mu.other_location"],+	from_ ["modules as mu"],+	where_ ["mu.name is not null"]]++qImport :: Text -> Select Text+qImport i = template ["i" ~% i] [+	select_ [+		"{i}.line", "{i}.column",+		"{i}.module_name",+		"{i}.qualified",+		"{i}.alias"],+	from_ ["imports as {i}"]]++qBuildInfo :: Select Text+qBuildInfo = mconcat [+	select_ [+		"bi.depends",+		"bi.language",+		"bi.extensions",+		"bi.ghc_options",+		"bi.source_dirs",+		"bi.other_modules"],+	from_ ["build_infos as bi"]]++-- | Symbol from haskell-names+qNSymbol :: Text -> Text -> Select Text+qNSymbol m s = template ["m" ~% m, "s" ~% s] [+	select_ [+		"{s}.what",+		"{m}.name",+		"{s}.name",+		"{s}.parent",+		"{s}.constructors",+		"{s}.associate",+		"{s}.pat_type",+		"{s}.pat_constructor"],+	from_ ["symbols as {s}", "modules as {m}"],+	where_ ["{m}.id = {s}.module_id"]]++qNote :: Text -> Text -> Select Text+qNote m n = template ["m" ~% m, "n" ~% n] [+	select_ [+		"{m}.file",+		"{n}.line", "{n}.column", "{n}.line_to", "{n}.column_to",+		"{n}.severity",+		"{n}.message", "{n}.suggestion"],+	from_ ["modules as {m}", "messages as {n}"],+	where_ [+		"{m}.file is not null",+		"{n}.module_id = {m}.id"]]++template :: [FormatArg] -> [Select Text] -> Select Text+template args = fmap ((`formats` args) . T.unpack) . mconcat

@@ -1,98 +1,98 @@-{-# LANGUAGE TypeApplications, MultiWayIf, OverloadedStrings #-}
-
-module HsDev.Database.SQLite.Transaction (
-	TransactionType(..),
-	Retries(..), def, noRetry, retryForever, retryN,
-
-	-- * Transactions
-	withTransaction, beginTransaction, commitTransaction, rollbackTransaction,
-	transaction, transaction_,
-
-	-- * Retry functions
-	retry, retry_
-	) where
-
-import Control.Concurrent
-import Control.Monad.Catch
-import Control.Monad.IO.Class
-import Data.Default
-import Database.SQLite.Simple as SQL hiding (withTransaction)
-
-import HsDev.Server.Types (SessionMonad, serverSqlDatabase)
-
--- | Three types of transactions
-data TransactionType = Deferred | Immediate | Exclusive
-	deriving (Eq, Ord, Read, Show)
-
--- | Retry config
-data Retries = Retries {
-	retriesIntervals :: [Int],
-	retriesError :: SQLError -> Bool }
-
-instance Default Retries where
-	def = Retries (replicate 10 100000) $ \e -> sqlError e `elem` [ErrorBusy, ErrorLocked]
-
--- | Don't retry
-noRetry :: Retries
-noRetry = Retries [] (const False)
-
--- | Retry forever
-retryForever :: Int -> Retries
-retryForever interval = def { retriesIntervals = repeat interval }
-
--- | Retry with interval N times
-retryN :: Int -> Int -> Retries
-retryN interval times = def { retriesIntervals = replicate times interval }
-
--- | Run actions inside transaction
-withTransaction :: (MonadIO m, MonadMask m) => Connection -> TransactionType -> Retries -> m a -> m a
-withTransaction conn t rs act = mask $ \restore -> do
-	mretry restore (beginTransaction conn t)
-	(restore act <* mretry restore (commitTransaction conn)) `onException` rollbackTransaction conn
-	where
-		mretry restore' fn = mretry' (retriesIntervals rs) where
-			mretry' [] = fn
-			mretry' (tm:tms) = catch @_ @SQLError fn $ \e -> if
-				| retriesError rs e -> do
-						_ <- restore' $ liftIO $ threadDelay tm
-						mretry' tms
-				| otherwise -> throwM e
-
--- | Begin transaction
-beginTransaction :: MonadIO m => Connection -> TransactionType -> m ()
-beginTransaction conn t = liftIO $ SQL.execute_ conn $ case t of
-	Deferred -> "begin transaction;"
-	Immediate -> "begin immediate transaction;"
-	Exclusive -> "begin exclusive transaction;"
-
--- | Commit transaction
-commitTransaction :: MonadIO m => Connection -> m ()
-commitTransaction conn = liftIO $ SQL.execute_ conn "commit transaction;"
-
--- | Rollback transaction
-rollbackTransaction :: MonadIO m => Connection -> m ()
-rollbackTransaction conn = liftIO $ SQL.execute_ conn "rollback transaction;"
-
--- | Run transaction in @SessionMonad@
-transaction :: SessionMonad m => TransactionType -> Retries -> m a -> m a
-transaction t rs act = do
-	conn <- serverSqlDatabase
-	withTransaction conn t rs act
-
--- | Transaction with default retries config
-transaction_ :: SessionMonad m => TransactionType -> m a -> m a
-transaction_ t = transaction t def
-
--- | Retry operation
-retry :: (MonadIO m, MonadCatch m) => Retries -> m a -> m a
-retry rs = retry' (retriesIntervals rs) where
-	retry' [] fn = fn
-	retry' (tm:tms) fn = catch @_ @SQLError fn $ \e -> if
-		| retriesError rs e -> do
-			liftIO $ threadDelay tm
-			retry' tms fn
-		| otherwise -> throwM e
-
--- | Retry with default params
-retry_ :: (MonadIO m, MonadCatch m) => m a -> m a
-retry_ = retry def
+{-# LANGUAGE TypeApplications, MultiWayIf, OverloadedStrings #-}++module HsDev.Database.SQLite.Transaction (+	TransactionType(..),+	Retries(..), def, noRetry, retryForever, retryN,++	-- * Transactions+	withTransaction, beginTransaction, commitTransaction, rollbackTransaction,+	transaction, transaction_,++	-- * Retry functions+	retry, retry_+	) where++import Control.Concurrent+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Default+import Database.SQLite.Simple as SQL hiding (withTransaction)++import HsDev.Server.Types (SessionMonad, serverSqlDatabase)++-- | Three types of transactions+data TransactionType = Deferred | Immediate | Exclusive+	deriving (Eq, Ord, Read, Show)++-- | Retry config+data Retries = Retries {+	retriesIntervals :: [Int],+	retriesError :: SQLError -> Bool }++instance Default Retries where+	def = Retries (replicate 10 100000) $ \e -> sqlError e `elem` [ErrorBusy, ErrorLocked]++-- | Don't retry+noRetry :: Retries+noRetry = Retries [] (const False)++-- | Retry forever+retryForever :: Int -> Retries+retryForever interval = def { retriesIntervals = repeat interval }++-- | Retry with interval N times+retryN :: Int -> Int -> Retries+retryN interval times = def { retriesIntervals = replicate times interval }++-- | Run actions inside transaction+withTransaction :: (MonadIO m, MonadMask m) => Connection -> TransactionType -> Retries -> m a -> m a+withTransaction conn t rs act = mask $ \restore -> do+	mretry restore (beginTransaction conn t)+	(restore act <* mretry restore (commitTransaction conn)) `onException` rollbackTransaction conn+	where+		mretry restore' fn = mretry' (retriesIntervals rs) where+			mretry' [] = fn+			mretry' (tm:tms) = catch @_ @SQLError fn $ \e -> if+				| retriesError rs e -> do+						_ <- restore' $ liftIO $ threadDelay tm+						mretry' tms+				| otherwise -> throwM e++-- | Begin transaction+beginTransaction :: MonadIO m => Connection -> TransactionType -> m ()+beginTransaction conn t = liftIO $ SQL.execute_ conn $ case t of+	Deferred -> "begin transaction;"+	Immediate -> "begin immediate transaction;"+	Exclusive -> "begin exclusive transaction;"++-- | Commit transaction+commitTransaction :: MonadIO m => Connection -> m ()+commitTransaction conn = liftIO $ SQL.execute_ conn "commit transaction;"++-- | Rollback transaction+rollbackTransaction :: MonadIO m => Connection -> m ()+rollbackTransaction conn = liftIO $ SQL.execute_ conn "rollback transaction;"++-- | Run transaction in @SessionMonad@+transaction :: SessionMonad m => TransactionType -> Retries -> m a -> m a+transaction t rs act = do+	conn <- serverSqlDatabase+	withTransaction conn t rs act++-- | Transaction with default retries config+transaction_ :: SessionMonad m => TransactionType -> m a -> m a+transaction_ t = transaction t def++-- | Retry operation+retry :: (MonadIO m, MonadCatch m) => Retries -> m a -> m a+retry rs = retry' (retriesIntervals rs) where+	retry' [] fn = fn+	retry' (tm:tms) fn = catch @_ @SQLError fn $ \e -> if+		| retriesError rs e -> do+			liftIO $ threadDelay tm+			retry' tms fn+		| otherwise -> throwM e++-- | Retry with default params+retry_ :: (MonadIO m, MonadCatch m) => m a -> m a+retry_ = retry def

@@ -1,693 +1,693 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses, RankNTypes, TypeOperators, TypeApplications #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module HsDev.Database.Update (
-	Status(..), Progress(..), Task(..),
-	UpdateOptions(..),
-
-	UpdateM(..),
-	runUpdate,
-
-	postStatus, updater, runTask, runTasks, runTasks_,
-
-	scanModules, scanFile, scanFiles, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanPackageDbStack, scanProjectFile, scanProjectStack, scanProject, scanDirectory,
-	scanPackageDbStackDocs, scanDocs,
-	setModTypes, inferModTypes,
-	scan,
-	processEvents, updateEvents, applyUpdates,
-
-	cacheGhcWarnings, cachedWarnings,
-
-	module HsDev.Database.Update.Types,
-
-	module HsDev.Watcher,
-
-	module Control.Monad.Except
-	) where
-
-import qualified Control.Concurrent.Async as A
-import Control.Concurrent.MVar
-import Control.DeepSeq
-import Control.Exception (ErrorCall, evaluate, displayException)
-import Control.Lens
-import Control.Monad.Catch (catch, handle, MonadThrow, bracket_)
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.Writer
-import Control.Monad.State (get, modify, runStateT)
-import Data.Aeson
-import Data.List (intercalate)
-import Data.String (fromString)
-import qualified Data.Map.Strict as M
-import qualified Data.Set as S
-import Data.Maybe
-import Data.Text (Text)
-import Data.Time.Clock.POSIX
-import qualified Data.Text as T
-import System.FilePath
-import qualified System.Log.Simple as Log
-
-import Data.Maybe.JustIf
-import HsDev.Error
-import qualified HsDev.Database.SQLite as SQLite
-import HsDev.Display
-import HsDev.Inspect
-import HsDev.Inspect.Order
-import HsDev.PackageDb
-import HsDev.Project
-import HsDev.Sandbox
-import qualified HsDev.Stack as S
-import HsDev.Symbols
-import HsDev.Tools.Ghc.Session hiding (Session, evaluate)
-import HsDev.Tools.Ghc.Types (fileTypes, TypedExpr)
-import HsDev.Tools.Types
-import HsDev.Tools.HDocs
-import qualified HsDev.Scan as S
-import HsDev.Scan.Browse
-import HsDev.Util (ordNub, fromJSON', uniqueBy, timer)
-import qualified HsDev.Util as Util (withCurrentDirectory)
-import HsDev.Server.Types (commandNotify, inSessionGhc, FileSource(..))
-import HsDev.Server.Message
-import HsDev.Database.Update.Types
-import HsDev.Watcher
-import Text.Format
-import System.Directory.Paths
-
-onStatus :: UpdateMonad m => m ()
-onStatus = asks (view (updateOptions . updateTasks)) >>= commandNotify . Notification . toJSON . reverse
-
-childTask :: UpdateMonad m => Task -> m a -> m a
-childTask t = local (over (updateOptions . updateTasks) (t:))
-
-transact :: SessionMonad m => m a -> m a
-transact = SQLite.transaction_ SQLite.Immediate
-
-runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a
-runUpdate uopts act = Log.scope "update" $ do
-	(r, updatedMods) <- withUpdateState uopts $ \ust ->
-		runWriterT (runUpdateM act' `runReaderT` ust)
-	Log.sendLog Log.Debug $ "updated {} modules" ~~ length updatedMods
-	return r
-	where
-		act' = do
-			(r, _) <- listen act
-			-- (r, mlocs') <- listen act
-
-			-- dbs <- liftM S.unions $ forM mlocs' $ \mloc' -> do
-			-- 	mid <- SQLite.lookupModuleLocation mloc'
-			-- 	case mid of
-			-- 		Nothing -> return (S.empty :: S.Set PackageDb)
-			-- 		Just mid' -> liftM (S.fromList . map SQLite.fromOnly) $ SQLite.query (SQLite.toQuery $ SQLite.select_
-			-- 			["ps.package_db"]
-			-- 			["package_dbs as ps", "modules as m"]
-			-- 			["m.package_name == ps.package_name", "m.package_version == ps.package_version", "m.id == ?"]) (SQLite.Only mid')
-
-			-- If some sourced files depends on currently scanned package-dbs
-			-- We must resolve them and even rescan if there was errors scanning without
-			-- dependencies provided (lack of fixities can cause errors inspecting files)
-
-			-- sboxes = databaseSandboxes dbval
-			-- sboxOf :: Path -> Maybe Sandbox
-			-- sboxOf fpath = find (pathInSandbox fpath) sboxes
-			-- projsRows <- SQLite.query_ "select name, cabal, version, ifnull(package_db_stack, json('[]')) from projects;"
-			-- let
-			-- 	projs = [proj' | (proj' SQLite.:. (SQLite.Only (SQLite.JSON projPdbs))) <- projsRows,
-			-- 		not (S.null (S.fromList projPdbs `S.intersection` dbs))]
-
-			-- 	stands = []
-			-- 	-- HOWTO?
-			-- 	-- stands = do
-			-- 	-- 	sloc <- dbval ^.. standaloneSlice . modules . moduleId . moduleLocation
-			-- 	-- 	guard $ sboxUpdated $ sboxOf (sloc ^?! moduleFile)
-			-- 	-- 	guard (notElem sloc mlocs')
-			-- 	-- 	return (sloc, dbval ^.. databaseModules . ix sloc . inspection . inspectionOpts . each . unpacked, Nothing)
-
-			-- Log.sendLog Log.Trace $ "updated package-dbs: {}, have to rescan {} projects and {} files"
-			-- 	~~ intercalate ", " (map display $ S.toList dbs)
-			-- 	~~ length projs ~~ length stands
-			-- (_, rlocs') <- listen $ runTasks_ (scanModules [] stands : [scanProject [] (proj ^. projectCabal) | proj <- projs])
-			-- let
-			-- 	ulocs' = filter (isJust . preview moduleFile) (ordNub $ mlocs' ++ rlocs')
-			-- 	getMods :: (MonadIO m) => m [InspectedModule]
-			-- 	getMods = do
-			-- 		db' <- liftIO $ readAsync db
-			-- 		return $ filter ((`elem` ulocs') . view inspectedKey) $ toList $ view databaseModules db'
-
-			-- FIXME: Now it's broken since `Database` is not used anymore
-			when (view updateDocs uopts) $ do
-				Log.sendLog Log.Trace "forking inspecting source docs"
-				Log.sendLog Log.Warning "not implemented"
-				-- void $ fork (getMods >>= waiter . mapM_ scanDocs_)
-			when (view updateInfer uopts) $ do
-				Log.sendLog Log.Trace "forking inferring types"
-				Log.sendLog Log.Warning "not implemented"
-				-- void $ fork (getMods >>= waiter . mapM_ inferModTypes_)
-			return r
-		-- scanDocs_ :: UpdateMonad m => InspectedModule -> m ()
-		-- scanDocs_ im = do
-		-- 	im' <- (S.scanModify (\opts -> inSessionGhc . liftGhc . inspectDocsGhc opts) im) <|> return im
-		-- 	sendUpdateAction $ Log.scope "scan-docs" $ SQLite.updateModule im'
-		-- inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()
-		-- inferModTypes_ im = do
-		-- 	-- TODO: locate sandbox
-		-- 	im' <- (S.scanModify infer' im) <|> return im
-		-- 	sendUpdateAction $ Log.scope "infer-types" $ SQLite.updateModule im'
-		-- infer' :: UpdateMonad m => [String] -> Module -> m Module
-		-- infer' opts m = case preview (moduleId . moduleLocation . moduleFile) m of
-		-- 	Nothing -> return m
-		-- 	Just _ -> inSessionGhc $ do
-		-- 		targetSession opts m
-		-- 		inferTypes opts m Nothing
-
--- | Post status
-postStatus :: UpdateMonad m => Task -> m ()
-postStatus t = childTask t onStatus
-
--- | Mark module as updated
-updater :: UpdateMonad m => [ModuleLocation] -> m ()
-updater mlocs = tell $!! mlocs
-
--- | Run one task
-runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a
-runTask action subj act = Log.scope "task" $ do
-	postStatus $ set taskStatus StatusWorking task
-	x <- childTask task act
-	x `deepseq` postStatus (set taskStatus StatusOk task)
-	return x
-	`catch`
-	(\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e)
-	where
-		task = Task {
-			_taskName = action,
-			_taskStatus = StatusWorking,
-			_taskSubjectType = displayType subj,
-			_taskSubjectName = display subj,
-			_taskProgress = Nothing }
-
--- | Run many tasks with numeration
-runTasks :: UpdateMonad m => [m a] -> m [a]
-runTasks ts = liftM catMaybes $ zipWithM taskNum [1..] (map noErr ts) where
-	total = length ts
-	taskNum n = local setProgress where
-		setProgress = set (updateOptions . updateTasks . _head . taskProgress) (Just (Progress n total))
-	noErr v = hsdevIgnore Nothing (Just <$> v)
-
--- | Run many tasks with numeration
-runTasks_ :: UpdateMonad m => [m ()] -> m ()
-runTasks_ = void . runTasks
-
-data PreloadFailure = PreloadFailure ModuleLocation Inspection HsDevError
-
-instance NFData PreloadFailure where
-	rnf (PreloadFailure mloc insp err) = rnf mloc `seq` rnf insp `seq` rnf err
-
--- | Scan modules
-scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()
-scanModules opts ms = Log.scope "scan-modules" $ mapM_ (uncurry scanModules') grouped where
-	scanModules' mproj ms' = do
-		maybe (return ()) (sendUpdateAction . SQLite.updateProject) mproj
-		updater $ ms' ^.. each . _1
-		defines <- askSession sessionDefines
-
-		let
-			pload (mloc, mopts, mcts) = runTask "preloading" mloc $ do
-				mfcts <- maybe (S.getFileContents (mloc ^?! moduleFile)) (const $ return Nothing) mcts
-				insp <- liftIO $ fileInspection (mloc ^?! moduleFile) (opts ++ mopts)
-				case (mfcts ^? _Just . _1) of
-					Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm
-					Nothing -> return ()
-				let
-					inspection' = maybe insp (fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1
-					dirtyTag' = maybe id (const $ inspectTag DirtyTag) $ mfcts ^? _Just . _1
-					mcts' = mplus mcts (mfcts ^? _Just . _2)
-				runInspect mloc $ withInspection (return inspection') $ dirtyTag' $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mcts'
-
-		ploaded <- runTasks (map pload ms')
-		sendUpdateAction $ void $ SQLite.upsertModules $ map (fmap (view asModule)) ploaded
-		let
-			mlocs' = ploaded ^.. each . inspected . preloadedId . moduleLocation
-
-		updater mlocs'
-
-		let
-			mcabal = mproj ^? _Just . projectCabal
-
-		(env, fixities) <- loadEnv mcabal
-
-		Log.sendLog Log.Trace $ "resolved environment: {} modules" ~~ M.size env
-		case orderBy (preview inspected) ploaded of
-			Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err)
-			Right ordered -> do
-				(ms'', (updEnv, updFixities)) <- flip runStateT (env, fixities) $ runTasks (map inspect' ordered)
-				saveEnv mcabal updEnv updFixities
-				mlocs'' <- timer "updated scanned modules" $ do
-					Log.sendLog Log.Trace $ case mproj of
-						Just proj -> "inserting data for resolved modules of project: {}" ~~ proj
-						Nothing -> "inserting data for resolved standalone modules"
-					sendUpdateAction $ Log.scope "resolved" $ updateResolveds mcabal ms''
-					return (ms'' ^.. each . inspectedKey)
-				updater mlocs''
-				where
-					inspect' pmod = runTask "scanning" ploc $ Log.scope "module" $ do
-						(env', fixities') <- get
-						r <- continueInspect pmod $ \p -> do
-							resolved' <- msum [
-								resolveModule env' fixities' p,
-								do
-									lift (Log.sendLog Log.Trace ("error resolving module {}, falling to resolving just imports/scope" ~~ (p ^. preloadedId . moduleLocation)))
-									resolvePreloaded env' p]
-							eval resolved'
-						modify $ mappend (
-							maybe mempty resolvedEnv (r ^? inspected),
-							maybe mempty resolvedFixitiesTable (r ^? inspected))
-						return r
-						where
-							ploc = pmod ^?! inspected . preloadedId . moduleLocation
-
-	grouped = M.toList $ M.unionsWith (++) [M.singleton (m ^? _1 . moduleProject . _Just) [m] | m <- ms]
-	eval v = handle onError (v `deepseq` liftIO (evaluate v)) where
-		onError :: MonadThrow m => ErrorCall -> m a
-		onError = hsdevError . OtherError . displayException
-
--- | Scan source file, possibly scanning also related project and installed modules
-scanFile :: UpdateMonad m => [String] -> Path -> BuildTool -> Bool -> Bool -> m ()
-scanFile opts fpath tool scanProj scanDb = do
-	mproj <- fmap (set (_Just . projectBuildTool) tool) $ locateProjectInfo fpath
-	sbox <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj
-	when scanDb $ do
-		[SQLite.Only scanned] <- SQLite.query @_ @(SQLite.Only Bool) "select count(*) > 0 from package_dbs as pdbs where pdbs.package_db = ?;" (SQLite.Only (topPackageDb sbox))
-		unless scanned $ scanPackageDbStack opts sbox
-	case join (mproj `justIf` scanProj) of
-		Nothing -> scanFiles [(FileSource fpath Nothing, opts)]
-		Just proj -> scanProject opts tool (view projectCabal proj)
-
--- | Scan source files, resolving dependent modules
-scanFiles :: UpdateMonad m => [(FileSource, [String])] -> m ()
-scanFiles fsrcs = runTask "scanning" ("files" :: String) $ Log.scope "files" $ hsdevLiftIO $ do
-	Log.sendLog Log.Trace $ "scanning {} files" ~~ length fsrcs
-	fpaths' <- traverse (liftIO . canonicalize) $ map (fileSource . fst) fsrcs
-	forM_ fpaths' $ \fpath' -> do
-		ex <- liftIO $ fileExists fpath'
-		unless ex $ hsdevError $ FileNotFound fpath'
-	mlocs <- forM fpaths' $ \fpath' -> do
-		mids <- SQLite.query (SQLite.toQuery $ SQLite.qModuleId `mappend` SQLite.where_ ["mu.file == ?"]) (SQLite.Only fpath')
-		if length mids > 1
-			then return (head mids ^. moduleLocation)
-			else do
-				mproj <- locateProjectInfo fpath'
-				return $ FileModule fpath' mproj
-	let
-		filesMods = liftM concat $ forM fpaths' $ \fpath' -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file == ?;" (SQLite.Only fpath')
-	scan filesMods [(mloc, opts, mcts) | (mloc, (FileSource _ mcts, opts)) <- zip mlocs fsrcs] [] $ \mlocs' -> do
-		mapM_ ((watch . flip watchModule) . view _1) mlocs'
-		S.ScanContents dmods _ _ <- fmap mconcat $ mapM (S.enumDependent . view (_1 . moduleFile . path)) mlocs'
-		Log.sendLog Log.Trace $ "dependent modules: {}" ~~ length dmods
-		scanModules [] (mlocs' ++ dmods)
-
--- | Scan source file with contents and resolve dependent modules
-scanFileContents :: UpdateMonad m => [String] -> Path -> Maybe Text -> m ()
-scanFileContents opts fpath mcts = scanFiles [(FileSource fpath mcts, opts)]
-
--- | Scan cabal modules, doesn't rescan if already scanned
-scanCabal :: UpdateMonad m => [String] -> m ()
-scanCabal opts = Log.scope "cabal" $ scanPackageDbStack opts userDb
-
--- | Prepare sandbox for scanning. This is used for stack project to build & configure.
-prepareSandbox :: UpdateMonad m => Sandbox -> m ()
-prepareSandbox sbox@(Sandbox StackTool fpath) = Log.scope "prepare" $ runTasks_ [
-	runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.buildDeps Nothing]
-	where
-		dir = takeDirectory $ view path fpath
-prepareSandbox _ = return ()
-
--- | Scan sandbox modules, doesn't rescan if already scanned
-scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()
-scanSandbox opts sbox = Log.scope "sandbox" $ do
-	-- prepareSandbox sbox
-	pdbs <- inSessionGhc $ sandboxPackageDbStack sbox
-	scanPackageDbStack opts pdbs
-
--- | Scan top of package-db stack, usable for rescan
-scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m ()
-scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do
-	pdbState <- liftIO $ readPackageDb (topPackageDb pdbs)
-	let
-		packageDbMods = S.fromList $ concat $ M.elems pdbState
-		packages' = M.keys pdbState
-	Log.sendLog Log.Trace $ "package-db state: {} modules" ~~ length packageDbMods
-	watch (\w -> watchPackageDb w pdbs opts)
-
-	pkgs <- SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only $ topPackageDb pdbs)
-	if S.fromList packages' == S.fromList pkgs
-		then Log.sendLog Log.Trace "nothing changes, all packages the same"
-		else do
-			mlocs <- liftM
-				(filter (`S.member` packageDbMods)) $
-				(inSessionGhc $ listModules opts pdbs packages')
-			let
-				umlocs = uniqueModuleLocations mlocs
-			Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs
-			let
-				packageDbMods' = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only (topPackageDb pdbs))
-			scan packageDbMods' ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
-				ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)
-				Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms
-				sendUpdateAction $ timer "updated package-db modules" $ do
-					SQLite.updateModules ms
-					SQLite.updatePackageDb (topPackageDb pdbs) (M.keys pdbState)
-
-				when hdocsSupported $ scanPackageDbStackDocs opts pdbs
-
-				updater $ ms ^.. each . inspectedKey
-
--- | Scan top of package-db stack, usable for rescan
-scanPackageDbStack :: UpdateMonad m => [String] -> PackageDbStack -> m ()
-scanPackageDbStack opts pdbs = runTask "scanning" pdbs $ Log.scope "package-db-stack" $ do
-	pdbStates <- liftIO $ mapM readPackageDb (packageDbs pdbs)
-	let
-		packageDbMods = S.fromList $ concat $ concatMap M.elems pdbStates
-		packages' = ordNub $ concatMap M.keys pdbStates
-	Log.sendLog Log.Trace $ "package-db-stack state: {} modules" ~~ length packageDbMods
-	watch (\w -> watchPackageDbStack w pdbs opts)
-
-	pkgs <- liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only pdb)
-	if S.fromList packages' == S.fromList pkgs
-		then Log.sendLog Log.Trace "nothing changes, all packages the same"
-		else do
-			mlocs <- liftM
-				(filter (`S.member` packageDbMods)) $
-				(inSessionGhc $ listModules opts pdbs packages')
-			let
-				umlocs = uniqueModuleLocations mlocs
-			Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs
-			let
-				packageDbStackMods = liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only pdb)
-			scan packageDbStackMods ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
-				ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)
-				Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms
-				sendUpdateAction $ timer "updated package-db-stack modules" $ do
-					SQLite.updateModules ms
-					sequence_ [SQLite.updatePackageDb pdb (M.keys pdbState) | (pdb, pdbState) <- zip (packageDbs pdbs) pdbStates]
-
-				-- BUG: I don't know why, but these steps leads to segfault on my PC:
-				-- > hsdev scan --cabal --project .
-				-- > hsdev check -f .\src\HsDev\Client\Commands.hs
-				-- But it works if docs are scanned, it also works from ghci
-				
-				-- needDocs <- asks (view updateDocs)
-				-- ms' <- if needDocs
-				-- 	then do
-				-- 		docs <- inSessionGhc $ hdocsCabal pdbs opts
-				-- 		return $ map (fmap $ setDocs' docs) ms
-				-- 	else return ms
-
-				when hdocsSupported $ scanPackageDbStackDocs opts pdbs
-
-				updater $ ms ^.. each . inspectedKey
-
--- | Scan project file
-scanProjectFile :: UpdateMonad m => [String] -> BuildTool -> Path -> m Project
-scanProjectFile opts tool cabal = runTask "scanning" cabal $ do
-	proj <- fmap (set projectBuildTool tool) $ S.scanProjectFile opts cabal
-	pdbs <- inSessionGhc $ getProjectPackageDbStack proj
-	let
-		proj' = set projectPackageDbStack (Just pdbs) proj
-	sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj'
-	return proj'
-
--- | Refine project info and update if necessary
-refineProjectInfo :: UpdateMonad m => Project -> m Project
-refineProjectInfo proj = do
-	[SQLite.Only exist] <- SQLite.query "select count(*) > 0 from projects where cabal == ?;" (SQLite.Only (proj ^. projectCabal))
-	if exist
-		then SQLite.loadProject (proj ^. projectCabal)
-		else runTask "scanning" (proj ^. projectCabal) $ do
-			proj' <- liftIO $ loadProject proj
-			pdbs <- inSessionGhc $ getProjectPackageDbStack proj'
-			let
-				proj'' = set projectPackageDbStack (Just pdbs) proj'
-			sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj''
-			return proj''
-
--- | Get project info for module
-locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project)
-locateProjectInfo cabal = liftIO (locateProject (view path cabal)) >>= traverse refineProjectInfo
-
--- | Scan project and related package-db stack
-scanProjectStack :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()
-scanProjectStack opts tool cabal = do
-	sbox <- liftIO $ projectSandbox tool cabal
-	maybe (scanCabal opts) (scanSandbox opts) sbox
-	scanProject opts tool cabal
-
--- | Scan project
-scanProject :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()
-scanProject opts tool cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do
-	proj <- scanProjectFile opts tool cabal
-	watch (\w -> watchProject w proj opts)
-	S.ScanContents _ [(_, sources)] _ <- S.enumProject proj
-	let
-		projMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file is not null and m.cabal == ?;" (SQLite.Only $ proj ^. projectCabal)
-	scan projMods sources opts $ scanModules opts
-
-		-- Scan docs
-		-- inSessionGhc $ do
-		-- 	currentSession >>= maybe (return ()) (const clearTargets)
-
-		-- 	forM_ (maybe [] targetInfos (proj ^. projectDescription)) $ \tinfo' -> do
-		-- 		opts' <- getProjectTargetOpts [] proj (tinfo' ^. targetBuildInfo)
-		-- 		files' <- projectTargetFiles proj tinfo'
-		-- 		haddockSession opts'
-		-- 		docsMap <- liftGhc $ readProjectTargetDocs opts' proj files'
-		-- 		Log.sendLog Log.Debug $ "scanned logs for modules: {}, summary docs: {}" ~~ (intercalate "," (M.keys docsMap)) ~~ (sum $ map M.size $ M.elems docsMap)
-
-
--- | Scan directory for source files and projects
-scanDirectory :: UpdateMonad m => [String] -> Path -> m ()
-scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do
-	S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory (view path dir)
-	runTasks_ [scanProject opts CabalTool (view projectCabal p) | (p, _) <- projSrcs]
-	runTasks_ $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan
-	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs
-	let
-		standaloneMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.cabal is null and m.file is not null and m.file like ? escape '\\';" (SQLite.Only $ SQLite.escapeLike dir `T.append` "%")
-	scan standaloneMods standSrcs opts $ scanModules opts
-
--- | Scan installed docs
-scanPackageDbStackDocs :: UpdateMonad m => [String] -> PackageDbStack -> m ()
-scanPackageDbStackDocs opts pdbs
-	| hdocsSupported = Log.scope "docs" $ do
-		docs <- inSessionGhc $ hdocsCabal pdbs opts
-		Log.sendLog Log.Trace $ "docs scanned: {} packages, {} modules total"
-			~~ length docs ~~ sum (map (M.size . snd) docs)
-		sendUpdateAction $ transact $ SQLite.executeMany "update symbols set docs = ? where name == ? and module_id in (select id from modules where name == ? and package_name == ? and package_version == ?);" $ do
-			(ModulePackage pname pver, pdocs) <- docs
-			(mname, mdocs) <- M.toList pdocs
-			(nm, doc) <- M.toList mdocs
-			return (doc, nm, mname, pname, pver)
-		Log.sendLog Log.Trace "docs set"
-	| otherwise = Log.sendLog Log.Warning "hdocs not supported"
-
--- | Scan docs for inspected modules
-scanDocs :: UpdateMonad m => [Module] -> m ()
-scanDocs
-	| hdocsSupported = runTasks_ . map scanDocs'
-	| otherwise = const $ Log.sendLog Log.Warning "hdocs not supported"
-	where
-		scanDocs' m = runTask "scanning docs" (view (moduleId . moduleLocation) m) $ Log.scope "docs" $ do
-			mid <- SQLite.lookupModule (m ^. moduleId)
-			mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid
-			m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m
-			Log.sendLog Log.Trace $ "Scanning docs for {}" ~~ view (moduleId . moduleLocation) m'
-			docsMap <- inSessionGhc $ do
-				(pdbs, opts') <- getModuleOpts [] m'
-				currentSession >>= maybe (return ()) (const clearTargets)
-				-- Calling haddock with targets set sometimes cause errors
-				haddockSession pdbs opts'
-				readModuleDocs opts' m'
-			sendUpdateAction $ transact $ do
-				SQLite.executeMany "update symbols set docs = ? where name == ? and module_id == ?;"
-					[(doc, nm, mid') | (nm, doc) <- maybe [] M.toList docsMap]
-				SQLite.execute "update modules set tags = json_set(tags, '$.docs', 1) where id == ?;" (SQLite.Only mid')
-
--- | Set inferred types for module
-setModTypes :: UpdateMonad m => ModuleId -> [Note TypedExpr] -> m ()
-setModTypes m ts = Log.scope "set-types" $ do
-	mid <- SQLite.lookupModule m
-	mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid
-	sendUpdateAction $ transact $ do
-		SQLite.execute "delete from types where module_id = ?;" (SQLite.Only mid')
-		SQLite.executeMany "insert into types (module_id, line, column, line_to, column_to, expr, type) values (?, ?, ?, ?, ?, ?, ?);" [
-			(SQLite.Only mid' SQLite.:. view noteRegion n' SQLite.:. view note n') | n' <- uniqueBy (view noteRegion) ts]
-		SQLite.execute "update names set inferred_type = (select type from types as t where t.module_id = ? and names.line = t.line and names.column = t.column and names.line_to = t.line_to and names.column_to = t.column_to) where module_id == ?;"
-			(mid', mid')
-		SQLite.execute "update symbols set type = (select type from types as t where t.module_id = ? and symbols.line = t.line and symbols.column = t.column order by t.line_to, t.column_to) where module_id == ? and type is null;" (mid', mid')
-		SQLite.execute "update modules set tags = json_set(tags, '$.types', 1) where id == ?;" (SQLite.Only mid')
-
--- | Infer types for modules
-inferModTypes :: UpdateMonad m => [Module] -> m ()
-inferModTypes = runTasks_ . map inferModTypes' where
-	inferModTypes' m = runTask "inferring types" (view (moduleId . moduleLocation) m) $ Log.scope "types" $ do
-		mid <- SQLite.lookupModule (m ^. moduleId)
-		_ <- maybe (hsdevError $ SQLiteError "module id not found") return mid
-		m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m
-		Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view (moduleId . moduleLocation) m'
-
-		sess <- getSession
-		mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile)
-		types' <- inSessionGhc $ do
-			targetSession [] m'
-			cacheGhcWarnings sess (m' ^.. moduleId . moduleLocation) $
-				fileTypes m' mcts
-
-		setModTypes (m' ^. moduleId) types'
-
--- | Generic scan function. Removed obsolete modules and calls callback on changed modules.
-scan :: UpdateMonad m
-	=> m [SQLite.Only Int SQLite.:. ModuleLocation SQLite.:. Inspection]
-	-- ^ Get affected modules, obsolete will be removed, changed will be updated
-	-> [S.ModuleToScan]
-	-- ^ Actual modules, other will be removed
-	-> [String]
-	-- ^ Extra scan options
-	-> ([S.ModuleToScan] -> m ())
-	-- ^ Update function
-	-> m ()
-scan part' mlocs opts act = Log.scope "scan" $ do
-	mlocs' <- liftM (M.fromList . map (\(SQLite.Only mid SQLite.:. (m SQLite.:. i)) -> (m, (mid, i)))) part'
-	let
-		obsolete = M.filterWithKey (\k _ -> k `S.notMember` S.fromList (map (^. _1) mlocs)) mlocs'
-	changed <- S.changedModules (M.map snd mlocs') opts mlocs
-	sendUpdateAction $ Log.scope "remove-obsolete" $ transact $
-		forM_ (M.elems obsolete) $ SQLite.removeModule . fst
-	act changed
-
-processEvents :: ([(Watched, Event)] -> IO ()) -> MVar (A.Async ()) -> MVar [(Watched, Event)] -> [(Watched, Event)] -> ClientM IO ()
-processEvents handleEvents updaterTask eventsVar evs = Log.scope "event" $ do
-	Log.sendLog Log.Trace $ "events received: {}" ~~ intercalate ", " (evs ^.. each . _2 . eventPath)
-	l <- Log.askLog
-	liftIO $ do
-		modifyMVar_ eventsVar (return . (++evs))
-		modifyMVar_ updaterTask $ \task -> do
-			done <- fmap isJust $ poll task
-			if done
-				then do
-					Log.withLog l $ Log.sendLog Log.Trace "starting update thread"
-					A.async $ fix $ \loop -> do
-						updates <- modifyMVar eventsVar (\es -> return ([], es))
-						unless (null updates) $ handleEvents updates >> loop
-				else return task
-
-updateEvents :: ServerMonadBase m => [(Watched, Event)] -> UpdateM m ()
-updateEvents updates = Log.scope "updater" $ do
-	Log.sendLog Log.Trace $ "prepared to process {} events" ~~ length updates
-	files <- fmap concat $ forM updates $ \(w, e) -> case w of
-		WatchedProject proj projOpts
-			| isSource e -> do
-				Log.sendLog Log.Info $ "File '{file}' in project {proj} changed"
-					~~ ("file" ~% view eventPath e)
-					~~ ("proj" ~% view projectName proj)
-				[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)
-				opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts
-				return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]
-			| isCabal e -> do
-				Log.sendLog Log.Info $ "Project {proj} changed"
-					~~ ("proj" ~% view projectName proj)
-				scanProject projOpts (view projectBuildTool proj) (view projectCabal proj)
-				return []
-			| otherwise -> return []
-		WatchedPackageDb pdbs opts
-			| isConf e -> do
-				Log.sendLog Log.Info $ "Package db {package} changed"
-					~~ ("package" ~% topPackageDb pdbs)
-				scanPackageDb opts pdbs
-				return []
-			| otherwise -> return []
-		WatchedModule
-			| isSource e -> do
-				Log.sendLog Log.Info $ "Module {file} changed"
-					~~ ("file" ~% view eventPath e)
-				[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)
-				opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts
-				return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]
-			| otherwise -> return []
-	scanFiles files
-	where
-		parseErr' mopts' = do
-			Log.sendLog Log.Error $ "Error parsing inspection_opts: {}" ~~ show mopts'
-			hsdevError $ SQLiteError $ "Error parsing inspection_opts: {}" ~~ show mopts'
-
-applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO ()
-applyUpdates uopts = runUpdate uopts . updateEvents
-
--- Save ghc warnings on loading target, because second loading won't produce any
-cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a
-cacheGhcWarnings sess mlocs act = Log.scope "cache-warnings" $ do
-	tm <- liftIO getPOSIXTime
-	(r, msgs) <- collectMessages act
-	Log.sendLog Log.Trace $ "collected {} warnings" ~~ length msgs
-	_ <- liftIO $ withSession sess $ postSessionUpdater $ refreshCache mlocs tm msgs
-	return r
-	where
-		refreshCache :: [ModuleLocation] -> POSIXTime -> [Note OutputMessage] -> ServerM IO ()
-		refreshCache mlocs' tm' msgs' = Log.scope "refresh" $ bracket_ initTemp dropTemp $ do
-			fillTemp
-			removeOutdated
-			insertMessages
-			where
-				initTemp :: SessionMonad m => m ()
-				initTemp = do
-					SQLite.execute_ "create temporary table updating_files (file text not null, mtime real not null);"
-					SQLite.execute_ "create index updating_files_index on updating_files (file);"
-					SQLite.execute_ "create temporary table updating_ids (id integer not null unique, mtime real);"
-					SQLite.execute_ "create temporary table updating_messages as select * from messages where 0;"
-					SQLite.execute_ "create index update_messages_module_id_index on updating_messages (module_id);"
-
-				dropTemp :: SessionMonad m => m ()
-				dropTemp = do
-					SQLite.execute_ "drop table if exists updating_files;"
-					SQLite.execute_ "drop table if exists updating_ids;"
-					SQLite.execute_ "drop table if exists updating_messages;"
-
-				fillTemp :: SessionMonad m => m ()
-				fillTemp = do
-					mtimes <- forM (mlocs' ^.. each . moduleFile) $ \file' -> (,) <$> pure file' <*> liftIO (fileMTime file')
-					SQLite.executeMany "insert into updating_files values (?, ?);" mtimes
-					SQLite.execute_ "update updating_files set mtime = coalesce(max(mtime, (select c.mtime from file_contents as c where c.file == updating_files.file)), mtime);"
-					SQLite.execute_ "insert into updating_ids select distinct m.id, coalesce(max(u.mtime, m.inspection_time), u.mtime) from modules as m, updating_files as u where m.file = u.file;"
-					SQLite.executeMany "insert into updating_messages select (select m.id from modules as m where (m.file = ?)), ?, ?, ?, ?, ?, ?, ?;" msgs'
-					SQLite.execute_ "insert into updating_ids select distinct umsgs.module_id, m.inspection_time from updating_messages as umsgs, modules as m where umsgs.module_id = m.id and umsgs.module_id not in (select id from updating_ids);"
-
-				removeOutdated :: SessionMonad m => m ()
-				removeOutdated = SQLite.execute_ $ fromString $ unlines [
-					"delete from messages",
-					"where",
-					" module_id in (",
-					"  select um.id",
-					"  from updating_ids as um",
-					"  left outer join load_times as lt",
-					"  on lt.module_id = um.id",
-					"  where",
-					"   lt.load_time is null or",
-					"   lt.load_time <= um.mtime or",
-					"   um.id in (select distinct umsgs.module_id from updating_messages as umsgs)",
-					" );"]
-
-				insertMessages :: SessionMonad m => m ()
-				insertMessages = SQLite.transaction_ SQLite.Deferred $ do
-					SQLite.execute "insert or replace into load_times (module_id, load_time) select um.id, ? from updating_ids as um;" (SQLite.Only tm')
-					SQLite.execute_ "insert into messages select distinct * from updating_messages;"
-
--- | Get cached warnings
-cachedWarnings :: SessionMonad m => [ModuleLocation] -> m [Note OutputMessage]
-cachedWarnings mlocs = liftM concat $ forM (mlocs ^.. each . moduleFile) $ \f -> SQLite.query @_ @(Note OutputMessage) (SQLite.toQuery $ mconcat [
-	SQLite.qNote "m" "n",
-	SQLite.from_ ["load_times as lt"],
-	SQLite.where_ [
-		"lt.module_id = m.id",
-		"m.file = ?",
-		"lt.load_time >= m.inspection_time"]])
-	(SQLite.Only f)
-
-watch :: SessionMonad m => (Watcher -> IO ()) -> m ()
-watch f = whenJustM (askSession sessionWatcher) $ liftIO . f
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses, RankNTypes, TypeOperators, TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsDev.Database.Update (+	Status(..), Progress(..), Task(..),+	UpdateOptions(..),++	UpdateM(..),+	runUpdate,++	postStatus, updater, runTask, runTasks, runTasks_,++	scanModules, scanFile, scanFiles, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanPackageDbStack, scanProjectFile, scanProjectStack, scanProject, scanDirectory,+	scanPackageDbStackDocs, scanDocs,+	setModTypes, inferModTypes,+	scan,+	processEvents, updateEvents, applyUpdates,++	cacheGhcWarnings, cachedWarnings,++	module HsDev.Database.Update.Types,++	module HsDev.Watcher,++	module Control.Monad.Except+	) where++import qualified Control.Concurrent.Async as A+import Control.Concurrent.MVar+import Control.DeepSeq+import Control.Exception (ErrorCall, evaluate, displayException)+import Control.Lens+import Control.Monad.Catch (catch, handle, MonadThrow, bracket_)+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State (get, modify, runStateT)+import Data.Aeson+import Data.List (intercalate)+import Data.String (fromString)+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.Maybe+import Data.Text (Text)+import Data.Time.Clock.POSIX+import qualified Data.Text as T+import System.FilePath+import qualified System.Log.Simple as Log++import Data.Maybe.JustIf+import HsDev.Error+import qualified HsDev.Database.SQLite as SQLite+import HsDev.Display+import HsDev.Inspect+import HsDev.Inspect.Order+import HsDev.PackageDb+import HsDev.Project+import HsDev.Sandbox+import qualified HsDev.Stack as S+import HsDev.Symbols+import HsDev.Tools.Ghc.Session hiding (Session, evaluate)+import HsDev.Tools.Ghc.Types (fileTypes, TypedExpr)+import HsDev.Tools.Types+import HsDev.Tools.HDocs+import qualified HsDev.Scan as S+import HsDev.Scan.Browse+import HsDev.Util (ordNub, fromJSON', uniqueBy, timer)+import qualified HsDev.Util as Util (withCurrentDirectory)+import HsDev.Server.Types (commandNotify, inSessionGhc, FileSource(..))+import HsDev.Server.Message+import HsDev.Database.Update.Types+import HsDev.Watcher+import Text.Format+import System.Directory.Paths++onStatus :: UpdateMonad m => m ()+onStatus = asks (view (updateOptions . updateTasks)) >>= commandNotify . Notification . toJSON . reverse++childTask :: UpdateMonad m => Task -> m a -> m a+childTask t = local (over (updateOptions . updateTasks) (t:))++transact :: SessionMonad m => m a -> m a+transact = SQLite.transaction_ SQLite.Immediate++runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a+runUpdate uopts act = Log.scope "update" $ do+	(r, updatedMods) <- withUpdateState uopts $ \ust ->+		runWriterT (runUpdateM act' `runReaderT` ust)+	Log.sendLog Log.Debug $ "updated {} modules" ~~ length updatedMods+	return r+	where+		act' = do+			(r, _) <- listen act+			-- (r, mlocs') <- listen act++			-- dbs <- liftM S.unions $ forM mlocs' $ \mloc' -> do+			-- 	mid <- SQLite.lookupModuleLocation mloc'+			-- 	case mid of+			-- 		Nothing -> return (S.empty :: S.Set PackageDb)+			-- 		Just mid' -> liftM (S.fromList . map SQLite.fromOnly) $ SQLite.query (SQLite.toQuery $ SQLite.select_+			-- 			["ps.package_db"]+			-- 			["package_dbs as ps", "modules as m"]+			-- 			["m.package_name == ps.package_name", "m.package_version == ps.package_version", "m.id == ?"]) (SQLite.Only mid')++			-- If some sourced files depends on currently scanned package-dbs+			-- We must resolve them and even rescan if there was errors scanning without+			-- dependencies provided (lack of fixities can cause errors inspecting files)++			-- sboxes = databaseSandboxes dbval+			-- sboxOf :: Path -> Maybe Sandbox+			-- sboxOf fpath = find (pathInSandbox fpath) sboxes+			-- projsRows <- SQLite.query_ "select name, cabal, version, ifnull(package_db_stack, json('[]')) from projects;"+			-- let+			-- 	projs = [proj' | (proj' SQLite.:. (SQLite.Only (SQLite.JSON projPdbs))) <- projsRows,+			-- 		not (S.null (S.fromList projPdbs `S.intersection` dbs))]++			-- 	stands = []+			-- 	-- HOWTO?+			-- 	-- stands = do+			-- 	-- 	sloc <- dbval ^.. standaloneSlice . modules . moduleId . moduleLocation+			-- 	-- 	guard $ sboxUpdated $ sboxOf (sloc ^?! moduleFile)+			-- 	-- 	guard (notElem sloc mlocs')+			-- 	-- 	return (sloc, dbval ^.. databaseModules . ix sloc . inspection . inspectionOpts . each . unpacked, Nothing)++			-- Log.sendLog Log.Trace $ "updated package-dbs: {}, have to rescan {} projects and {} files"+			-- 	~~ intercalate ", " (map display $ S.toList dbs)+			-- 	~~ length projs ~~ length stands+			-- (_, rlocs') <- listen $ runTasks_ (scanModules [] stands : [scanProject [] (proj ^. projectCabal) | proj <- projs])+			-- let+			-- 	ulocs' = filter (isJust . preview moduleFile) (ordNub $ mlocs' ++ rlocs')+			-- 	getMods :: (MonadIO m) => m [InspectedModule]+			-- 	getMods = do+			-- 		db' <- liftIO $ readAsync db+			-- 		return $ filter ((`elem` ulocs') . view inspectedKey) $ toList $ view databaseModules db'++			-- FIXME: Now it's broken since `Database` is not used anymore+			when (view updateDocs uopts) $ do+				Log.sendLog Log.Trace "forking inspecting source docs"+				Log.sendLog Log.Warning "not implemented"+				-- void $ fork (getMods >>= waiter . mapM_ scanDocs_)+			when (view updateInfer uopts) $ do+				Log.sendLog Log.Trace "forking inferring types"+				Log.sendLog Log.Warning "not implemented"+				-- void $ fork (getMods >>= waiter . mapM_ inferModTypes_)+			return r+		-- scanDocs_ :: UpdateMonad m => InspectedModule -> m ()+		-- scanDocs_ im = do+		-- 	im' <- (S.scanModify (\opts -> inSessionGhc . liftGhc . inspectDocsGhc opts) im) <|> return im+		-- 	sendUpdateAction $ Log.scope "scan-docs" $ SQLite.updateModule im'+		-- inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()+		-- inferModTypes_ im = do+		-- 	-- TODO: locate sandbox+		-- 	im' <- (S.scanModify infer' im) <|> return im+		-- 	sendUpdateAction $ Log.scope "infer-types" $ SQLite.updateModule im'+		-- infer' :: UpdateMonad m => [String] -> Module -> m Module+		-- infer' opts m = case preview (moduleId . moduleLocation . moduleFile) m of+		-- 	Nothing -> return m+		-- 	Just _ -> inSessionGhc $ do+		-- 		targetSession opts m+		-- 		inferTypes opts m Nothing++-- | Post status+postStatus :: UpdateMonad m => Task -> m ()+postStatus t = childTask t onStatus++-- | Mark module as updated+updater :: UpdateMonad m => [ModuleLocation] -> m ()+updater mlocs = tell $!! mlocs++-- | Run one task+runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a+runTask action subj act = Log.scope "task" $ do+	postStatus $ set taskStatus StatusWorking task+	x <- childTask task act+	x `deepseq` postStatus (set taskStatus StatusOk task)+	return x+	`catch`+	(\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e)+	where+		task = Task {+			_taskName = action,+			_taskStatus = StatusWorking,+			_taskSubjectType = displayType subj,+			_taskSubjectName = display subj,+			_taskProgress = Nothing }++-- | Run many tasks with numeration+runTasks :: UpdateMonad m => [m a] -> m [a]+runTasks ts = liftM catMaybes $ zipWithM taskNum [1..] (map noErr ts) where+	total = length ts+	taskNum n = local setProgress where+		setProgress = set (updateOptions . updateTasks . _head . taskProgress) (Just (Progress n total))+	noErr v = hsdevIgnore Nothing (Just <$> v)++-- | Run many tasks with numeration+runTasks_ :: UpdateMonad m => [m ()] -> m ()+runTasks_ = void . runTasks++data PreloadFailure = PreloadFailure ModuleLocation Inspection HsDevError++instance NFData PreloadFailure where+	rnf (PreloadFailure mloc insp err) = rnf mloc `seq` rnf insp `seq` rnf err++-- | Scan modules+scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()+scanModules opts ms = Log.scope "scan-modules" $ mapM_ (uncurry scanModules') grouped where+	scanModules' mproj ms' = do+		maybe (return ()) (sendUpdateAction . SQLite.updateProject) mproj+		updater $ ms' ^.. each . _1+		defines <- askSession sessionDefines++		let+			pload (mloc, mopts, mcts) = runTask "preloading" mloc $ do+				mfcts <- maybe (S.getFileContents (mloc ^?! moduleFile)) (const $ return Nothing) mcts+				insp <- liftIO $ fileInspection (mloc ^?! moduleFile) (opts ++ mopts)+				case (mfcts ^? _Just . _1) of+					Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm+					Nothing -> return ()+				let+					inspection' = maybe insp (fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1+					dirtyTag' = maybe id (const $ inspectTag DirtyTag) $ mfcts ^? _Just . _1+					mcts' = mplus mcts (mfcts ^? _Just . _2)+				runInspect mloc $ withInspection (return inspection') $ dirtyTag' $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mcts'++		ploaded <- runTasks (map pload ms')+		sendUpdateAction $ void $ SQLite.upsertModules $ map (fmap (view asModule)) ploaded+		let+			mlocs' = ploaded ^.. each . inspected . preloadedId . moduleLocation++		updater mlocs'++		let+			mcabal = mproj ^? _Just . projectCabal++		(env, fixities) <- loadEnv mcabal++		Log.sendLog Log.Trace $ "resolved environment: {} modules" ~~ M.size env+		case orderBy (preview inspected) ploaded of+			Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err)+			Right ordered -> do+				(ms'', (updEnv, updFixities)) <- flip runStateT (env, fixities) $ runTasks (map inspect' ordered)+				saveEnv mcabal updEnv updFixities+				mlocs'' <- timer "updated scanned modules" $ do+					Log.sendLog Log.Trace $ case mproj of+						Just proj -> "inserting data for resolved modules of project: {}" ~~ proj+						Nothing -> "inserting data for resolved standalone modules"+					sendUpdateAction $ Log.scope "resolved" $ updateResolveds mcabal ms''+					return (ms'' ^.. each . inspectedKey)+				updater mlocs''+				where+					inspect' pmod = runTask "scanning" ploc $ Log.scope "module" $ do+						(env', fixities') <- get+						r <- continueInspect pmod $ \p -> do+							resolved' <- msum [+								resolveModule env' fixities' p,+								do+									lift (Log.sendLog Log.Trace ("error resolving module {}, falling to resolving just imports/scope" ~~ (p ^. preloadedId . moduleLocation)))+									resolvePreloaded env' p]+							eval resolved'+						modify $ mappend (+							maybe mempty resolvedEnv (r ^? inspected),+							maybe mempty resolvedFixitiesTable (r ^? inspected))+						return r+						where+							ploc = pmod ^?! inspected . preloadedId . moduleLocation++	grouped = M.toList $ M.unionsWith (++) [M.singleton (m ^? _1 . moduleProject . _Just) [m] | m <- ms]+	eval v = handle onError (v `deepseq` liftIO (evaluate v)) where+		onError :: MonadThrow m => ErrorCall -> m a+		onError = hsdevError . OtherError . displayException++-- | Scan source file, possibly scanning also related project and installed modules+scanFile :: UpdateMonad m => [String] -> Path -> BuildTool -> Bool -> Bool -> m ()+scanFile opts fpath tool scanProj scanDb = do+	mproj <- fmap (set (_Just . projectBuildTool) tool) $ locateProjectInfo fpath+	sbox <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj+	when scanDb $ do+		[SQLite.Only scanned] <- SQLite.query @_ @(SQLite.Only Bool) "select count(*) > 0 from package_dbs as pdbs where pdbs.package_db = ?;" (SQLite.Only (topPackageDb sbox))+		unless scanned $ scanPackageDbStack opts sbox+	case join (mproj `justIf` scanProj) of+		Nothing -> scanFiles [(FileSource fpath Nothing, opts)]+		Just proj -> scanProject opts tool (view projectCabal proj)++-- | Scan source files, resolving dependent modules+scanFiles :: UpdateMonad m => [(FileSource, [String])] -> m ()+scanFiles fsrcs = runTask "scanning" ("files" :: String) $ Log.scope "files" $ hsdevLiftIO $ do+	Log.sendLog Log.Trace $ "scanning {} files" ~~ length fsrcs+	fpaths' <- traverse (liftIO . canonicalize) $ map (fileSource . fst) fsrcs+	forM_ fpaths' $ \fpath' -> do+		ex <- liftIO $ fileExists fpath'+		unless ex $ hsdevError $ FileNotFound fpath'+	mlocs <- forM fpaths' $ \fpath' -> do+		mids <- SQLite.query (SQLite.toQuery $ SQLite.qModuleId `mappend` SQLite.where_ ["mu.file == ?"]) (SQLite.Only fpath')+		if length mids > 1+			then return (head mids ^. moduleLocation)+			else do+				mproj <- locateProjectInfo fpath'+				return $ FileModule fpath' mproj+	let+		filesMods = liftM concat $ forM fpaths' $ \fpath' -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file == ?;" (SQLite.Only fpath')+	scan filesMods [(mloc, opts, mcts) | (mloc, (FileSource _ mcts, opts)) <- zip mlocs fsrcs] [] $ \mlocs' -> do+		mapM_ ((watch . flip watchModule) . view _1) mlocs'+		S.ScanContents dmods _ _ <- fmap mconcat $ mapM (S.enumDependent . view (_1 . moduleFile . path)) mlocs'+		Log.sendLog Log.Trace $ "dependent modules: {}" ~~ length dmods+		scanModules [] (mlocs' ++ dmods)++-- | Scan source file with contents and resolve dependent modules+scanFileContents :: UpdateMonad m => [String] -> Path -> Maybe Text -> m ()+scanFileContents opts fpath mcts = scanFiles [(FileSource fpath mcts, opts)]++-- | Scan cabal modules, doesn't rescan if already scanned+scanCabal :: UpdateMonad m => [String] -> m ()+scanCabal opts = Log.scope "cabal" $ scanPackageDbStack opts userDb++-- | Prepare sandbox for scanning. This is used for stack project to build & configure.+prepareSandbox :: UpdateMonad m => Sandbox -> m ()+prepareSandbox sbox@(Sandbox StackTool fpath) = Log.scope "prepare" $ runTasks_ [+	runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.buildDeps Nothing]+	where+		dir = takeDirectory $ view path fpath+prepareSandbox _ = return ()++-- | Scan sandbox modules, doesn't rescan if already scanned+scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()+scanSandbox opts sbox = Log.scope "sandbox" $ do+	-- prepareSandbox sbox+	pdbs <- inSessionGhc $ sandboxPackageDbStack sbox+	scanPackageDbStack opts pdbs++-- | Scan top of package-db stack, usable for rescan+scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m ()+scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do+	pdbState <- liftIO $ readPackageDb (topPackageDb pdbs)+	let+		packageDbMods = S.fromList $ concat $ M.elems pdbState+		packages' = M.keys pdbState+	Log.sendLog Log.Trace $ "package-db state: {} modules" ~~ length packageDbMods+	watch (\w -> watchPackageDb w pdbs opts)++	pkgs <- SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only $ topPackageDb pdbs)+	if S.fromList packages' == S.fromList pkgs+		then Log.sendLog Log.Trace "nothing changes, all packages the same"+		else do+			mlocs <- liftM+				(filter (`S.member` packageDbMods)) $+				(inSessionGhc $ listModules opts pdbs packages')+			let+				umlocs = uniqueModuleLocations mlocs+			Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs+			let+				packageDbMods' = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only (topPackageDb pdbs))+			scan packageDbMods' ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do+				ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)+				Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms+				sendUpdateAction $ timer "updated package-db modules" $ do+					SQLite.updateModules ms+					SQLite.updatePackageDb (topPackageDb pdbs) (M.keys pdbState)++				when hdocsSupported $ scanPackageDbStackDocs opts pdbs++				updater $ ms ^.. each . inspectedKey++-- | Scan top of package-db stack, usable for rescan+scanPackageDbStack :: UpdateMonad m => [String] -> PackageDbStack -> m ()+scanPackageDbStack opts pdbs = runTask "scanning" pdbs $ Log.scope "package-db-stack" $ do+	pdbStates <- liftIO $ mapM readPackageDb (packageDbs pdbs)+	let+		packageDbMods = S.fromList $ concat $ concatMap M.elems pdbStates+		packages' = ordNub $ concatMap M.keys pdbStates+	Log.sendLog Log.Trace $ "package-db-stack state: {} modules" ~~ length packageDbMods+	watch (\w -> watchPackageDbStack w pdbs opts)++	pkgs <- liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only pdb)+	if S.fromList packages' == S.fromList pkgs+		then Log.sendLog Log.Trace "nothing changes, all packages the same"+		else do+			mlocs <- liftM+				(filter (`S.member` packageDbMods)) $+				(inSessionGhc $ listModules opts pdbs packages')+			let+				umlocs = uniqueModuleLocations mlocs+			Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs+			let+				packageDbStackMods = liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only pdb)+			scan packageDbStackMods ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do+				ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)+				Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms+				sendUpdateAction $ timer "updated package-db-stack modules" $ do+					SQLite.updateModules ms+					sequence_ [SQLite.updatePackageDb pdb (M.keys pdbState) | (pdb, pdbState) <- zip (packageDbs pdbs) pdbStates]++				-- BUG: I don't know why, but these steps leads to segfault on my PC:+				-- > hsdev scan --cabal --project .+				-- > hsdev check -f .\src\HsDev\Client\Commands.hs+				-- But it works if docs are scanned, it also works from ghci+				+				-- needDocs <- asks (view updateDocs)+				-- ms' <- if needDocs+				-- 	then do+				-- 		docs <- inSessionGhc $ hdocsCabal pdbs opts+				-- 		return $ map (fmap $ setDocs' docs) ms+				-- 	else return ms++				when hdocsSupported $ scanPackageDbStackDocs opts pdbs++				updater $ ms ^.. each . inspectedKey++-- | Scan project file+scanProjectFile :: UpdateMonad m => [String] -> BuildTool -> Path -> m Project+scanProjectFile opts tool cabal = runTask "scanning" cabal $ do+	proj <- fmap (set projectBuildTool tool) $ S.scanProjectFile opts cabal+	pdbs <- inSessionGhc $ getProjectPackageDbStack proj+	let+		proj' = set projectPackageDbStack (Just pdbs) proj+	sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj'+	return proj'++-- | Refine project info and update if necessary+refineProjectInfo :: UpdateMonad m => Project -> m Project+refineProjectInfo proj = do+	[SQLite.Only exist] <- SQLite.query "select count(*) > 0 from projects where cabal == ?;" (SQLite.Only (proj ^. projectCabal))+	if exist+		then SQLite.loadProject (proj ^. projectCabal)+		else runTask "scanning" (proj ^. projectCabal) $ do+			proj' <- liftIO $ loadProject proj+			pdbs <- inSessionGhc $ getProjectPackageDbStack proj'+			let+				proj'' = set projectPackageDbStack (Just pdbs) proj'+			sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj''+			return proj''++-- | Get project info for module+locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project)+locateProjectInfo cabal = liftIO (locateProject (view path cabal)) >>= traverse refineProjectInfo++-- | Scan project and related package-db stack+scanProjectStack :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()+scanProjectStack opts tool cabal = do+	sbox <- liftIO $ projectSandbox tool cabal+	maybe (scanCabal opts) (scanSandbox opts) sbox+	scanProject opts tool cabal++-- | Scan project+scanProject :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()+scanProject opts tool cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do+	proj <- scanProjectFile opts tool cabal+	watch (\w -> watchProject w proj opts)+	S.ScanContents _ [(_, sources)] _ <- S.enumProject proj+	let+		projMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file is not null and m.cabal == ?;" (SQLite.Only $ proj ^. projectCabal)+	scan projMods sources opts $ scanModules opts++		-- Scan docs+		-- inSessionGhc $ do+		-- 	currentSession >>= maybe (return ()) (const clearTargets)++		-- 	forM_ (maybe [] targetInfos (proj ^. projectDescription)) $ \tinfo' -> do+		-- 		opts' <- getProjectTargetOpts [] proj (tinfo' ^. targetBuildInfo)+		-- 		files' <- projectTargetFiles proj tinfo'+		-- 		haddockSession opts'+		-- 		docsMap <- liftGhc $ readProjectTargetDocs opts' proj files'+		-- 		Log.sendLog Log.Debug $ "scanned logs for modules: {}, summary docs: {}" ~~ (intercalate "," (M.keys docsMap)) ~~ (sum $ map M.size $ M.elems docsMap)+++-- | Scan directory for source files and projects+scanDirectory :: UpdateMonad m => [String] -> Path -> m ()+scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do+	S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory (view path dir)+	runTasks_ [scanProject opts CabalTool (view projectCabal p) | (p, _) <- projSrcs]+	runTasks_ $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan+	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs+	let+		standaloneMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.cabal is null and m.file is not null and m.file like ? escape '\\';" (SQLite.Only $ SQLite.escapeLike dir `T.append` "%")+	scan standaloneMods standSrcs opts $ scanModules opts++-- | Scan installed docs+scanPackageDbStackDocs :: UpdateMonad m => [String] -> PackageDbStack -> m ()+scanPackageDbStackDocs opts pdbs+	| hdocsSupported = Log.scope "docs" $ do+		docs <- inSessionGhc $ hdocsCabal pdbs opts+		Log.sendLog Log.Trace $ "docs scanned: {} packages, {} modules total"+			~~ length docs ~~ sum (map (M.size . snd) docs)+		sendUpdateAction $ transact $ SQLite.executeMany "update symbols set docs = ? where name == ? and module_id in (select id from modules where name == ? and package_name == ? and package_version == ?);" $ do+			(ModulePackage pname pver, pdocs) <- docs+			(mname, mdocs) <- M.toList pdocs+			(nm, doc) <- M.toList mdocs+			return (doc, nm, mname, pname, pver)+		Log.sendLog Log.Trace "docs set"+	| otherwise = Log.sendLog Log.Warning "hdocs not supported"++-- | Scan docs for inspected modules+scanDocs :: UpdateMonad m => [Module] -> m ()+scanDocs+	| hdocsSupported = runTasks_ . map scanDocs'+	| otherwise = const $ Log.sendLog Log.Warning "hdocs not supported"+	where+		scanDocs' m = runTask "scanning docs" (view (moduleId . moduleLocation) m) $ Log.scope "docs" $ do+			mid <- SQLite.lookupModule (m ^. moduleId)+			mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid+			m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m+			Log.sendLog Log.Trace $ "Scanning docs for {}" ~~ view (moduleId . moduleLocation) m'+			docsMap <- inSessionGhc $ do+				(pdbs, opts') <- getModuleOpts [] m'+				currentSession >>= maybe (return ()) (const clearTargets)+				-- Calling haddock with targets set sometimes cause errors+				haddockSession pdbs opts'+				readModuleDocs opts' m'+			sendUpdateAction $ transact $ do+				SQLite.executeMany "update symbols set docs = ? where name == ? and module_id == ?;"+					[(doc, nm, mid') | (nm, doc) <- maybe [] M.toList docsMap]+				SQLite.execute "update modules set tags = json_set(tags, '$.docs', 1) where id == ?;" (SQLite.Only mid')++-- | Set inferred types for module+setModTypes :: UpdateMonad m => ModuleId -> [Note TypedExpr] -> m ()+setModTypes m ts = Log.scope "set-types" $ do+	mid <- SQLite.lookupModule m+	mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid+	sendUpdateAction $ transact $ do+		SQLite.execute "delete from types where module_id = ?;" (SQLite.Only mid')+		SQLite.executeMany "insert into types (module_id, line, column, line_to, column_to, expr, type) values (?, ?, ?, ?, ?, ?, ?);" [+			(SQLite.Only mid' SQLite.:. view noteRegion n' SQLite.:. view note n') | n' <- uniqueBy (view noteRegion) ts]+		SQLite.execute "update names set inferred_type = (select type from types as t where t.module_id = ? and names.line = t.line and names.column = t.column and names.line_to = t.line_to and names.column_to = t.column_to) where module_id == ?;"+			(mid', mid')+		SQLite.execute "update symbols set type = (select type from types as t where t.module_id = ? and symbols.line = t.line and symbols.column = t.column order by t.line_to, t.column_to) where module_id == ? and type is null;" (mid', mid')+		SQLite.execute "update modules set tags = json_set(tags, '$.types', 1) where id == ?;" (SQLite.Only mid')++-- | Infer types for modules+inferModTypes :: UpdateMonad m => [Module] -> m ()+inferModTypes = runTasks_ . map inferModTypes' where+	inferModTypes' m = runTask "inferring types" (view (moduleId . moduleLocation) m) $ Log.scope "types" $ do+		mid <- SQLite.lookupModule (m ^. moduleId)+		_ <- maybe (hsdevError $ SQLiteError "module id not found") return mid+		m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m+		Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view (moduleId . moduleLocation) m'++		sess <- getSession+		mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile)+		types' <- inSessionGhc $ do+			targetSession [] m'+			cacheGhcWarnings sess (m' ^.. moduleId . moduleLocation) $+				fileTypes m' mcts++		setModTypes (m' ^. moduleId) types'++-- | Generic scan function. Removed obsolete modules and calls callback on changed modules.+scan :: UpdateMonad m+	=> m [SQLite.Only Int SQLite.:. ModuleLocation SQLite.:. Inspection]+	-- ^ Get affected modules, obsolete will be removed, changed will be updated+	-> [S.ModuleToScan]+	-- ^ Actual modules, other will be removed+	-> [String]+	-- ^ Extra scan options+	-> ([S.ModuleToScan] -> m ())+	-- ^ Update function+	-> m ()+scan part' mlocs opts act = Log.scope "scan" $ do+	mlocs' <- liftM (M.fromList . map (\(SQLite.Only mid SQLite.:. (m SQLite.:. i)) -> (m, (mid, i)))) part'+	let+		obsolete = M.filterWithKey (\k _ -> k `S.notMember` S.fromList (map (^. _1) mlocs)) mlocs'+	changed <- S.changedModules (M.map snd mlocs') opts mlocs+	sendUpdateAction $ Log.scope "remove-obsolete" $ transact $+		forM_ (M.elems obsolete) $ SQLite.removeModule . fst+	act changed++processEvents :: ([(Watched, Event)] -> IO ()) -> MVar (A.Async ()) -> MVar [(Watched, Event)] -> [(Watched, Event)] -> ClientM IO ()+processEvents handleEvents updaterTask eventsVar evs = Log.scope "event" $ do+	Log.sendLog Log.Trace $ "events received: {}" ~~ intercalate ", " (evs ^.. each . _2 . eventPath)+	l <- Log.askLog+	liftIO $ do+		modifyMVar_ eventsVar (return . (++evs))+		modifyMVar_ updaterTask $ \task -> do+			done <- fmap isJust $ poll task+			if done+				then do+					Log.withLog l $ Log.sendLog Log.Trace "starting update thread"+					A.async $ fix $ \loop -> do+						updates <- modifyMVar eventsVar (\es -> return ([], es))+						unless (null updates) $ handleEvents updates >> loop+				else return task++updateEvents :: ServerMonadBase m => [(Watched, Event)] -> UpdateM m ()+updateEvents updates = Log.scope "updater" $ do+	Log.sendLog Log.Trace $ "prepared to process {} events" ~~ length updates+	files <- fmap concat $ forM updates $ \(w, e) -> case w of+		WatchedProject proj projOpts+			| isSource e -> do+				Log.sendLog Log.Info $ "File '{file}' in project {proj} changed"+					~~ ("file" ~% view eventPath e)+					~~ ("proj" ~% view projectName proj)+				[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)+				opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts+				return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]+			| isCabal e -> do+				Log.sendLog Log.Info $ "Project {proj} changed"+					~~ ("proj" ~% view projectName proj)+				scanProject projOpts (view projectBuildTool proj) (view projectCabal proj)+				return []+			| otherwise -> return []+		WatchedPackageDb pdbs opts+			| isConf e -> do+				Log.sendLog Log.Info $ "Package db {package} changed"+					~~ ("package" ~% topPackageDb pdbs)+				scanPackageDb opts pdbs+				return []+			| otherwise -> return []+		WatchedModule+			| isSource e -> do+				Log.sendLog Log.Info $ "Module {file} changed"+					~~ ("file" ~% view eventPath e)+				[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)+				opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts+				return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]+			| otherwise -> return []+	scanFiles files+	where+		parseErr' mopts' = do+			Log.sendLog Log.Error $ "Error parsing inspection_opts: {}" ~~ show mopts'+			hsdevError $ SQLiteError $ "Error parsing inspection_opts: {}" ~~ show mopts'++applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO ()+applyUpdates uopts = runUpdate uopts . updateEvents++-- Save ghc warnings on loading target, because second loading won't produce any+cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a+cacheGhcWarnings sess mlocs act = Log.scope "cache-warnings" $ do+	tm <- liftIO getPOSIXTime+	(r, msgs) <- collectMessages act+	Log.sendLog Log.Trace $ "collected {} warnings" ~~ length msgs+	_ <- liftIO $ withSession sess $ postSessionUpdater $ refreshCache mlocs tm msgs+	return r+	where+		refreshCache :: [ModuleLocation] -> POSIXTime -> [Note OutputMessage] -> ServerM IO ()+		refreshCache mlocs' tm' msgs' = Log.scope "refresh" $ bracket_ initTemp dropTemp $ do+			fillTemp+			removeOutdated+			insertMessages+			where+				initTemp :: SessionMonad m => m ()+				initTemp = do+					SQLite.execute_ "create temporary table updating_files (file text not null, mtime real not null);"+					SQLite.execute_ "create index updating_files_index on updating_files (file);"+					SQLite.execute_ "create temporary table updating_ids (id integer not null unique, mtime real);"+					SQLite.execute_ "create temporary table updating_messages as select * from messages where 0;"+					SQLite.execute_ "create index update_messages_module_id_index on updating_messages (module_id);"++				dropTemp :: SessionMonad m => m ()+				dropTemp = do+					SQLite.execute_ "drop table if exists updating_files;"+					SQLite.execute_ "drop table if exists updating_ids;"+					SQLite.execute_ "drop table if exists updating_messages;"++				fillTemp :: SessionMonad m => m ()+				fillTemp = do+					mtimes <- forM (mlocs' ^.. each . moduleFile) $ \file' -> (,) <$> pure file' <*> liftIO (fileMTime file')+					SQLite.executeMany "insert into updating_files values (?, ?);" mtimes+					SQLite.execute_ "update updating_files set mtime = coalesce(max(mtime, (select c.mtime from file_contents as c where c.file == updating_files.file)), mtime);"+					SQLite.execute_ "insert into updating_ids select distinct m.id, coalesce(max(u.mtime, m.inspection_time), u.mtime) from modules as m, updating_files as u where m.file = u.file;"+					SQLite.executeMany "insert into updating_messages select (select m.id from modules as m where (m.file = ?)), ?, ?, ?, ?, ?, ?, ?;" msgs'+					SQLite.execute_ "insert into updating_ids select distinct umsgs.module_id, m.inspection_time from updating_messages as umsgs, modules as m where umsgs.module_id = m.id and umsgs.module_id not in (select id from updating_ids);"++				removeOutdated :: SessionMonad m => m ()+				removeOutdated = SQLite.execute_ $ fromString $ unlines [+					"delete from messages",+					"where",+					" module_id in (",+					"  select um.id",+					"  from updating_ids as um",+					"  left outer join load_times as lt",+					"  on lt.module_id = um.id",+					"  where",+					"   lt.load_time is null or",+					"   lt.load_time <= um.mtime or",+					"   um.id in (select distinct umsgs.module_id from updating_messages as umsgs)",+					" );"]++				insertMessages :: SessionMonad m => m ()+				insertMessages = SQLite.transaction_ SQLite.Deferred $ do+					SQLite.execute "insert or replace into load_times (module_id, load_time) select um.id, ? from updating_ids as um;" (SQLite.Only tm')+					SQLite.execute_ "insert into messages select distinct * from updating_messages;"++-- | Get cached warnings+cachedWarnings :: SessionMonad m => [ModuleLocation] -> m [Note OutputMessage]+cachedWarnings mlocs = liftM concat $ forM (mlocs ^.. each . moduleFile) $ \f -> SQLite.query @_ @(Note OutputMessage) (SQLite.toQuery $ mconcat [+	SQLite.qNote "m" "n",+	SQLite.from_ ["load_times as lt"],+	SQLite.where_ [+		"lt.module_id = m.id",+		"m.file = ?",+		"lt.load_time >= m.inspection_time"]])+	(SQLite.Only f)++watch :: SessionMonad m => (Watcher -> IO ()) -> m ()+watch f = whenJustM (askSession sessionWatcher) $ liftIO . f