packages feed

hsdev 0.3.1.3 → 0.3.1.4

raw patch · 85 files changed

+12914/−13240 lines, 85 filesdep +haddock-librarydep +traverse-with-classdep −bin-package-dbdep ~Cabaldep ~HTTPdep ~aesonsetup-changed

Dependencies added: haddock-library, traverse-with-class

Dependencies removed: bin-package-db

Dependency ranges changed: Cabal, HTTP, aeson, aeson-pretty, array, async, attoparsec, base, bytestring, containers, cpphs, data-default, deepseq, direct-sqlite, directory, exceptions, filepath, ghc, ghc-boot, ghc-paths, ghc-syb-utils, haddock-api, haskell-names, haskell-src-exts, hdocs, hformat, hlint, hspec, lens, lifted-base, mmorph, monad-control, monad-loops, mtl, network, optparse-applicative, process, regex-pcre-builtin, scientific, sqlite-simple, syb, template-haskell, text, text-region, time, transformers, transformers-base, uniplate, unix, unordered-containers, vector

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
data/hsdev.sql view
@@ -1,350 +1,350 @@--- 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;---- source projects-create table projects (-	id integer primary key autoincrement,-	name text not null,-	cabal text not null, -- path to `.cabal` file-	version text,-	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;
+
+-- source projects
+create table projects (
+	id integer primary key autoincrement,
+	name text not null,
+	cabal text not null, -- path to `.cabal` file
+	version text,
+	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);
hsdev.cabal view
@@ -1,253 +1,246 @@-name:                hsdev-version:             0.3.1.3-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--library-  hs-source-dirs: src-  ghc-options: -Wall -fno-warn-tabs--  if !flag(docs)-    cpp-options: -DNODOCS--  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.0--  if impl(ghc >= 8.2) && impl(ghc < 8.3)-    if flag(docs)-      build-depends:-        haddock-api >= 2.18.0 && < 2.19.0--    build-depends:-      ghc == 8.2.*,-      ghc-boot,-      directory >= 1.2.6.0-  if impl(ghc >= 8.0) && impl(ghc < 8.2)-    if flag(docs)-      build-depends:-        haddock-api >= 2.17.0 && < 2.18.0--    build-depends:-      ghc >= 8.0.0 && < 8.1.0,-      ghc-boot,-      directory >= 1.2.6.0-  if impl(ghc < 8.0)-    if flag(docs)-      build-depends:-        haddock-api >= 2.16.0 && < 2.17.0--    build-depends:-      ghc >= 7.10.0 && < 7.11.0,-      bin-package-db,-      directory == 1.2.2.*--  if flag(docs)-    build-depends:-      hdocs >= 0.5.1--  build-depends:-    base >= 4.7 && < 5,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    array >= 0.5.0,-    async >= 2.0,-    attoparsec >= 0.11.0,-    bytestring >= 0.10.0,-    Cabal >= 1.22.0,-    containers >= 0.5,-    cpphs >= 1.19.0,-    data-default >= 0.5.0,-    deepseq >= 1.4.0,-    exceptions >= 0.6.0,-    filepath >= 1.4.0,-    fsnotify >= 0.2.1,-    ghc-paths >= 0.1.0,-    ghc-syb-utils >= 0.2.3,-    haskell-names >= 0.9.0 && < 0.10.0,-    haskell-src-exts >= 1.18.0 && < 1.21.0,-    hformat >= 0.3.0,-    hlint >= 1.9.13 && < 2.1,-    HTTP >= 4000.2.0,-    lens >= 4.8,-    lifted-base >= 0.2,-    monad-control >= 1.0,-    monad-loops >= 0.4,-    mmorph >= 1.0 && < 1.2,-    mtl >= 2.2.0,-    network >= 2.6.0,-    optparse-applicative >= 0.11,-    process >= 1.2.0,-    regex-pcre-builtin >= 0.94,-    scientific >= 0.3,-    simple-log == 0.9.*,-    stm == 2.4.*,-    direct-sqlite >= 2.3.21,-    sqlite-simple,-    syb >= 0.5.1,-    template-haskell,-    text >= 1.2.0,-    text-region >= 0.3,-    time >= 1.5.0,-    transformers >= 0.4.0,-    transformers-base >= 0.4.0,-    uniplate >= 1.6.0,-    unordered-containers >= 0.2.0,-    vector >= 0.10.0--executable hsdev-  main-is: hsdev.hs-  hs-source-dirs: tools-  ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4"--  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    bytestring >= 0.10.0,-    containers >= 0.5,-    deepseq >= 1.4.0,-    directory,-    exceptions >= 0.6.0,-    filepath >= 1.4.0,-    monad-loops >= 0.4.0,-    mtl >= 2.2.0,-    network >= 2.6.0,-    optparse-applicative >= 0.11,-    process >= 1.2.0,-    text >= 1.2.0,-    transformers >= 0.4.0,-    unordered-containers >= 0.2.0--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:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-lens >= 0.5.0,-    async >= 2.0,-    data-default >= 0.5.0,-    deepseq >= 1.4.0,-    directory,-    filepath >= 1.4.0,-    containers >= 0.5.0,-    hformat == 0.3.*,-    hspec,-    lens >= 4.8,-    mtl >= 2.2.0,-    text >= 1.2.0+name:                hsdev
+version:             0.3.1.4
+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
+
+library
+  hs-source-dirs: src
+  ghc-options: -Wall -fno-warn-tabs
+
+  if !flag(docs)
+    cpp-options: -DNODOCS
+
+  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.4) && impl(ghc < 8.5)
+    build-depends:
+      ghc   == 8.4.*,
+      Cabal == 2.0.1.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.2,
+      haddock-api >= 2.17.4,
+      haddock-library >= 1.4.3 && < 1.6
+
+  -- 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,
+    HTTP                              >= 4000.3.7 && < 4000.4,
+    aeson                             >= 1.2.4.0 && < 1.3,
+    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.6,
+    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.9,
+    filepath                          >= 1.4.1.0 && < 1.5,
+    fsnotify                          >= 0.2.1 && < 0.3,
+    ghc-boot                          >= 8.0.1 && < 8.5,
+    ghc-paths                         >= 0.1.0.9 && < 0.2,
+    ghc-syb-utils                     >= 0.2.3 && < 0.3,
+    haskell-names                     >= 0.9.1 && < 0.10.0,
+    haskell-src-exts                  >= 1.19.1 && < 1.21.0,
+    hformat                           >= 0.1.0.1 && < 0.4,
+    hlint                             >= 2.0.11 && < 2.2,
+    lens                              >= 4.14 && < 4.17,
+    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.6.3.1 && < 2.7,
+    optparse-applicative              >= 0.12.1.0 && < 0.15,
+    process                           >= 1.4.2.0 && < 1.7,
+    regex-pcre-builtin                >= 0.94.4 && < 0.95,
+    scientific                        >= 0.3.4.9 && < 0.4,
+    simple-log                        == 0.9.*,
+    sqlite-simple                     >= 0.4.13.0 && < 0.5,
+    stm                               == 2.4.*,
+    syb                               >= 0.6 && < 0.8,
+    template-haskell                  >= 2.11.0 && < 2.14,
+    text                              >= 1.2.2.2 && < 1.3,
+    text-region                       >= 0.1.0.1 && < 0.4,
+    time                              >= 1.6.0.1 && < 1.9,
+    transformers                      >= 0.5.2.0 && < 0.6,
+    transformers-base                 >= 0.4.4 && < 0.5,
+    traverse-with-class               >= 1.0.0.0 && < 1.1,
+    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.3,
+    aeson-pretty                      >= 0.8.2 && < 0.9,
+    bytestring                        >= 0.10.8.1 && < 0.11,
+    containers                        >= 0.5.7.1 && < 0.6,
+    deepseq                           >= 1.4.2.0 && < 1.5,
+    directory                         >= 1.2.6.2 && < 1.4,
+    exceptions                        >= 0.8.3 && < 0.9,
+    filepath                          >= 1.4.1.0 && < 1.5,
+    monad-loops                       >= 0.4.3 && < 0.5,
+    mtl                               >= 2.2.1 && < 2.3,
+    network                           >= 2.6.3.1 && < 2.7,
+    optparse-applicative              >= 0.12.1.0 && < 0.15,
+    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.3,
+    aeson-lens                        >= 0.5.0,
+    async                             >= 2.1.1.1 && < 2.3,
+    containers                        >= 0.5.7.1 && < 0.6,
+    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.17,
+    mtl                               >= 2.2.1 && < 2.3,
+    text                              >= 1.2.2.2 && < 1.3
src/Control/Apply/Util.hs view
@@ -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
src/Control/Concurrent/FiniteChan.hs view
@@ -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
src/Control/Concurrent/Util.hs view
@@ -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
src/Control/Concurrent/Worker.hs view
@@ -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` onError-		onError :: MonadIO m => SomeException -> m ()-		onError = liftIO . putMVar var . Left-		f = do-			p <- sendChan (workerChan w) (void async', void act')-			unless p $ putMVar var (Left $ SomeException WorkerStopped)-			r <- takeMVar var-			either throwM return r-	async f---- | 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` onError
+		onError :: MonadIO m => SomeException -> m ()
+		onError = liftIO . putMVar var . Left
+		f = do
+			p <- sendChan (workerChan w) (void async', void act')
+			unless p $ putMVar var (Left $ SomeException WorkerStopped)
+			r <- takeMVar var
+			either throwM return r
+	async f
+
+-- | 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
src/Data/Deps.hs view
@@ -1,101 +1,101 @@-{-# 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.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 => 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.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 => 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
src/Data/Help.hs view
@@ -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
src/Data/LookupTable.hs view
@@ -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
src/Data/Maybe/JustIf.hs view
@@ -1,8 +1,8 @@-module Data.Maybe.JustIf (-	justIf-	) where---- | Return @Just@ if True-justIf :: a -> Bool -> Maybe a-x `justIf` True = Just x-_ `justIf` False = Nothing+module Data.Maybe.JustIf (
+	justIf
+	) where
+
+-- | Return @Just@ if True
+justIf :: a -> Bool -> Maybe a
+x `justIf` True = Just x
+_ `justIf` False = Nothing
src/HsDev.hs view
@@ -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
src/HsDev/Client/Commands.hs view
@@ -1,698 +1,698 @@-{-# 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 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 = liftM 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' 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') projs,-		map (Update.scanDirectory ghcs') paths']-runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts-runCommand (RefineDocs projs fs)-	| HDocs.hdocsSupported = toValue $ do-		projects <- traverse findProject projs-		mods <- do-			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)-			return $ projMods ++ fileMods-		updateProcess def [Update.scanDocs mods]-	| otherwise = hsdevError $ OtherError "docs not supported"-runCommand (InferTypes projs fs) = toValue $ do-	projects <- traverse findProject projs-	mods <- do-		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)-		return $ projMods ++ fileMods-	updateProcess def [Update.inferModTypes mods]-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-			w <- lift $ askSession sessionWatcher-			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-				liftIO $ unwatchPackageDb w $ topPackageDb pdbs-		-- Remove package-db stack when possible-		removePackageDbStack = mapM_ removePackageDb' . packageDbStacks-	w <- askSession sessionWatcher-	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-		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-			liftIO . unwatchModule w $ (m ^. moduleLocation)-runCommand RemoveAll = toValue $ do-	SQLite.purge-	w <- askSession sessionWatcher-	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 $ searchSandbox 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) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM-	(mapMaybe Hayoo.hayooAsSymbol . Hayoo.resultResult) $-	liftIO $ hsdevLift $ Hayoo.hayoo 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 <- actualFileContents 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 actualFileContents 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' <- actualFileContents 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 fpath) = toValue $ do-	m <- refineSourceModule fpath-	let-		mname = m ^. moduleId . moduleName-		makeNote mloc r = Tools.Note {-			Tools._noteSource = mloc,-			Tools._noteRegion = r,-			Tools._noteLevel = Nothing,-			Tools._note = AutoFix.Refact "rename" (AutoFix.replace (AutoFix.fromRegion r) newName) }--	defRenames <- do-		-- FIXME: Doesn't take scope into account. If you have modules with same names in different project, it will rename symbols from both-		defRegions <- 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 def_line is not null;" (-			mname,-			nm)-		return $ map (makeNote (m ^. moduleId . moduleLocation)) defRegions--	usageRenames <- do-		-- FIXME: Same as above: doesn't take scope into account-		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 $ defRenames ++ usageRenames-runCommand (GhcEval exprs mfile) = toValue $ do-	mfile' <- traverse actualFileContents 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 actualFileContents 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 = actualFileContents >=> 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-				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 file contents-actualFileContents :: CommandMonad m => FileSource -> m FileSource-actualFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath)-actualFileContents fcts = 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 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' 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') projs,
+		map (Update.scanDirectory ghcs') paths']
+runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts
+runCommand (RefineDocs projs fs)
+	| HDocs.hdocsSupported = toValue $ do
+		projects <- traverse findProject projs
+		mods <- do
+			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)
+			return $ projMods ++ fileMods
+		updateProcess def [Update.scanDocs mods]
+	| otherwise = hsdevError $ OtherError "docs not supported"
+runCommand (InferTypes projs fs) = toValue $ do
+	projects <- traverse findProject projs
+	mods <- do
+		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)
+		return $ projMods ++ fileMods
+	updateProcess def [Update.inferModTypes mods]
+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
+			w <- lift $ askSession sessionWatcher
+			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
+				liftIO $ unwatchPackageDb w $ topPackageDb pdbs
+		-- Remove package-db stack when possible
+		removePackageDbStack = mapM_ removePackageDb' . packageDbStacks
+	w <- askSession sessionWatcher
+	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
+		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
+			liftIO . unwatchModule w $ (m ^. moduleLocation)
+runCommand RemoveAll = toValue $ do
+	SQLite.purge
+	w <- askSession sessionWatcher
+	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 $ searchSandbox 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) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
+	(mapMaybe Hayoo.hayooAsSymbol . Hayoo.resultResult) $
+	liftIO $ hsdevLift $ Hayoo.hayoo 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 <- actualFileContents 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 actualFileContents 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' <- actualFileContents 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 fpath) = toValue $ do
+	m <- refineSourceModule fpath
+	let
+		mname = m ^. moduleId . moduleName
+		makeNote mloc r = Tools.Note {
+			Tools._noteSource = mloc,
+			Tools._noteRegion = r,
+			Tools._noteLevel = Nothing,
+			Tools._note = AutoFix.Refact "rename" (AutoFix.replace (AutoFix.fromRegion r) newName) }
+
+	defRenames <- do
+		-- FIXME: Doesn't take scope into account. If you have modules with same names in different project, it will rename symbols from both
+		defRegions <- 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 def_line is not null;" (
+			mname,
+			nm)
+		return $ map (makeNote (m ^. moduleId . moduleLocation)) defRegions
+
+	usageRenames <- do
+		-- FIXME: Same as above: doesn't take scope into account
+		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 $ defRenames ++ usageRenames
+runCommand (GhcEval exprs mfile) = toValue $ do
+	mfile' <- traverse actualFileContents 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 actualFileContents 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 = actualFileContents >=> 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
+				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 file contents
+actualFileContents :: CommandMonad m => FileSource -> m FileSource
+actualFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath)
+actualFileContents fcts = 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)
src/HsDev/Database/SQLite.hs view
@@ -1,675 +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,-	updateModule,-	removeModuleContents, removeModule,-	insertModuleSymbols,-	upsertModule,-	lookupModuleLocation, lookupModule,-	lookupSymbol,-	lastRow,--	loadModule, loadModules,-	loadProject,--	updateModules,--	-- * 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.Generics.Uniplate.Operations-import Data.List (intercalate)-import Data.Maybe-import qualified Data.Map as M-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.Exts.Syntax hiding (Name, Module)-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.Name-import qualified HsDev.Symbols.HaskellNames as HN-import HsDev.Symbols.Parsed-import HsDev.Symbols.Types hiding (loadProject)-import qualified HsDev.Symbols.Parsed as P-import qualified HsDev.Symbols.Name as Name-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, 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--updateModule :: SessionMonad m => InspectedModule -> m ()-updateModule im = scope "update-module" $ do-	_ <- upsertModule im-	insertModuleSymbols im--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)--upsertModule :: SessionMonad m => InspectedModule -> m Int-upsertModule im = scope "upsert-module" $ do-	mmid <- lookupModuleLocation (im ^. inspectedKey)-	case mmid of-		Nothing -> do-			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) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"-				moduleData-			lastRow-		Just mid' -> do-			execute "update modules set file = ?, cabal = ?, install_dirs = ?, package_name = ?, package_version = ?, installed_name = ?, exposed = ?, other_location = ?, name = ?, docs = ?, fixities = ?, tags = ?, inspection_error = ?, inspection_time = ?, inspection_opts = ? where id == ?;"-				(moduleData :. Only mid')-			return mid'-	where-		moduleData = (-			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]--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;"--	execute_ "delete from imports where module_id in (select id from upserted_modules);"-	execute_ "delete from exports where module_id in (select id from upserted_modules);"-	execute_ "delete from scopes where module_id in (select id from upserted_modules);"-	execute_ "delete from names where module_id in (select id from upserted_modules);"-	execute_ "delete from types where module_id in (select id from upserted_modules);"-	execute_ "delete from symbols where module_id in (select id from upserted_modules);"--	liftM (map fromOnly) $ query_ "select id from upserted_modules;"-	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]--insertModuleSymbols :: SessionMonad m => InspectedModule -> m ()-insertModuleSymbols im = scope "insert-module-symbols" $ do-	[Only mid] <- queryNamed "select id from modules where ((file is null and :file is null) or file = :file) and ((package_name is null and :package_name is null) or package_name = :package_name) and ((package_version is null and :package_version is null) or package_version = :package_version) and ((other_location is null and :other_location is null) or other_location = :other_location) and ((installed_name is null and :installed_name is null) or installed_name = :installed_name);" [-		":file" := im ^? inspectedKey . moduleFile . path,-		":package_name" := im ^? inspectedKey . modulePackage . packageName,-		":package_version" := im ^? inspectedKey . modulePackage . packageVersion,-		":other_location" := im ^? inspectedKey . otherLocationName,-		":installed_name" := im ^? inspectedKey . installedModuleName]-	-- TODO: Delete obsolete symbols (note, that they can be referenced from another modules)-	removeModuleContents mid-	insertModuleImports mid-	insertExportSymbols mid (im ^.. inspected . moduleExports . each)-	insertScopeSymbols mid (M.toList (im ^. inspected . moduleScope))-	maybe (return ()) (insertResolvedNames mid) (im ^? inspected . moduleSource . _Just)-	where-		insertModuleImports :: SessionMonad m => Int -> m ()-		insertModuleImports mid = scope "insert-module-imports" $ do-			case im ^? inspected . moduleSource . _Just of-				Nothing -> return ()-				Just psrc -> do-					let-						imps = childrenBi psrc :: [ImportDecl Ann]-						importRow idecl@(ImportDecl _ mname qual _ _ _ alias specList) = (-							mid,-							idecl ^. pos . positionLine,-							idecl ^. pos . positionColumn,-							getModuleName mname,-							qual,-							fmap getModuleName alias,-							maybe False getHiding specList,-							fmap makeImportList specList)-					executeMany "insert into imports (module_id, line, column, module_name, qualified, alias, hiding, import_list) values (?, ?, ?, ?, ?, ?, ?, ?);"-						(map importRow imps)-					executeNamed "update imports set import_module_id = (select im.id from modules as im, projects_modules_scope as ps where ((ps.cabal is null and :cabal is null) or (ps.cabal == :cabal)) and ps.module_id == im.id and im.name == imports.module_name) where module_id == :module_id;" [-					 ":cabal" := im ^? inspectedKey . moduleProject . _Just . projectCabal,-					 ":module_id" := mid]-			where-				getModuleName (ModuleName _ s) = s-				getHiding (ImportSpecList _ h _) = h--				makeImportList (ImportSpecList _ _ specs) = encode $ map asJson specs-				asJson (IVar _ nm) = object ["name" .= fromName_ (void nm), "what" .= str' "var"]-				asJson (IAbs _ ns nm) = object ["name" .= fromName_ (void nm), "what" .= str' "abs", "ns" .= fromNamespace ns] where-					fromNamespace :: Namespace l -> Maybe String-					fromNamespace (NoNamespace _) = Nothing-					fromNamespace (TypeNamespace _) = Just "type"-					fromNamespace (PatternNamespace _) = Just "pat"-				asJson (IThingAll _ nm) = object ["name" .= fromName_ (void nm), "what" .= str' "all"]-				asJson (IThingWith _ nm cs) = object ["name" .= fromName_ (void nm), "what" .= str' "with", "list" .= map (fromName_ . void . toName') cs] where-					toName' (VarName _ n') = n'-					toName' (ConName _ n') = n'--				str' :: String -> String-				str' = id--		insertExportSymbols :: SessionMonad m => Int -> [Symbol] -> m ()-		insertExportSymbols _ [] = return ()-		insertExportSymbols mid syms = scope "insert-export-symbols" $ withTemporaryTable "export_symbols" (symbolsColumns ++ idColumns) $ do-			dumpSymbols "export_symbols" symbolsColumns syms-			insertMissingModules "export_symbols"-			insertMissingSymbols "export_symbols"-			execute "insert into exports (module_id, symbol_id) select ?, symbol_id from export_symbols;" (Only mid)--		insertScopeSymbols :: SessionMonad m => Int -> [(Name, [Symbol])] -> m ()-		insertScopeSymbols _ [] = return ()-		insertScopeSymbols mid snames = scope "insert-scope-symbols" $ withTemporaryTable "scope_symbols" (symbolsColumns ++ scopeNameColumns ++ idColumns) $ do-			dumpSymbols "scope_symbols" (symbolsColumns ++ scopeNameColumns)-				[(s :. (Name.nameModule nm, Name.nameIdent nm)) | (nm, syms) <- snames, s <- syms]-			insertMissingModules "scope_symbols"-			insertMissingSymbols "scope_symbols"-			execute "insert into scopes (module_id, qualifier, name, symbol_id) select ?, qualifier, ident, symbol_id from scope_symbols;" (Only mid)--		insertResolvedNames :: SessionMonad m => Int -> Parsed -> m ()-		insertResolvedNames mid p = scope "insert-resolved-names" $ do-			insertNames-			replaceQNames-			setResolvedSymbolIds-			where-				insertNames = executeMany insertQuery namesData-				replaceQNames = executeMany insertQuery qnamesData-				setResolvedSymbolIds = execute "update names set symbol_id = (select sc.symbol_id from scopes as sc, symbols as s, modules as m where names.module_id == sc.module_id and ((names.qualifier is null and sc.qualifier is null) or (names.qualifier == sc.qualifier)) and names.name == sc.name and s.id == sc.symbol_id and m.id == s.module_id and s.name == names.resolved_name and s.what == names.resolved_what and m.name == names.resolved_module) where module_id == ? and resolved_module is not null and resolved_name is not null and resolved_what is not null;" (Only mid)-				insertQuery = "insert or replace into names (module_id, qualifier, name, line, column, line_to, column_to, def_line, def_column, resolved_module, resolved_name, resolved_what, resolve_error) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"-				namesData = map toData $ p ^.. P.names-				qnamesData = map toQData $ p ^.. P.qnames-				toData name = (-					mid,-					Nothing :: Maybe Text,-					Name.fromName_ $ void name,-					name ^. P.pos . positionLine,-					name ^. P.pos . positionColumn,-					name ^. P.regionL . regionTo . positionLine,-					name ^. P.regionL . regionTo . positionColumn)-					:. (-					name ^? P.defPos . positionLine,-					name ^? P.defPos . positionColumn,-					(name ^? P.resolvedName) >>= Name.nameModule,-					Name.nameIdent <$> (name ^? P.resolvedName),-					fmap (symbolType . HN.fromSymbol) $ name ^? P.symbolL,-					P.resolveError name)-				toQData qname = (-					mid,-					Name.nameModule $ void qname,-					Name.nameIdent $ void qname,-					qname ^. P.pos . positionLine,-					qname ^. P.pos . positionColumn,-					qname ^. P.regionL . regionTo . positionLine,-					qname ^. P.regionL . regionTo . positionColumn)-					:. (-					qname ^? P.defPos . positionLine,-					qname ^? P.defPos . positionColumn,-					(qname ^? P.resolvedName) >>= Name.nameModule,-					Name.nameIdent <$> (qname ^? P.resolvedName),-					fmap (symbolType . HN.fromSymbol) $ qname ^? P.symbolL,-					P.resolveError qname)--		symbolsColumns :: [String]-		symbolsColumns = [-			"name", "module_name",-			"file", "cabal", "install_dirs", "package_name", "package_version", "installed_name", "exposed", "other_location",-			"docs",-			"line", "column",-			"what", "type", "parent", "constructors", "args", "context", "associate", "pat_type", "pat_constructor"]--		scopeNameColumns :: [String]-		scopeNameColumns = ["qualifier", "ident"]--		idColumns :: [String]-		idColumns = ["module_id", "symbol_id"]--		-- Dumps symbol data to temporary row and fills with 'module_id' and 'symbol_id' fields-		dumpSymbols :: (SessionMonad m, ToRow q) => String -> [String] -> [q] -> m ()-		dumpSymbols tableName columnNames rows = scope "dump-symbols" $ do-			executeMany (fromString ("insert into {} ({}) values ({});" ~~ tableName ~~ intercalate ", " columnNames ~~ intercalate ", " (replicate (length columnNames) "?"))) (map toRow rows)-			updateModuleIds tableName-			updateSymbolIds tableName--		updateModuleIds :: SessionMonad m => String -> m ()-		updateModuleIds tableName = scope "update-module-ids" $-			execute_ (fromString ("update {table} set module_id = (select m.id from modules as m where (m.file = {table}.file) or (m.package_name = {table}.package_name and m.package_version = {table}.package_version and m.installed_name = {table}.installed_name) or (m.other_location = {table}.other_location)) where module_id is null;" ~~ ("table" ~% tableName)))--		updateSymbolIds :: SessionMonad m => String -> m ()-		updateSymbolIds tableName = scope "update-symbol-ids" $-			execute_ (fromString ("update {table} set symbol_id = (select s.id from symbols as s where s.name = {table}.name and s.what = {table}.what and s.module_id = {table}.module_id) where symbol_id is null;" ~~ ("table" ~% tableName)))--		insertMissingModules :: SessionMonad m => String -> m ()-		insertMissingModules tableName = scope "insert-missing-modules" $ do-			execute_ (fromString ("insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name) select distinct file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, module_name from {} where module_id is null;" ~~ tableName))-			updateModuleIds tableName--		insertMissingSymbols :: SessionMonad m => String -> m ()-		insertMissingSymbols tableName = scope "insert-missing-symbols" $ do-			execute_ (fromString ("insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) select distinct name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor from {} where module_id is not null and symbol_id is null;" ~~ tableName))-			updateSymbolIds tableName--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, 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" $ transaction_ Immediate $ do-	ids <- upsertModules ims-	insertModulesSymbols $ zip ids ims---- | Update symbols of bunch of modules-insertModulesSymbols :: SessionMonad m => [(Int, InspectedModule)] -> m ()-insertModulesSymbols ims = scope "update-modules" $ timer "updated modules" $ do-	insertModulesDefs ims-	insertModulesExports ims-	where-		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, 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, 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"
src/HsDev/Database/SQLite/Instances.hs view
@@ -1,357 +1,357 @@-{-# 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.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 (fail $ "Can't parse module location: {}" ~~ show (file, cabal, dirs, pname, pver, iname, iexposed, other)) 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 (fail $ "Can't parse symbol info: {}" ~~ show (what, ty, parent, ctors, args, ctx, assoc, patTy, patCtor)) 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 ToRow Project where-	toRow (Project name _ cabal pdesc dbs) = [-		toField name,-		toField cabal,-		toField $ pdesc ^? _Just . projectVersion,-		toField dbs]--instance FromRow Project where-	fromRow = do-		name <- field-		cabal <- field-		ver <- field-		dbs <- field-		return $ Project name (takeDir cabal) cabal (fmap (\v -> ProjectDescription v Nothing [] []) ver) dbs--instance FromRow Library where-	fromRow = do-		mods <- field >>= maybe (fail "Error parsing library modules") 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 (fail "Error parsing depends") return . fromJSON') <*>-		field <*>-		(field >>= maybe (fail "Error parsing extensions") return . fromJSON') <*>-		(field >>= maybe (fail "Error parsing ghc-options") return . fromJSON') <*>-		(field >>= maybe (fail "Error parsing source-dirs") return . fromJSON') <*>-		(field >>= maybe (fail "Error parsing other-modules") return . fromJSON')--instance FromField Language where-	fromField fld = case fieldData fld of-		SQLText txt -> parseDT "Language" (T.unpack txt)-		_ -> fail "Can't parse language, invalid type"--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 -> fail $ "Can't parse package-db, invalid string: " ++ T.unpack s--instance ToField PackageDbStack where-	toField = toField . toJSON . packageDbs--instance FromField PackageDbStack where-	fromField = fromField >=> maybe (fail "Error parsing package-db-stack") (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 (fail "Error parsing inspection opts") return (fromJSON' opts')-			(Just _, Nothing) -> fail "Error parsing inspection data, time is set, but flags are null"--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 (fail $ "Can't parse symbol: {}" ~~ show (what, mname, name, parent, ctors, assoc, patType, patCtor)) 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,-			fail ("Unknown severity: {}" ~~ s)]--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.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 (fail $ "Can't parse module location: {}" ~~ show (file, cabal, dirs, pname, pver, iname, iexposed, other)) 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 (fail $ "Can't parse symbol info: {}" ~~ show (what, ty, parent, ctors, args, ctx, assoc, patTy, patCtor)) 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 ToRow Project where
+	toRow (Project name _ cabal pdesc dbs) = [
+		toField name,
+		toField cabal,
+		toField $ pdesc ^? _Just . projectVersion,
+		toField dbs]
+
+instance FromRow Project where
+	fromRow = do
+		name <- field
+		cabal <- field
+		ver <- field
+		dbs <- field
+		return $ Project name (takeDir cabal) cabal (fmap (\v -> ProjectDescription v Nothing [] []) ver) dbs
+
+instance FromRow Library where
+	fromRow = do
+		mods <- field >>= maybe (fail "Error parsing library modules") 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 (fail "Error parsing depends") return . fromJSON') <*>
+		field <*>
+		(field >>= maybe (fail "Error parsing extensions") return . fromJSON') <*>
+		(field >>= maybe (fail "Error parsing ghc-options") return . fromJSON') <*>
+		(field >>= maybe (fail "Error parsing source-dirs") return . fromJSON') <*>
+		(field >>= maybe (fail "Error parsing other-modules") return . fromJSON')
+
+instance FromField Language where
+	fromField fld = case fieldData fld of
+		SQLText txt -> parseDT "Language" (T.unpack txt)
+		_ -> fail "Can't parse language, invalid type"
+
+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 -> fail $ "Can't parse package-db, invalid string: " ++ T.unpack s
+
+instance ToField PackageDbStack where
+	toField = toField . toJSON . packageDbs
+
+instance FromField PackageDbStack where
+	fromField = fromField >=> maybe (fail "Error parsing package-db-stack") (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 (fail "Error parsing inspection opts") return (fromJSON' opts')
+			(Just _, Nothing) -> fail "Error parsing inspection data, time is set, but flags are null"
+
+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 (fail $ "Can't parse symbol: {}" ~~ show (what, mname, name, parent, ctors, assoc, patType, patCtor)) 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,
+			fail ("Unknown severity: {}" ~~ s)]
+
+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]
src/HsDev/Database/SQLite/Schema.hs view
@@ -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
src/HsDev/Database/SQLite/Schema/TH.hs view
@@ -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 #-}
+
+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 |]
src/HsDev/Database/SQLite/Select.hs view
@@ -1,155 +1,155 @@-{-# 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 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 Monoid (Select a) where-	mempty = Select mempty mempty mempty-	Select lc lt lcond `mappend` Select rc rt rcond = Select-		(lc `mappend` rc)-		(lt `mappend` rt)-		(lcond `mappend` rcond)--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 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 Monoid (Select a) where
+	mempty = Select mempty mempty mempty
+	Select lc lt lcond `mappend` Select rc rt rcond = Select
+		(lc `mappend` rc)
+		(lt `mappend` rt)
+		(lcond `mappend` rcond)
+
+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
src/HsDev/Database/SQLite/Transaction.hs view
@@ -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
src/HsDev/Database/Update.hs view
@@ -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, scanProjectFile, scanProjectStack, scanProject, scanDirectory, scanContents,-	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 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')-		mapM_ (SQLite.upsertModule . 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, resolve dependent modules-scanFile :: UpdateMonad m => [String] -> Path -> m ()-scanFile opts fpath = scanFiles [(FileSource fpath Nothing, opts)]---- | 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 StackWork 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')-			Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs-			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' ((,,) <$> mlocs <*> 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')-			Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs-			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 ((,,) <$> mlocs <*> 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] -> Path -> m Project-scanProjectFile opts cabal = runTask "scanning" cabal $ do-	proj <- 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] -> Path -> m ()-scanProjectStack opts cabal = do-	proj <- scanProjectFile opts cabal-	scanProject opts cabal-	sbox <- liftIO $ projectSandbox (view projectPath proj)-	maybe (scanCabal opts) (scanSandbox opts) sbox---- | Scan project-scanProject :: UpdateMonad m => [String] -> Path -> m ()-scanProject opts cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do-	proj <- scanProjectFile opts 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 (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--scanContents :: UpdateMonad m => [String] -> S.ScanContents -> m ()-scanContents opts (S.ScanContents standSrcs projSrcs pdbss) = do-	projs <- liftM (map SQLite.fromOnly) $ SQLite.query_ "select cabal from projects;"-	pdbs <- liftM (map SQLite.fromOnly) $ SQLite.query_ "select package_db from package_dbs;"-	let-		filesMods = 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 is null;"-	runTasks_ [scanPackageDb opts pdbs' | pdbs' <- pdbss, topPackageDb pdbs' `notElem` pdbs]-	runTasks_ [scanProject opts (view projectCabal p) | (p, _) <- projSrcs, view projectCabal p `notElem` projs]-	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs-	scan filesMods 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 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_ids (id integer not null unique);"-					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_ids;"-					SQLite.execute_ "drop table if exists updating_messages;"--				fillTemp :: SessionMonad m => m ()-				fillTemp = do-					SQLite.executeMany "insert into updating_ids select distinct m.id from modules as m where (m.file = ?);" $ (map SQLite.Only $ mlocs' ^.. each . moduleFile)-					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 from updating_messages as umsgs where 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, modules as m",-					"  left outer join",-					"   load_times as lt",-					"  on",-					"   lt.module_id = um.id",-					"  where",-					"   um.id = m.id and (",-					"    lt.load_time is null or",-					"    lt.load_time <= m.inspection_time 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 = do-	w <- askSession sessionWatcher-	liftIO $ f w+{-# 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, scanProjectFile, scanProjectStack, scanProject, scanDirectory, scanContents,
+	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 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, resolve dependent modules
+scanFile :: UpdateMonad m => [String] -> Path -> m ()
+scanFile opts fpath = scanFiles [(FileSource fpath Nothing, opts)]
+
+-- | 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 StackWork 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')
+			Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs
+			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' ((,,) <$> mlocs <*> 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')
+			Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs
+			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 ((,,) <$> mlocs <*> 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] -> Path -> m Project
+scanProjectFile opts cabal = runTask "scanning" cabal $ do
+	proj <- 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] -> Path -> m ()
+scanProjectStack opts cabal = do
+	proj <- scanProjectFile opts cabal
+	scanProject opts cabal
+	sbox <- liftIO $ projectSandbox (view projectPath proj)
+	maybe (scanCabal opts) (scanSandbox opts) sbox
+
+-- | Scan project
+scanProject :: UpdateMonad m => [String] -> Path -> m ()
+scanProject opts cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do
+	proj <- scanProjectFile opts 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 (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
+
+scanContents :: UpdateMonad m => [String] -> S.ScanContents -> m ()
+scanContents opts (S.ScanContents standSrcs projSrcs pdbss) = do
+	projs <- liftM (map SQLite.fromOnly) $ SQLite.query_ "select cabal from projects;"
+	pdbs <- liftM (map SQLite.fromOnly) $ SQLite.query_ "select package_db from package_dbs;"
+	let
+		filesMods = 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 is null;"
+	runTasks_ [scanPackageDb opts pdbs' | pdbs' <- pdbss, topPackageDb pdbs' `notElem` pdbs]
+	runTasks_ [scanProject opts (view projectCabal p) | (p, _) <- projSrcs, view projectCabal p `notElem` projs]
+	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs
+	scan filesMods 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 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_ids (id integer not null unique);"
+					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_ids;"
+					SQLite.execute_ "drop table if exists updating_messages;"
+
+				fillTemp :: SessionMonad m => m ()
+				fillTemp = do
+					SQLite.executeMany "insert into updating_ids select distinct m.id from modules as m where (m.file = ?);" $ (map SQLite.Only $ mlocs' ^.. each . moduleFile)
+					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 from updating_messages as umsgs where 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, modules as m",
+					"  left outer join",
+					"   load_times as lt",
+					"  on",
+					"   lt.module_id = um.id",
+					"  where",
+					"   um.id = m.id and (",
+					"    lt.load_time is null or",
+					"    lt.load_time <= m.inspection_time 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 = do
+	w <- askSession sessionWatcher
+	liftIO $ f w
src/HsDev/Database/Update/Types.hs view
@@ -1,144 +1,144 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ConstraintKinds, FlexibleContexts, TemplateHaskell #-}--module HsDev.Database.Update.Types (-	Status(..), Progress(..), Task(..),-	UpdateOptions(..), updateTasks, updateGhcOpts, updateDocs, updateInfer,-	UpdateState(..), updateOptions, updateWorker, withUpdateState, sendUpdateAction,-	UpdateM(..), UpdateMonad,-	taskName, taskStatus, taskSubjectType, taskSubjectName, taskProgress,--	module HsDev.Server.Types-	) where--import Control.Applicative-import Control.Lens (makeLenses)-import Control.Monad.Base-import Control.Monad.Catch-import Control.Monad.Except-import Control.Monad.Morph-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.Trans.Control-import Data.Aeson-import Data.Functor-import Data.Default-import qualified System.Log.Simple as Log--import Control.Concurrent.Worker-import HsDev.Server.Types hiding (Command(..))-import HsDev.Symbols-import HsDev.Types-import HsDev.Util ((.::), logAll)--data Status = StatusWorking | StatusOk | StatusError HsDevError--instance ToJSON Status where-	toJSON StatusWorking = toJSON ("working" :: String)-	toJSON StatusOk = toJSON ("ok" :: String)-	toJSON (StatusError e) = toJSON e--instance FromJSON Status where-	parseJSON v = msum $ map ($ v) [-		withText "status" $ \t -> guard (t == "working") $> StatusWorking,-		withText "status" $ \t -> guard (t == "ok") $> StatusOk,-		liftM StatusError . parseJSON,-		fail "invalid status"]--data Progress = Progress {-	progressCurrent :: Int,-	progressTotal :: Int }--instance ToJSON Progress where-	toJSON (Progress c t) = object [-		"current" .= c,-		"total" .= t]--instance FromJSON Progress where-	parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total")--data Task = Task {-	_taskName :: String,-	_taskStatus :: Status,-	_taskSubjectType :: String,-	_taskSubjectName :: String,-	_taskProgress :: Maybe Progress }--makeLenses ''Task--instance ToJSON Task where-	toJSON t = object [-		"task" .= _taskName t,-		"status" .= _taskStatus t,-		"type" .= _taskSubjectType t,-		"name" .= _taskSubjectName t,-		"progress" .= _taskProgress t]--instance FromJSON Task where-	parseJSON = withObject "task" $ \v -> Task <$>-		(v .:: "task") <*>-		(v .:: "status") <*>-		(v .:: "type") <*>-		(v .:: "name") <*>-		(v .:: "progress")--data UpdateOptions = UpdateOptions {-	_updateTasks :: [Task],-	_updateGhcOpts :: [String],-	_updateDocs :: Bool,-	_updateInfer :: Bool }--instance Default UpdateOptions where-	def = UpdateOptions [] [] False False--makeLenses ''UpdateOptions--data UpdateState = UpdateState {-	_updateOptions :: UpdateOptions,-	_updateWorker :: Worker (ServerM IO) }--makeLenses ''UpdateState--withUpdateState :: SessionMonad m => UpdateOptions -> (UpdateState -> m a) -> m a-withUpdateState uopts fn = do-	session <- getSession-	bracket (liftIO $ startWorker (withSession session . Log.component "sqlite" . Log.scope "update") id logAll) (liftIO . joinWorker) $ \w ->-		fn (UpdateState uopts w)-	-- where-	-- 	enterTransaction act = do-	-- 		Log.sendLog Log.Trace "entering sqlite transaction"-	-- 		timer "closed transaction" $ transaction_ Immediate $ do-	-- 			Log.sendLog Log.Debug "updating sql database"-	-- 			_ <- act-	-- 			Log.sendLog Log.Debug "sql database updated"--type UpdateMonad m = (CommandMonad m, MonadReader UpdateState m, MonadWriter [ModuleLocation] m)--sendUpdateAction :: UpdateMonad m => ServerM IO () -> m ()-sendUpdateAction act = do-	w <- asks _updateWorker-	liftIO $ inWorker w act--newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m)) a }-	deriving (Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask, Functor, MonadReader UpdateState, MonadWriter [ModuleLocation])--instance MonadTrans UpdateM where-	lift = UpdateM . lift . lift . lift--instance (MonadIO m, MonadMask m) => Log.MonadLog (UpdateM m) where-	askLog = UpdateM $ lift $ lift Log.askLog-	localLog fn = UpdateM . hoist (hoist (Log.localLog fn)) . runUpdateM--instance ServerMonadBase m => SessionMonad (UpdateM m) where-	getSession = UpdateM $ lift $ lift getSession-	localSession fn = UpdateM . hoist (hoist (localSession fn)) . runUpdateM--instance ServerMonadBase m => CommandMonad (UpdateM m) where-	getOptions = UpdateM $ lift $ lift getOptions--instance MonadBase b m => MonadBase b (UpdateM m) where-	liftBase = UpdateM . liftBase--instance MonadBaseControl b m => MonadBaseControl b (UpdateM m) where-	type StM (UpdateM m) a = StM (ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m))) a-	liftBaseWith f = UpdateM $ liftBaseWith (\f' -> f (f' . runUpdateM))-	restoreM = UpdateM . restoreM+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ConstraintKinds, FlexibleContexts, TemplateHaskell #-}
+
+module HsDev.Database.Update.Types (
+	Status(..), Progress(..), Task(..),
+	UpdateOptions(..), updateTasks, updateGhcOpts, updateDocs, updateInfer,
+	UpdateState(..), updateOptions, updateWorker, withUpdateState, sendUpdateAction,
+	UpdateM(..), UpdateMonad,
+	taskName, taskStatus, taskSubjectType, taskSubjectName, taskProgress,
+
+	module HsDev.Server.Types
+	) where
+
+import Control.Applicative
+import Control.Lens (makeLenses)
+import Control.Monad.Base
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.Morph
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.Trans.Control
+import Data.Aeson
+import Data.Functor
+import Data.Default
+import qualified System.Log.Simple as Log
+
+import Control.Concurrent.Worker
+import HsDev.Server.Types hiding (Command(..))
+import HsDev.Symbols
+import HsDev.Types
+import HsDev.Util ((.::), logAll)
+
+data Status = StatusWorking | StatusOk | StatusError HsDevError
+
+instance ToJSON Status where
+	toJSON StatusWorking = toJSON ("working" :: String)
+	toJSON StatusOk = toJSON ("ok" :: String)
+	toJSON (StatusError e) = toJSON e
+
+instance FromJSON Status where
+	parseJSON v = msum $ map ($ v) [
+		withText "status" $ \t -> guard (t == "working") $> StatusWorking,
+		withText "status" $ \t -> guard (t == "ok") $> StatusOk,
+		liftM StatusError . parseJSON,
+		fail "invalid status"]
+
+data Progress = Progress {
+	progressCurrent :: Int,
+	progressTotal :: Int }
+
+instance ToJSON Progress where
+	toJSON (Progress c t) = object [
+		"current" .= c,
+		"total" .= t]
+
+instance FromJSON Progress where
+	parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total")
+
+data Task = Task {
+	_taskName :: String,
+	_taskStatus :: Status,
+	_taskSubjectType :: String,
+	_taskSubjectName :: String,
+	_taskProgress :: Maybe Progress }
+
+makeLenses ''Task
+
+instance ToJSON Task where
+	toJSON t = object [
+		"task" .= _taskName t,
+		"status" .= _taskStatus t,
+		"type" .= _taskSubjectType t,
+		"name" .= _taskSubjectName t,
+		"progress" .= _taskProgress t]
+
+instance FromJSON Task where
+	parseJSON = withObject "task" $ \v -> Task <$>
+		(v .:: "task") <*>
+		(v .:: "status") <*>
+		(v .:: "type") <*>
+		(v .:: "name") <*>
+		(v .:: "progress")
+
+data UpdateOptions = UpdateOptions {
+	_updateTasks :: [Task],
+	_updateGhcOpts :: [String],
+	_updateDocs :: Bool,
+	_updateInfer :: Bool }
+
+instance Default UpdateOptions where
+	def = UpdateOptions [] [] False False
+
+makeLenses ''UpdateOptions
+
+data UpdateState = UpdateState {
+	_updateOptions :: UpdateOptions,
+	_updateWorker :: Worker (ServerM IO) }
+
+makeLenses ''UpdateState
+
+withUpdateState :: SessionMonad m => UpdateOptions -> (UpdateState -> m a) -> m a
+withUpdateState uopts fn = do
+	session <- getSession
+	bracket (liftIO $ startWorker (withSession session . Log.component "sqlite" . Log.scope "update") id logAll) (liftIO . joinWorker) $ \w ->
+		fn (UpdateState uopts w)
+	-- where
+	-- 	enterTransaction act = do
+	-- 		Log.sendLog Log.Trace "entering sqlite transaction"
+	-- 		timer "closed transaction" $ transaction_ Immediate $ do
+	-- 			Log.sendLog Log.Debug "updating sql database"
+	-- 			_ <- act
+	-- 			Log.sendLog Log.Debug "sql database updated"
+
+type UpdateMonad m = (CommandMonad m, MonadReader UpdateState m, MonadWriter [ModuleLocation] m)
+
+sendUpdateAction :: UpdateMonad m => ServerM IO () -> m ()
+sendUpdateAction act = do
+	w <- asks _updateWorker
+	liftIO $ inWorker w act
+
+newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m)) a }
+	deriving (Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask, Functor, MonadReader UpdateState, MonadWriter [ModuleLocation])
+
+instance MonadTrans UpdateM where
+	lift = UpdateM . lift . lift . lift
+
+instance (MonadIO m, MonadMask m) => Log.MonadLog (UpdateM m) where
+	askLog = UpdateM $ lift $ lift Log.askLog
+	localLog fn = UpdateM . hoist (hoist (Log.localLog fn)) . runUpdateM
+
+instance ServerMonadBase m => SessionMonad (UpdateM m) where
+	getSession = UpdateM $ lift $ lift getSession
+	localSession fn = UpdateM . hoist (hoist (localSession fn)) . runUpdateM
+
+instance ServerMonadBase m => CommandMonad (UpdateM m) where
+	getOptions = UpdateM $ lift $ lift getOptions
+
+instance MonadBase b m => MonadBase b (UpdateM m) where
+	liftBase = UpdateM . liftBase
+
+instance MonadBaseControl b m => MonadBaseControl b (UpdateM m) where
+	type StM (UpdateM m) a = StM (ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m))) a
+	liftBaseWith f = UpdateM $ liftBaseWith (\f' -> f (f' . runUpdateM))
+	restoreM = UpdateM . restoreM
src/HsDev/Display.hs view
@@ -1,22 +1,22 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Display (-	Display(..)-	) where--import Control.Lens (view)--import System.Directory.Paths--class Display a where-	display :: a -> String-	displayType :: a -> String--instance Display FilePath where-	display = id-	displayType _ = "path"--instance Display Path where-	display = view path-	displayType _ = "path"+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Display (
+	Display(..)
+	) where
+
+import Control.Lens (view)
+
+import System.Directory.Paths
+
+class Display a where
+	display :: a -> String
+	displayType :: a -> String
+
+instance Display FilePath where
+	display = id
+	displayType _ = "path"
+
+instance Display Path where
+	display = view path
+	displayType _ = "path"
src/HsDev/Error.hs view
@@ -1,53 +1,53 @@-{-# LANGUAGE FlexibleContexts #-}--module HsDev.Error (-	hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore,-	hsdevHandle,--	module HsDev.Types-	) where--import Prelude--import Control.Exception (IOException)-import Control.Monad.Catch-import Control.Monad.Except--import HsDev.Types---- | Throw `HsDevError`-hsdevError :: MonadThrow m => HsDevError -> m a-hsdevError = throwM---- | Throw as `OtherError`-hsdevOtherError :: (Exception e, MonadThrow m) => e -> m a-hsdevOtherError = hsdevError . OtherError . displayException---- | Throw as `OtherError`-hsdevLift :: MonadThrow m => ExceptT String m a -> m a-hsdevLift = hsdevLiftWith OtherError---- | Throw as some `HsDevError`-hsdevLiftWith :: MonadThrow m => (String -> HsDevError) -> ExceptT String m a -> m a-hsdevLiftWith ctor act = runExceptT act >>= either (hsdevError . ctor) return--hsdevCatch :: MonadCatch m => m a -> m (Either HsDevError a)-hsdevCatch = try---- | Rethrow IO exceptions as `HsDevError`-hsdevLiftIO :: MonadCatch m => m a -> m a-hsdevLiftIO = hsdevLiftIOWith IOFailed---- | Rethrow IO exceptions-hsdevLiftIOWith :: MonadCatch m => (String -> HsDevError) -> m a -> m a-hsdevLiftIOWith ctor act = catch act onError where-	onError :: MonadThrow m => IOException -> m a-	onError = hsdevError . ctor . displayException---- | Ignore hsdev exception-hsdevIgnore :: MonadCatch m => a -> m a -> m a-hsdevIgnore v act = hsdevCatch act >>= either (const $ return v) return---- | Handle hsdev exception-hsdevHandle :: MonadCatch m => (HsDevError -> m a) -> m a -> m a-hsdevHandle h act = hsdevCatch act >>= either h return+{-# LANGUAGE FlexibleContexts #-}
+
+module HsDev.Error (
+	hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore,
+	hsdevHandle,
+
+	module HsDev.Types
+	) where
+
+import Prelude
+
+import Control.Exception (IOException)
+import Control.Monad.Catch
+import Control.Monad.Except
+
+import HsDev.Types
+
+-- | Throw `HsDevError`
+hsdevError :: MonadThrow m => HsDevError -> m a
+hsdevError = throwM
+
+-- | Throw as `OtherError`
+hsdevOtherError :: (Exception e, MonadThrow m) => e -> m a
+hsdevOtherError = hsdevError . OtherError . displayException
+
+-- | Throw as `OtherError`
+hsdevLift :: MonadThrow m => ExceptT String m a -> m a
+hsdevLift = hsdevLiftWith OtherError
+
+-- | Throw as some `HsDevError`
+hsdevLiftWith :: MonadThrow m => (String -> HsDevError) -> ExceptT String m a -> m a
+hsdevLiftWith ctor act = runExceptT act >>= either (hsdevError . ctor) return
+
+hsdevCatch :: MonadCatch m => m a -> m (Either HsDevError a)
+hsdevCatch = try
+
+-- | Rethrow IO exceptions as `HsDevError`
+hsdevLiftIO :: MonadCatch m => m a -> m a
+hsdevLiftIO = hsdevLiftIOWith IOFailed
+
+-- | Rethrow IO exceptions
+hsdevLiftIOWith :: MonadCatch m => (String -> HsDevError) -> m a -> m a
+hsdevLiftIOWith ctor act = catch act onError where
+	onError :: MonadThrow m => IOException -> m a
+	onError = hsdevError . ctor . displayException
+
+-- | Ignore hsdev exception
+hsdevIgnore :: MonadCatch m => a -> m a -> m a
+hsdevIgnore v act = hsdevCatch act >>= either (const $ return v) return
+
+-- | Handle hsdev exception
+hsdevHandle :: MonadCatch m => (HsDevError -> m a) -> m a -> m a
+hsdevHandle h act = hsdevCatch act >>= either h return
src/HsDev/Inspect.hs view
@@ -1,316 +1,316 @@-{-# LANGUAGE CPP, TypeSynonymInstances, ImplicitParams, TemplateHaskell #-}--module HsDev.Inspect (-	preload,-	AnalyzeEnv(..), analyzeEnv, analyzeFixities, analyzeRefine, moduleAnalyzeEnv,-	analyzeResolve, analyzePreloaded,-	inspectDocs, inspectDocsGhc,-	inspectContents, contentsInspection,-	inspectFile, sourceInspection, fileInspection, fileContentsInspection, fileContentsInspection_, installedInspection, moduleInspection,-	projectDirs, projectSources,-	getDefines,-	preprocess, preprocess_,--	module HsDev.Inspect.Types,-	module HsDev.Inspect.Resolve,-	module Control.Monad.Except-	) where--import Control.DeepSeq-import qualified Control.Exception as E-import Control.Lens-import Control.Monad-import Control.Monad.Catch-import Control.Monad.Reader-import Control.Monad.Except-import Data.List-import Data.Map.Strict (Map)-import Data.Maybe (fromMaybe, mapMaybe)-import Data.String-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime, POSIXTime)-import qualified Data.Map.Strict as M-import qualified Language.Haskell.Exts as H-import Language.Haskell.Exts.Fixity-import qualified Language.Haskell.Names as N-import qualified Language.Haskell.Names.Annotated as N-import qualified Language.Haskell.Names.SyntaxUtils as N-import qualified Language.Haskell.Names.Exports as N-import qualified Language.Haskell.Names.Imports as N-import qualified Language.Haskell.Names.ModuleSymbols as N-import qualified Language.Haskell.Names.Open as N-import qualified Language.Preprocessor.Cpphs as Cpphs-import qualified System.Directory as Dir-import System.FilePath-import Text.Format--import HsDev.Display ()-import HsDev.Error-import HsDev.Inspect.Definitions-import HsDev.Inspect.Types-import HsDev.Inspect.Resolve-import HsDev.Sandbox (searchPackageDbStack)-import HsDev.Symbols-import HsDev.Symbols.Resolve (refineSymbol, refineTable, RefineTable)-import qualified HsDev.Symbols.HaskellNames as HN-import HsDev.Tools.Base-import HsDev.Tools.Ghc.Worker (GhcM)-import HsDev.Tools.HDocs (hdocs, hdocsProcess, readModuleDocs)-import HsDev.Util-import System.Directory.Paths---- | Preload module - load head and imports to get actual extensions and dependencies-preload :: (MonadIO m, MonadCatch m) => Text -> [(String, String)] -> [String] -> Maybe Text -> InspectM ModuleLocation ModuleTag m Preloaded-preload name defines opts mcts = inspectTag OnlyHeaderTag $ case mcts of-	Nothing -> do-		mloc <- ask-		case mloc of-			FileModule fpath mproj -> do-				inspect_ (liftIO $ fileInspection fpath opts) $ do-					cts <- liftIO $ readFileUtf8 (view path fpath)-					let-						srcExts = fromMaybe (takeDir fpath `withExtensions` mempty) $ do-							proj <- mproj-							findSourceDir proj fpath-					liftIO $ preload' name defines (opts ++ extensionsOpts srcExts) mloc cts-			_ -> throwError $ InspectError $ format "preload called on non-sourced module: {}" ~~ mloc-	Just cts -> inspect (liftIO $ fileContentsInspection opts) $ \mloc ->-		liftIO $ preload' name defines opts mloc cts-	where-		preload' name' defines' opts' mloc' cts' = do-			cts'' <- preprocess_ defines' exts fpath $ T.map untab cts'-			pragmas <- parseOk $ H.getTopPragmas (T.unpack cts'')-			let-				fileExts = [H.parseExtension (T.unpack $ fromName_ $ void lang) | H.LanguagePragma _ langs <- pragmas, lang <- langs]-				pmode = H.ParseMode {-					H.parseFilename = view path fpath,-					H.baseLanguage = H.Haskell2010,-					H.extensions = ordNub (map H.parseExtension exts ++ fileExts),-					H.ignoreLanguagePragmas = False,-					H.ignoreLinePragmas = True,-					H.fixities = Nothing,-					H.ignoreFunctionArity = False }-			H.ModuleHeadAndImports l mpragmas mhead mimps <- parseOk $ fmap H.unNonGreedy $ H.parseWithMode pmode (T.unpack cts'')-			let-				mname = case mhead of-					Just (H.ModuleHead _ (H.ModuleName _ nm) _ _) -> nm-					_ -> "Main"-			return $ Preloaded {-				_preloadedId = ModuleId (fromString mname) mloc',-				_preloadedMode = pmode,-				_preloadedModule = H.Module l mhead mpragmas mimps [],-				_preloaded = cts'' }-			where-				fpath = fromMaybe name' (mloc' ^? moduleFile)-				parseOk :: H.ParseResult a -> IO a-				parseOk (H.ParseOk v) = return v-				parseOk (H.ParseFailed loc err) = hsdevError $ InspectError $-					format "Parse {} failed at {} with: {}" ~~ fpath ~~ show loc ~~ err-				untab '\t' = ' '-				untab ch = ch-				exts = mapMaybe flagExtension opts'--data AnalyzeEnv = AnalyzeEnv {-	_analyzeEnv :: N.Environment,-	_analyzeFixities :: M.Map Name H.Fixity,-	_analyzeRefine :: RefineTable }--instance Monoid AnalyzeEnv where-	mempty = AnalyzeEnv mempty mempty mempty-	AnalyzeEnv lenv lf lt `mappend` AnalyzeEnv renv rf rt = AnalyzeEnv-		(mappend lenv renv)-		(mappend lf rf)-		(mappend lt rt)--moduleAnalyzeEnv :: Module -> AnalyzeEnv-moduleAnalyzeEnv m = AnalyzeEnv-	(environment m)-	(m ^. fixitiesMap)-	(refineTable (m ^.. exportedSymbols))---- | Resolve module imports/exports/scope-analyzeResolve :: AnalyzeEnv -> Module -> Module-analyzeResolve (AnalyzeEnv env _ rtable) m = case m ^. moduleSource of-	Nothing -> m-	Just msrc -> over moduleSymbols (refineSymbol stbl) $ m {-		_moduleImports = map (toImport . dropScope) idecls',-		_moduleExports = map HN.fromSymbol $ N.exportedSymbols tbl msrc,-		_moduleFixities = [Fixity (void assoc) (fromMaybe 0 pr) (fixName opName)-			| H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops],-		_moduleScope = M.map (map HN.fromSymbol) tbl,-		_moduleSource = Just annotated }-		where-			getOpName (H.VarOp _ nm) = nm-			getOpName (H.ConOp _ nm) = nm-			fixName o = H.Qual () (H.ModuleName () (T.unpack $ m ^. moduleId . moduleName)) (void o)-			itbl = N.importTable env msrc-			tbl = N.moduleTable itbl msrc-			syms = set (each . symbolId . symbolModule) (m ^. moduleId) $-				getSymbols decls'-			stbl = refineTable syms `mappend` rtable-			-- Not using 'annotate' because we already computed needed tables-			annotated = H.Module l mhead' mpragmas idecls' decls'-			H.Module l mhead mpragmas idecls decls = fmap (\(N.Scoped _ v) -> N.Scoped N.None v) msrc-			mhead' = fmap scopeHead mhead-			scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead lh mname mwarns $-				fmap (N.annotateExportSpecList tbl . dropScope) mexports-			idecls' = N.annotateImportDecls mn env (fmap dropScope idecls)-			decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl) . dropScope) decls-			mn = dropScope $ N.getModuleName msrc---- | Inspect preloaded module-analyzePreloaded :: AnalyzeEnv -> Preloaded -> Either String Module-analyzePreloaded aenv@(AnalyzeEnv env gfixities _) p = case H.parseFileContentsWithMode (_preloadedMode p') (T.unpack $ _preloaded p') of-	H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason-	H.ParseOk m -> Right $ analyzeResolve aenv $ Module {-		_moduleId = _preloadedId p',-		_moduleDocs = Nothing,-		_moduleImports = mempty,-		_moduleExports = mempty,-		_moduleFixities = mempty,-		_moduleScope = mempty,-		_moduleSource = Just $ fmap (N.Scoped N.None) m }-	where-		qimps = M.keys $ N.importTable env (_preloadedModule p)-		p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` gfixities) qimps) } }---- | Adds documentation to declaration-addDoc :: Map String String -> Symbol -> Symbol-addDoc docsMap sym' = set symbolDocs (preview (ix (view (symbolId . symbolName) sym')) docsMap') sym' where-	docsMap' = M.mapKeys fromString . M.map fromString $ docsMap---- | Adds documentation to all declarations in module-addDocs :: Map String String -> Module -> Module-addDocs docsMap = over moduleSymbols (addDoc docsMap)---- | Extract file docs and set them to module declarations-inspectDocs :: [String] -> Module -> GhcM Module-inspectDocs opts m = do-	let-		hdocsWorkaround = False-	pdbs <- case view (moduleId . moduleLocation) m of-		FileModule fpath _ -> searchPackageDbStack fpath-		InstalledModule{} -> return userDb-		_ -> return userDb-	docsMap <- if hdocsWorkaround-		then liftIO $ hdocsProcess (fromMaybe (T.unpack $ view (moduleId . moduleName) m) (preview (moduleId . moduleLocation . moduleFile . path) m)) opts-		else liftM Just $ hdocs pdbs (view (moduleId . moduleLocation) m) opts-	return $ maybe id addDocs docsMap m---- | Like @inspectDocs@, but in @Ghc@ monad-inspectDocsGhc :: [String] -> Module -> GhcM Module-inspectDocsGhc opts m = do-	docsMap <- readModuleDocs opts m-	return $ maybe id addDocs docsMap m---- | Inspect contents-inspectContents :: Text -> [(String, String)] -> [String] -> Text -> IO InspectedModule-inspectContents name defines opts cts = runInspect (OtherLocation name) $ withInspection (contentsInspection cts opts) $ do-	p <- preload name defines opts (Just cts)-	analyzed <- lift $ either (hsdevError . InspectError) return $ analyzePreloaded mempty p-	inspectUntag OnlyHeaderTag $-		return $ set (moduleId . moduleLocation) (OtherLocation name) analyzed--contentsInspection :: Text -> [String] -> IO Inspection-contentsInspection _ _ = return InspectionNone -- crc or smth---- | Inspect file-inspectFile :: [(String, String)] -> [String] -> Path -> Maybe Project -> Maybe Text -> IO InspectedModule-inspectFile defines opts file mproj mcts = hsdevLiftIO $ do-	absFilename <- canonicalize file-	ex <- fileExists absFilename-	unless ex $ hsdevError $ FileNotFound absFilename-	runInspect (FileModule absFilename mproj) $ withInspection (sourceInspection absFilename mcts opts) $ do-		p <- preload absFilename defines opts mcts-		forced <- liftIO (E.handle onError (return $!! analyzePreloaded mempty p)) >>= either (hsdevError . InspectError) return-		return $ set (moduleId . moduleLocation) (FileModule absFilename mproj) forced-	where-		onError :: E.ErrorCall -> IO (Either String Module)-		onError = return . Left . show---- | Source inspection data, differs whether there are contents provided-sourceInspection :: Path -> Maybe Text -> [String] -> IO Inspection-sourceInspection f Nothing = fileInspection f-sourceInspection _ (Just _) = fileContentsInspection---- | File inspection data-fileInspection :: Path -> [String] -> IO Inspection-fileInspection f opts = do-	tm <- Dir.getModificationTime (view path f)-	return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ map fromString $ sort $ ordNub opts---- | File contents inspection data-fileContentsInspection :: [String] -> IO Inspection-fileContentsInspection opts = fileContentsInspection_ opts <$> getPOSIXTime---- | File contents inspection data-fileContentsInspection_ :: [String] -> POSIXTime -> Inspection-fileContentsInspection_ opts tm = InspectionAt tm $ map fromString $ sort $ ordNub opts---- | Installed module inspection data, just opts-installedInspection :: [String] -> IO Inspection-installedInspection opts = return $ InspectionAt 0 $ map fromString $ sort $ ordNub opts---- | Inspection by module location-moduleInspection :: ModuleLocation -> [String] -> IO Inspection-moduleInspection (FileModule fpath _) = fileInspection fpath-moduleInspection _ = installedInspection---- | Enumerate project dirs-projectDirs :: Project -> IO [Extensions Path]-projectDirs p = do-	p' <- loadProject p-	return $ ordNub $ map (fmap (normPath . (view projectPath p' `subPath`))) $ maybe [] sourceDirs $ view projectDescription p'---- | Enumerate project source files-projectSources :: Project -> IO [Extensions Path]-projectSources p = do-	dirs <- projectDirs p-	let-		enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory-		dirs' = map (view (entity . path)) dirs-	-- enum inner projects and dont consider them as part of this project-	subProjs <- liftM (map fromFilePath . delete (view (projectPath . path) p) . ordNub . concat) $ triesMap (enumCabals) dirs'-	let-		enumHs = liftM (filter thisProjectSource) . traverseDirectory-		thisProjectSource h = haskellSource h && not (any (`isParent` fromFilePath h) subProjs)-	liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (liftM (map fromFilePath) . enumHs . view path)) dirs---- | Get actual defines-getDefines :: IO [(String, String)]-getDefines = E.handle onIO $ do-	tmp <- Dir.getTemporaryDirectory-	writeFile (tmp </> "defines.hs") ""-	_ <- runWait "ghc" ["-E", "-optP-dM", "-cpp", tmp </> "defines.hs"] ""-	cts <- readFileUtf8 (tmp </> "defines.hspp")-	Dir.removeFile (tmp </> "defines.hs")-	Dir.removeFile (tmp </> "defines.hspp")-	return $ mapMaybe (\g -> (,) <$> g 1 <*> g 2) $ mapMaybe (matchRx rx . T.unpack) $ T.lines cts-	where-		rx = "#define ([^\\s]+) (.*)"-		onIO :: E.IOException -> IO [(String, String)]-		onIO _ = return []--preprocess :: [(String, String)] -> Path -> Text -> IO Text-preprocess defines fpath cts = do-	cts' <- E.catch (Cpphs.cppIfdef (view path fpath) defines [] cppOpts (T.unpack cts)) onIOError-	return $ T.unlines $ map (fromString . snd) cts'-	where-		onIOError :: E.IOException -> IO [(Cpphs.Posn, String)]-		onIOError _ = return []--		cppOpts = Cpphs.defaultBoolOptions {-			Cpphs.locations = False,-			Cpphs.hashline = False-		}--preprocess_ :: [(String, String)] -> [String] -> Path -> Text -> IO Text-preprocess_ defines exts fpath cts-	| hasCPP = preprocess defines fpath cts-	| otherwise = return cts-	where-		exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions $ T.unpack cts)-		hasCPP = H.EnableExtension H.CPP `elem` exts'--makeLenses ''AnalyzeEnv+{-# LANGUAGE CPP, TypeSynonymInstances, ImplicitParams, TemplateHaskell #-}
+
+module HsDev.Inspect (
+	preload,
+	AnalyzeEnv(..), analyzeEnv, analyzeFixities, analyzeRefine, moduleAnalyzeEnv,
+	analyzeResolve, analyzePreloaded,
+	inspectDocs, inspectDocsGhc,
+	inspectContents, contentsInspection,
+	inspectFile, sourceInspection, fileInspection, fileContentsInspection, fileContentsInspection_, installedInspection, moduleInspection,
+	projectDirs, projectSources,
+	getDefines,
+	preprocess, preprocess_,
+
+	module HsDev.Inspect.Types,
+	module HsDev.Inspect.Resolve,
+	module Control.Monad.Except
+	) where
+
+import Control.DeepSeq
+import qualified Control.Exception as E
+import Control.Lens
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.Reader
+import Control.Monad.Except
+import Data.List
+import Data.Map.Strict (Map)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime, POSIXTime)
+import qualified Data.Map.Strict as M
+import qualified Language.Haskell.Exts as H
+import Language.Haskell.Exts.Fixity
+import qualified Language.Haskell.Names as N
+import qualified Language.Haskell.Names.Annotated as N
+import qualified Language.Haskell.Names.SyntaxUtils as N
+import qualified Language.Haskell.Names.Exports as N
+import qualified Language.Haskell.Names.Imports as N
+import qualified Language.Haskell.Names.ModuleSymbols as N
+import qualified Language.Haskell.Names.Open as N
+import qualified Language.Preprocessor.Cpphs as Cpphs
+import qualified System.Directory as Dir
+import System.FilePath
+import Text.Format
+
+import HsDev.Display ()
+import HsDev.Error
+import HsDev.Inspect.Definitions
+import HsDev.Inspect.Types
+import HsDev.Inspect.Resolve
+import HsDev.Sandbox (searchPackageDbStack)
+import HsDev.Symbols
+import HsDev.Symbols.Resolve (refineSymbol, refineTable, RefineTable)
+import qualified HsDev.Symbols.HaskellNames as HN
+import HsDev.Tools.Base
+import HsDev.Tools.Ghc.Worker (GhcM)
+import HsDev.Tools.HDocs (hdocs, hdocsProcess, readModuleDocs)
+import HsDev.Util
+import System.Directory.Paths
+
+-- | Preload module - load head and imports to get actual extensions and dependencies
+preload :: (MonadIO m, MonadCatch m) => Text -> [(String, String)] -> [String] -> Maybe Text -> InspectM ModuleLocation ModuleTag m Preloaded
+preload name defines opts mcts = inspectTag OnlyHeaderTag $ case mcts of
+	Nothing -> do
+		mloc <- ask
+		case mloc of
+			FileModule fpath mproj -> do
+				inspect_ (liftIO $ fileInspection fpath opts) $ do
+					cts <- liftIO $ readFileUtf8 (view path fpath)
+					let
+						srcExts = fromMaybe (takeDir fpath `withExtensions` mempty) $ do
+							proj <- mproj
+							findSourceDir proj fpath
+					liftIO $ preload' name defines (opts ++ extensionsOpts srcExts) mloc cts
+			_ -> throwError $ InspectError $ format "preload called on non-sourced module: {}" ~~ mloc
+	Just cts -> inspect (liftIO $ fileContentsInspection opts) $ \mloc ->
+		liftIO $ preload' name defines opts mloc cts
+	where
+		preload' name' defines' opts' mloc' cts' = do
+			cts'' <- preprocess_ defines' exts fpath $ T.map untab cts'
+			pragmas <- parseOk $ H.getTopPragmas (T.unpack cts'')
+			let
+				fileExts = [H.parseExtension (T.unpack $ fromName_ $ void lang) | H.LanguagePragma _ langs <- pragmas, lang <- langs]
+				pmode = H.ParseMode {
+					H.parseFilename = view path fpath,
+					H.baseLanguage = H.Haskell2010,
+					H.extensions = ordNub (map H.parseExtension exts ++ fileExts),
+					H.ignoreLanguagePragmas = False,
+					H.ignoreLinePragmas = True,
+					H.fixities = Nothing,
+					H.ignoreFunctionArity = False }
+			H.ModuleHeadAndImports l mpragmas mhead mimps <- parseOk $ fmap H.unNonGreedy $ H.parseWithMode pmode (T.unpack cts'')
+			let
+				mname = case mhead of
+					Just (H.ModuleHead _ (H.ModuleName _ nm) _ _) -> nm
+					_ -> "Main"
+			return $ Preloaded {
+				_preloadedId = ModuleId (fromString mname) mloc',
+				_preloadedMode = pmode,
+				_preloadedModule = H.Module l mhead mpragmas mimps [],
+				_preloaded = cts'' }
+			where
+				fpath = fromMaybe name' (mloc' ^? moduleFile)
+				parseOk :: H.ParseResult a -> IO a
+				parseOk (H.ParseOk v) = return v
+				parseOk (H.ParseFailed loc err) = hsdevError $ InspectError $
+					format "Parse {} failed at {} with: {}" ~~ fpath ~~ show loc ~~ err
+				untab '\t' = ' '
+				untab ch = ch
+				exts = mapMaybe flagExtension opts'
+
+data AnalyzeEnv = AnalyzeEnv {
+	_analyzeEnv :: N.Environment,
+	_analyzeFixities :: M.Map Name H.Fixity,
+	_analyzeRefine :: RefineTable }
+
+instance Monoid AnalyzeEnv where
+	mempty = AnalyzeEnv mempty mempty mempty
+	AnalyzeEnv lenv lf lt `mappend` AnalyzeEnv renv rf rt = AnalyzeEnv
+		(mappend lenv renv)
+		(mappend lf rf)
+		(mappend lt rt)
+
+moduleAnalyzeEnv :: Module -> AnalyzeEnv
+moduleAnalyzeEnv m = AnalyzeEnv
+	(environment m)
+	(m ^. fixitiesMap)
+	(refineTable (m ^.. exportedSymbols))
+
+-- | Resolve module imports/exports/scope
+analyzeResolve :: AnalyzeEnv -> Module -> Module
+analyzeResolve (AnalyzeEnv env _ rtable) m = case m ^. moduleSource of
+	Nothing -> m
+	Just msrc -> over moduleSymbols (refineSymbol stbl) $ m {
+		_moduleImports = map (toImport . dropScope) idecls',
+		_moduleExports = map HN.fromSymbol $ N.exportedSymbols tbl msrc,
+		_moduleFixities = [Fixity (void assoc) (fromMaybe 0 pr) (fixName opName)
+			| H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops],
+		_moduleScope = M.map (map HN.fromSymbol) tbl,
+		_moduleSource = Just annotated }
+		where
+			getOpName (H.VarOp _ nm) = nm
+			getOpName (H.ConOp _ nm) = nm
+			fixName o = H.Qual () (H.ModuleName () (T.unpack $ m ^. moduleId . moduleName)) (void o)
+			itbl = N.importTable env msrc
+			tbl = N.moduleTable itbl msrc
+			syms = set (each . symbolId . symbolModule) (m ^. moduleId) $
+				getSymbols decls'
+			stbl = refineTable syms `mappend` rtable
+			-- Not using 'annotate' because we already computed needed tables
+			annotated = H.Module l mhead' mpragmas idecls' decls'
+			H.Module l mhead mpragmas idecls decls = fmap (\(N.Scoped _ v) -> N.Scoped N.None v) msrc
+			mhead' = fmap scopeHead mhead
+			scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead lh mname mwarns $
+				fmap (N.annotateExportSpecList tbl . dropScope) mexports
+			idecls' = N.annotateImportDecls mn env (fmap dropScope idecls)
+			decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl) . dropScope) decls
+			mn = dropScope $ N.getModuleName msrc
+
+-- | Inspect preloaded module
+analyzePreloaded :: AnalyzeEnv -> Preloaded -> Either String Module
+analyzePreloaded aenv@(AnalyzeEnv env gfixities _) p = case H.parseFileContentsWithMode (_preloadedMode p') (T.unpack $ _preloaded p') of
+	H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason
+	H.ParseOk m -> Right $ analyzeResolve aenv $ Module {
+		_moduleId = _preloadedId p',
+		_moduleDocs = Nothing,
+		_moduleImports = mempty,
+		_moduleExports = mempty,
+		_moduleFixities = mempty,
+		_moduleScope = mempty,
+		_moduleSource = Just $ fmap (N.Scoped N.None) m }
+	where
+		qimps = M.keys $ N.importTable env (_preloadedModule p)
+		p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` gfixities) qimps) } }
+
+-- | Adds documentation to declaration
+addDoc :: Map String String -> Symbol -> Symbol
+addDoc docsMap sym' = set symbolDocs (preview (ix (view (symbolId . symbolName) sym')) docsMap') sym' where
+	docsMap' = M.mapKeys fromString . M.map fromString $ docsMap
+
+-- | Adds documentation to all declarations in module
+addDocs :: Map String String -> Module -> Module
+addDocs docsMap = over moduleSymbols (addDoc docsMap)
+
+-- | Extract file docs and set them to module declarations
+inspectDocs :: [String] -> Module -> GhcM Module
+inspectDocs opts m = do
+	let
+		hdocsWorkaround = False
+	pdbs <- case view (moduleId . moduleLocation) m of
+		FileModule fpath _ -> searchPackageDbStack fpath
+		InstalledModule{} -> return userDb
+		_ -> return userDb
+	docsMap <- if hdocsWorkaround
+		then liftIO $ hdocsProcess (fromMaybe (T.unpack $ view (moduleId . moduleName) m) (preview (moduleId . moduleLocation . moduleFile . path) m)) opts
+		else liftM Just $ hdocs pdbs (view (moduleId . moduleLocation) m) opts
+	return $ maybe id addDocs docsMap m
+
+-- | Like @inspectDocs@, but in @Ghc@ monad
+inspectDocsGhc :: [String] -> Module -> GhcM Module
+inspectDocsGhc opts m = do
+	docsMap <- readModuleDocs opts m
+	return $ maybe id addDocs docsMap m
+
+-- | Inspect contents
+inspectContents :: Text -> [(String, String)] -> [String] -> Text -> IO InspectedModule
+inspectContents name defines opts cts = runInspect (OtherLocation name) $ withInspection (contentsInspection cts opts) $ do
+	p <- preload name defines opts (Just cts)
+	analyzed <- lift $ either (hsdevError . InspectError) return $ analyzePreloaded mempty p
+	inspectUntag OnlyHeaderTag $
+		return $ set (moduleId . moduleLocation) (OtherLocation name) analyzed
+
+contentsInspection :: Text -> [String] -> IO Inspection
+contentsInspection _ _ = return InspectionNone -- crc or smth
+
+-- | Inspect file
+inspectFile :: [(String, String)] -> [String] -> Path -> Maybe Project -> Maybe Text -> IO InspectedModule
+inspectFile defines opts file mproj mcts = hsdevLiftIO $ do
+	absFilename <- canonicalize file
+	ex <- fileExists absFilename
+	unless ex $ hsdevError $ FileNotFound absFilename
+	runInspect (FileModule absFilename mproj) $ withInspection (sourceInspection absFilename mcts opts) $ do
+		p <- preload absFilename defines opts mcts
+		forced <- liftIO (E.handle onError (return $!! analyzePreloaded mempty p)) >>= either (hsdevError . InspectError) return
+		return $ set (moduleId . moduleLocation) (FileModule absFilename mproj) forced
+	where
+		onError :: E.ErrorCall -> IO (Either String Module)
+		onError = return . Left . show
+
+-- | Source inspection data, differs whether there are contents provided
+sourceInspection :: Path -> Maybe Text -> [String] -> IO Inspection
+sourceInspection f Nothing = fileInspection f
+sourceInspection _ (Just _) = fileContentsInspection
+
+-- | File inspection data
+fileInspection :: Path -> [String] -> IO Inspection
+fileInspection f opts = do
+	tm <- Dir.getModificationTime (view path f)
+	return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ map fromString $ sort $ ordNub opts
+
+-- | File contents inspection data
+fileContentsInspection :: [String] -> IO Inspection
+fileContentsInspection opts = fileContentsInspection_ opts <$> getPOSIXTime
+
+-- | File contents inspection data
+fileContentsInspection_ :: [String] -> POSIXTime -> Inspection
+fileContentsInspection_ opts tm = InspectionAt tm $ map fromString $ sort $ ordNub opts
+
+-- | Installed module inspection data, just opts
+installedInspection :: [String] -> IO Inspection
+installedInspection opts = return $ InspectionAt 0 $ map fromString $ sort $ ordNub opts
+
+-- | Inspection by module location
+moduleInspection :: ModuleLocation -> [String] -> IO Inspection
+moduleInspection (FileModule fpath _) = fileInspection fpath
+moduleInspection _ = installedInspection
+
+-- | Enumerate project dirs
+projectDirs :: Project -> IO [Extensions Path]
+projectDirs p = do
+	p' <- loadProject p
+	return $ ordNub $ map (fmap (normPath . (view projectPath p' `subPath`))) $ maybe [] sourceDirs $ view projectDescription p'
+
+-- | Enumerate project source files
+projectSources :: Project -> IO [Extensions Path]
+projectSources p = do
+	dirs <- projectDirs p
+	let
+		enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory
+		dirs' = map (view (entity . path)) dirs
+	-- enum inner projects and dont consider them as part of this project
+	subProjs <- liftM (map fromFilePath . delete (view (projectPath . path) p) . ordNub . concat) $ triesMap (enumCabals) dirs'
+	let
+		enumHs = liftM (filter thisProjectSource) . traverseDirectory
+		thisProjectSource h = haskellSource h && not (any (`isParent` fromFilePath h) subProjs)
+	liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (liftM (map fromFilePath) . enumHs . view path)) dirs
+
+-- | Get actual defines
+getDefines :: IO [(String, String)]
+getDefines = E.handle onIO $ do
+	tmp <- Dir.getTemporaryDirectory
+	writeFile (tmp </> "defines.hs") ""
+	_ <- runWait "ghc" ["-E", "-optP-dM", "-cpp", tmp </> "defines.hs"] ""
+	cts <- readFileUtf8 (tmp </> "defines.hspp")
+	Dir.removeFile (tmp </> "defines.hs")
+	Dir.removeFile (tmp </> "defines.hspp")
+	return $ mapMaybe (\g -> (,) <$> g 1 <*> g 2) $ mapMaybe (matchRx rx . T.unpack) $ T.lines cts
+	where
+		rx = "#define ([^\\s]+) (.*)"
+		onIO :: E.IOException -> IO [(String, String)]
+		onIO _ = return []
+
+preprocess :: [(String, String)] -> Path -> Text -> IO Text
+preprocess defines fpath cts = do
+	cts' <- E.catch (Cpphs.cppIfdef (view path fpath) defines [] cppOpts (T.unpack cts)) onIOError
+	return $ T.unlines $ map (fromString . snd) cts'
+	where
+		onIOError :: E.IOException -> IO [(Cpphs.Posn, String)]
+		onIOError _ = return []
+
+		cppOpts = Cpphs.defaultBoolOptions {
+			Cpphs.locations = False,
+			Cpphs.hashline = False
+		}
+
+preprocess_ :: [(String, String)] -> [String] -> Path -> Text -> IO Text
+preprocess_ defines exts fpath cts
+	| hasCPP = preprocess defines fpath cts
+	| otherwise = return cts
+	where
+		exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions $ T.unpack cts)
+		hasCPP = H.EnableExtension H.CPP `elem` exts'
+
+makeLenses ''AnalyzeEnv
src/HsDev/Inspect/Definitions.hs view
@@ -1,126 +1,126 @@-{-# LANGUAGE CPP #-}--module HsDev.Inspect.Definitions (-	getSymbols,-	getDecl-	) where--import Control.Lens-import Control.Monad-import Data.Data (Data)-import Data.Generics.Uniplate.Data-import Data.List-import Data.Maybe-import Data.Function-import Data.Ord-import Data.String-import Data.Text (Text)-import qualified Language.Haskell.Exts as H--import HsDev.Symbols.Types-import HsDev.Symbols.Parsed-import HsDev.Symbols.Resolve (symbolUniqId)---- | Get top symbols-getSymbols :: [H.Decl Ann] -> [Symbol]-getSymbols decls =-	map mergeSymbols .-	groupBy ((==) `on` symbolUniqId) .-	sortBy (comparing symbolUniqId) $-	concatMap getDecl decls-	where-		mergeSymbols :: [Symbol] -> Symbol-		mergeSymbols [] = error "impossible"-		mergeSymbols [s] = s-		mergeSymbols ss@(s:_) = Symbol-			(view symbolId s)-			(msum $ map (view symbolDocs) ss)-			(msum $ map (view symbolPosition) ss)-			(foldr1 mergeInfo $ map (view symbolInfo) ss)--		mergeInfo :: SymbolInfo -> SymbolInfo -> SymbolInfo-		mergeInfo (Function lt) (Function rt) = Function $ lt `mplus` rt-		mergeInfo (PatConstructor las lt) (PatConstructor ras rt) = PatConstructor (if null las then ras else las) (lt `mplus` rt)-		mergeInfo (Selector lt lp lc) (Selector rt rp rc)-			| lt == rt && lp == rp = Selector lt lp (nub $ lc ++ rc)-			| otherwise = Selector lt lp lc-		mergeInfo l _ = l---- | Get symbols from declarations-getDecl :: H.Decl Ann -> [Symbol]-getDecl decl' = case decl' of-	H.TypeDecl _ h _ -> [mkSymbol (tyName h) (Type (tyArgs h) [])]-	H.TypeFamDecl _ h _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)]-	H.ClosedTypeFamDecl _ h _ _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)]-	H.DataDecl _ dt mctx h dcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getConDecl nm) dcons where-		nm = tyName h-	H.GDataDecl _ dt mctx h _ gcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getGConDecl nm) gcons where-		nm = tyName h-	H.DataFamDecl _ mctx h _ -> [mkSymbol (tyName h) (DataFam (tyArgs h) (getCtx mctx) Nothing)]-	H.ClassDecl _ mctx h _ clsDecls -> mkSymbol nm (Class (tyArgs h) (getCtx mctx)) : concatMap (getClassDecl nm) (fromMaybe [] clsDecls) where-		nm = tyName h-	H.TypeSig _ ns tsig -> [mkSymbol n (Function (Just $ oneLinePrint tsig)) | n <- ns]-	H.PatSynSig _ ns mas _ _ t -> [mkSymbol n (PatConstructor (maybe [] (map prp) mas) (Just $ oneLinePrint t)) | n <- ns'] where-#if MIN_VERSION_haskell_src_exts(1,20,0)-		ns' = ns-#else-		ns' = [ns]-#endif-	H.FunBind _ ms -> [mkSymbol (matchName m) (Function Nothing) | m <- ms] where-		matchName (H.Match _ n _ _ _) = n-		matchName (H.InfixMatch _ _ n _ _ _) = n-	H.PatBind _ p _ _ -> [mkSymbol n (Function Nothing) | n <- patNames p] where-		patNames :: H.Pat Ann -> [H.Name Ann]-		patNames = childrenBi-	H.PatSyn _ p _ _ -> case p of-		H.PInfixApp _ _ qn _ -> [mkSymbol (qToName qn) (PatConstructor [] Nothing)]-		H.PApp _ qn _ -> [mkSymbol (qToName qn) (PatConstructor [] Nothing)]-		H.PRec _ qn fs -> mkSymbol (qToName qn) (PatConstructor [] Nothing) :-			[mkSymbol (qToName n) (PatSelector Nothing Nothing (prp $ qToName qn)) | n <- (universeBi fs :: [H.QName Ann])]-		_ -> []-		where-			qToName (H.Qual _ _ n) = n-			qToName (H.UnQual _ n) = n-			qToName _ = error "invalid qname"-	_ -> []-	where-		tyName :: H.DeclHead Ann -> H.Name Ann-		tyName = head . universeBi-		tyArgs :: Data (ast Ann) => ast Ann -> [Text]-		tyArgs n = map prp (universeBi n :: [H.TyVarBind Ann])-		getCtx :: Maybe (H.Context Ann) -> [Text]-		getCtx mctx = map prp (universeBi mctx :: [H.Asst Ann])-		getCtor (H.DataType _) = Data-		getCtor (H.NewType _) = NewType--getConDecl :: H.Name Ann -> H.QualConDecl Ann -> [Symbol]-getConDecl ptype (H.QualConDecl _ _ _ cdecl) = case cdecl of-	H.ConDecl _ n ts -> [mkSymbol n (Constructor (map prp ts) (prp ptype))]-	H.InfixConDecl _ lt n rt -> [mkSymbol n (Constructor (map prp [lt, rt]) (prp ptype))]-	H.RecDecl _ n fs -> mkSymbol n (Constructor [prp t | H.FieldDecl _ _ t <- fs] (prp ptype)) :-		[mkSymbol fn (Selector (Just $ prp ft) (prp ptype) [prp n]) | H.FieldDecl _ fns ft <- fs, fn <- fns]--getGConDecl :: H.Name Ann -> H.GadtDecl Ann -> [Symbol]-getGConDecl _ (H.GadtDecl _ n Nothing t) = [mkSymbol n (Constructor (map prp as) (prp res))] where-	(as, res) = tyFunSplit t-	tyFunSplit = go [] where-		go as' (H.TyFun _ arg' res') = go (arg' : as') res'-		go as' t' = (reverse as', t')-getGConDecl ptype (H.GadtDecl _ n (Just fs) t) = mkSymbol n (Constructor [prp ft | H.FieldDecl _ _ ft <- fs] (prp t)) :-	[mkSymbol fn (Selector (Just $ prp ft) (prp ptype) [prp n]) | H.FieldDecl _ fns ft <- fs, fn <- fns]--getClassDecl :: H.Name Ann -> H.ClassDecl Ann -> [Symbol]-getClassDecl pclass (H.ClsDecl _ (H.TypeSig _ ns tsig)) = [mkSymbol n (Method (Just $ oneLinePrint tsig) (prp pclass)) | n <- ns]-getClassDecl _ _ = []--prp :: H.Pretty a => a -> Text-prp = fromString . H.prettyPrint---mkSymbol :: H.Name Ann -> SymbolInfo -> Symbol-mkSymbol nm = Symbol (SymbolId (fromName_ $ void nm) (ModuleId (fromString "") noLocation)) Nothing (nm ^? binders . defPos)----- | Print something in one line-oneLinePrint :: (H.Pretty a, IsString s) => a -> s-oneLinePrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode+{-# LANGUAGE CPP #-}
+
+module HsDev.Inspect.Definitions (
+	getSymbols,
+	getDecl
+	) where
+
+import Control.Lens
+import Control.Monad
+import Data.Data (Data)
+import Data.Generics.Uniplate.Data
+import Data.List
+import Data.Maybe
+import Data.Function
+import Data.Ord
+import Data.String
+import Data.Text (Text)
+import qualified Language.Haskell.Exts as H
+
+import HsDev.Symbols.Types
+import HsDev.Symbols.Parsed
+import HsDev.Symbols.Resolve (symbolUniqId)
+
+-- | Get top symbols
+getSymbols :: [H.Decl Ann] -> [Symbol]
+getSymbols decls =
+	map mergeSymbols .
+	groupBy ((==) `on` symbolUniqId) .
+	sortBy (comparing symbolUniqId) $
+	concatMap getDecl decls
+	where
+		mergeSymbols :: [Symbol] -> Symbol
+		mergeSymbols [] = error "impossible"
+		mergeSymbols [s] = s
+		mergeSymbols ss@(s:_) = Symbol
+			(view symbolId s)
+			(msum $ map (view symbolDocs) ss)
+			(msum $ map (view symbolPosition) ss)
+			(foldr1 mergeInfo $ map (view symbolInfo) ss)
+
+		mergeInfo :: SymbolInfo -> SymbolInfo -> SymbolInfo
+		mergeInfo (Function lt) (Function rt) = Function $ lt `mplus` rt
+		mergeInfo (PatConstructor las lt) (PatConstructor ras rt) = PatConstructor (if null las then ras else las) (lt `mplus` rt)
+		mergeInfo (Selector lt lp lc) (Selector rt rp rc)
+			| lt == rt && lp == rp = Selector lt lp (nub $ lc ++ rc)
+			| otherwise = Selector lt lp lc
+		mergeInfo l _ = l
+
+-- | Get symbols from declarations
+getDecl :: H.Decl Ann -> [Symbol]
+getDecl decl' = case decl' of
+	H.TypeDecl _ h _ -> [mkSymbol (tyName h) (Type (tyArgs h) [])]
+	H.TypeFamDecl _ h _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)]
+	H.ClosedTypeFamDecl _ h _ _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)]
+	H.DataDecl _ dt mctx h dcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getConDecl nm) dcons where
+		nm = tyName h
+	H.GDataDecl _ dt mctx h _ gcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getGConDecl nm) gcons where
+		nm = tyName h
+	H.DataFamDecl _ mctx h _ -> [mkSymbol (tyName h) (DataFam (tyArgs h) (getCtx mctx) Nothing)]
+	H.ClassDecl _ mctx h _ clsDecls -> mkSymbol nm (Class (tyArgs h) (getCtx mctx)) : concatMap (getClassDecl nm) (fromMaybe [] clsDecls) where
+		nm = tyName h
+	H.TypeSig _ ns tsig -> [mkSymbol n (Function (Just $ oneLinePrint tsig)) | n <- ns]
+	H.PatSynSig _ ns mas _ _ t -> [mkSymbol n (PatConstructor (maybe [] (map prp) mas) (Just $ oneLinePrint t)) | n <- ns'] where
+#if MIN_VERSION_haskell_src_exts(1,20,0)
+		ns' = ns
+#else
+		ns' = [ns]
+#endif
+	H.FunBind _ ms -> [mkSymbol (matchName m) (Function Nothing) | m <- ms] where
+		matchName (H.Match _ n _ _ _) = n
+		matchName (H.InfixMatch _ _ n _ _ _) = n
+	H.PatBind _ p _ _ -> [mkSymbol n (Function Nothing) | n <- patNames p] where
+		patNames :: H.Pat Ann -> [H.Name Ann]
+		patNames = childrenBi
+	H.PatSyn _ p _ _ -> case p of
+		H.PInfixApp _ _ qn _ -> [mkSymbol (qToName qn) (PatConstructor [] Nothing)]
+		H.PApp _ qn _ -> [mkSymbol (qToName qn) (PatConstructor [] Nothing)]
+		H.PRec _ qn fs -> mkSymbol (qToName qn) (PatConstructor [] Nothing) :
+			[mkSymbol (qToName n) (PatSelector Nothing Nothing (prp $ qToName qn)) | n <- (universeBi fs :: [H.QName Ann])]
+		_ -> []
+		where
+			qToName (H.Qual _ _ n) = n
+			qToName (H.UnQual _ n) = n
+			qToName _ = error "invalid qname"
+	_ -> []
+	where
+		tyName :: H.DeclHead Ann -> H.Name Ann
+		tyName = head . universeBi
+		tyArgs :: Data (ast Ann) => ast Ann -> [Text]
+		tyArgs n = map prp (universeBi n :: [H.TyVarBind Ann])
+		getCtx :: Maybe (H.Context Ann) -> [Text]
+		getCtx mctx = map prp (universeBi mctx :: [H.Asst Ann])
+		getCtor (H.DataType _) = Data
+		getCtor (H.NewType _) = NewType
+
+getConDecl :: H.Name Ann -> H.QualConDecl Ann -> [Symbol]
+getConDecl ptype (H.QualConDecl _ _ _ cdecl) = case cdecl of
+	H.ConDecl _ n ts -> [mkSymbol n (Constructor (map prp ts) (prp ptype))]
+	H.InfixConDecl _ lt n rt -> [mkSymbol n (Constructor (map prp [lt, rt]) (prp ptype))]
+	H.RecDecl _ n fs -> mkSymbol n (Constructor [prp t | H.FieldDecl _ _ t <- fs] (prp ptype)) :
+		[mkSymbol fn (Selector (Just $ prp ft) (prp ptype) [prp n]) | H.FieldDecl _ fns ft <- fs, fn <- fns]
+
+getGConDecl :: H.Name Ann -> H.GadtDecl Ann -> [Symbol]
+getGConDecl _ (H.GadtDecl _ n Nothing t) = [mkSymbol n (Constructor (map prp as) (prp res))] where
+	(as, res) = tyFunSplit t
+	tyFunSplit = go [] where
+		go as' (H.TyFun _ arg' res') = go (arg' : as') res'
+		go as' t' = (reverse as', t')
+getGConDecl ptype (H.GadtDecl _ n (Just fs) t) = mkSymbol n (Constructor [prp ft | H.FieldDecl _ _ ft <- fs] (prp t)) :
+	[mkSymbol fn (Selector (Just $ prp ft) (prp ptype) [prp n]) | H.FieldDecl _ fns ft <- fs, fn <- fns]
+
+getClassDecl :: H.Name Ann -> H.ClassDecl Ann -> [Symbol]
+getClassDecl pclass (H.ClsDecl _ (H.TypeSig _ ns tsig)) = [mkSymbol n (Method (Just $ oneLinePrint tsig) (prp pclass)) | n <- ns]
+getClassDecl _ _ = []
+
+prp :: H.Pretty a => a -> Text
+prp = fromString . H.prettyPrint
+
+
+mkSymbol :: H.Name Ann -> SymbolInfo -> Symbol
+mkSymbol nm = Symbol (SymbolId (fromName_ $ void nm) (ModuleId (fromString "") noLocation)) Nothing (nm ^? binders . defPos)
+
+
+-- | Print something in one line
+oneLinePrint :: (H.Pretty a, IsString s) => a -> s
+oneLinePrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode
src/HsDev/Inspect/Order.hs view
@@ -1,42 +1,42 @@-module HsDev.Inspect.Order (-	orderBy, order-	) where--import Control.Lens-import Data.Maybe-import Data.String-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Language.Haskell.Exts as H--import Data.Deps-import HsDev.Inspect-import HsDev.Symbols.Types-import System.Directory.Paths---- | Order source files so that dependencies goes first and we are able to resolve symbols and set fixities-orderBy :: (a -> Maybe Preloaded) -> [a] -> Either (DepsError Path) [a]-orderBy fn ps = do-	order' <- linearize pdeps-	return $ mapMaybe (`M.lookup` pm) order'-	where-		pdeps = mconcat $ mapMaybe (fmap getDeps . fn) ps-		pm = M.fromList [(pfile, p) | p <- ps, pfile <- fn p ^.. _Just . preloadedId . moduleLocation . moduleFile]-		files = S.fromList $ map fn ps ^.. each . _Just . preloadedId . moduleLocation . moduleFile-		getDeps :: Preloaded -> Deps Path-		getDeps p = deps mfile [ifile | ifile <- ifiles, S.member ifile files] where-			H.Module _ _ _ idecls _ = _preloadedModule p-			imods = [fromString iname | H.ModuleName _ iname <- map H.importModule idecls]-			mfile = _preloadedId p ^?! moduleLocation . moduleFile-			projRoot = _preloadedId p ^? moduleLocation . moduleProject . _Just . projectPath-			mroot = fromMaybe-				(sourceModuleRoot (view moduleName $ _preloadedId p) mfile)-				projRoot-			dirs = do-				proj <- _preloadedId p ^.. moduleLocation . moduleProject . _Just-				i <- fileTargets proj mfile-				view infoSourceDirs i-			ifiles = [normPath (joinPaths [mroot, dir, importPath imod]) | imod <- imods, dir <- if null dirs then [fromFilePath "."] else dirs]--order :: [Preloaded] -> Either (DepsError Path) [Preloaded]-order = orderBy Just+module HsDev.Inspect.Order (
+	orderBy, order
+	) where
+
+import Control.Lens
+import Data.Maybe
+import Data.String
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Language.Haskell.Exts as H
+
+import Data.Deps
+import HsDev.Inspect
+import HsDev.Symbols.Types
+import System.Directory.Paths
+
+-- | Order source files so that dependencies goes first and we are able to resolve symbols and set fixities
+orderBy :: (a -> Maybe Preloaded) -> [a] -> Either (DepsError Path) [a]
+orderBy fn ps = do
+	order' <- linearize pdeps
+	return $ mapMaybe (`M.lookup` pm) order'
+	where
+		pdeps = mconcat $ mapMaybe (fmap getDeps . fn) ps
+		pm = M.fromList [(pfile, p) | p <- ps, pfile <- fn p ^.. _Just . preloadedId . moduleLocation . moduleFile]
+		files = S.fromList $ map fn ps ^.. each . _Just . preloadedId . moduleLocation . moduleFile
+		getDeps :: Preloaded -> Deps Path
+		getDeps p = deps mfile [ifile | ifile <- ifiles, S.member ifile files] where
+			H.Module _ _ _ idecls _ = _preloadedModule p
+			imods = [fromString iname | H.ModuleName _ iname <- map H.importModule idecls]
+			mfile = _preloadedId p ^?! moduleLocation . moduleFile
+			projRoot = _preloadedId p ^? moduleLocation . moduleProject . _Just . projectPath
+			mroot = fromMaybe
+				(sourceModuleRoot (view moduleName $ _preloadedId p) mfile)
+				projRoot
+			dirs = do
+				proj <- _preloadedId p ^.. moduleLocation . moduleProject . _Just
+				i <- fileTargets proj mfile
+				view infoSourceDirs i
+			ifiles = [normPath (joinPaths [mroot, dir, importPath imod]) | imod <- imods, dir <- if null dirs then [fromFilePath "."] else dirs]
+
+order :: [Preloaded] -> Either (DepsError Path) [Preloaded]
+order = orderBy Just
src/HsDev/Inspect/Resolve.hs view
@@ -1,516 +1,383 @@-{-# LANGUAGE OverloadedStrings, TypeApplications, TypeOperators #-}--module HsDev.Inspect.Resolve (-	-- * Prepare-	loadEnv, saveEnv,-	loadEnvironment, loadFixities, withEnv,-	-- * Resolving-	resolveModule, resolvePreloaded, resolve,-	-- * Saving results-	updateResolved, updateResolveds-	) where--import Control.Lens hiding ((.=))-import Control.Monad.Catch-import Data.Aeson-import Data.Generics.Uniplate.Operations-import Data.Functor-import Data.Function-import Data.List-import qualified Data.Map as M-import Data.Maybe-import Data.Ord-import Data.String-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Language.Haskell.Exts as H-import qualified Language.Haskell.Names as N-import qualified Language.Haskell.Names.Open as N-import qualified Language.Haskell.Names.Annotated as N-import qualified Language.Haskell.Names.Imports as N-import qualified Language.Haskell.Names.Exports as N-import qualified Language.Haskell.Names.ModuleSymbols as N-import qualified Language.Haskell.Names.SyntaxUtils as N-import System.Log.Simple-import Text.Format--import Data.LookupTable-import System.Directory.Paths-import HsDev.Database.SQLite as SQLite-import qualified HsDev.Display as Display-import HsDev.Error-import HsDev.Inspect.Definitions-import HsDev.Inspect.Types-import HsDev.Symbols-import qualified HsDev.Symbols.HaskellNames as HN-import HsDev.Symbols.Parsed as P-import HsDev.Server.Types-import HsDev.Util---- | Try resolve module symbols-resolveModule :: MonadThrow m => Environment -> FixitiesTable -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved-resolveModule env fixities p = inspectTag ResolvedNamesTag $ inspectUntag OnlyHeaderTag $ case H.parseFileContentsWithMode (p' ^. preloadedMode) (T.unpack $ p ^. preloaded) of-	H.ParseFailed loc reason -> hsdevError $ InspectError $ "Parse failed at " ++ show loc ++ ": " ++ reason-	H.ParseOk m -> return (resolve env m)-	where-		qimps = M.keys $ N.importTable env (p ^. preloadedModule)-		p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` fixities) qimps) } }---- | Resolve just preloaded part of module, this will give imports and scope-resolvePreloaded :: MonadThrow m => Environment -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved-resolvePreloaded env = inspectTag ResolvedNamesTag . return . resolve env . view preloadedModule---- | Resolve parsed module-resolve :: Environment -> H.Module H.SrcSpanInfo -> Resolved-resolve env m = Resolved {-	_resolvedModule = void mn,-	_resolvedSource = annotated,-	_resolvedDefs = getSymbols decls',-	_resolvedImports = map (toImport . dropScope) idecls',-	_resolvedExports = N.exportedSymbols tbl m,-	_resolvedScope = tbl,-	_resolvedFixities = [H.Fixity (void assoc) (fromMaybe 0 pr) (fixName opName)-		| H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops] }-	where-		getOpName (H.VarOp _ nm) = nm-		getOpName (H.ConOp _ nm) = nm-		fixName o = H.Qual () (void mn) (void o)-		itbl = N.importTable env m-		tbl = N.moduleTable itbl m-		-- Not using 'annotate' because we already computed needed tables-		annotated = H.Module (noScope l) mhead' mpragmas' idecls' decls'-		H.Module l mhead mpragmas idecls decls = m-		mhead' = fmap scopeHead mhead-		mpragmas' = fmap withNoScope mpragmas-		scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead (noScope lh) (withNoScope mname) (fmap withNoScope mwarns) $-			fmap (N.annotateExportSpecList tbl) mexports-		idecls' = N.annotateImportDecls mn env idecls-		decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl)) decls-		mn = N.getModuleName m---- | Load environment and fixities from cache or sql-loadEnv :: SessionMonad m => Maybe Path -> m (Environment, FixitiesTable)-loadEnv mcabal = do-	envTable <- askSession sessionResolveEnvironment-	cacheInTableM envTable mcabal $ (,) <$> loadEnvironment mcabal <*> loadFixities mcabal---- | Save environment and fixities to cache-saveEnv :: SessionMonad m => Maybe Path -> Environment -> FixitiesTable -> m ()-saveEnv mcabal env fixities = do-	envTable <- askSession sessionResolveEnvironment-	void $ insertTable mcabal (env, fixities) envTable---- | Load environment from sql-loadEnvironment :: SessionMonad m => Maybe Path -> m Environment-loadEnvironment mcabal = transaction_ Deferred $ do-	sendLog Trace $ "loading environment for {}" ~~ fromMaybe "<standalone>" mcabal-	env <- query @_ @(Only (H.ModuleName ()) :. N.Symbol)-		(toQuery $ mconcat [-			select_ ["em.name"],-			from_ ["projects_modules_scope as ps", "exports as e", "modules as em"],-			where_ [-				"ps.cabal is ?",-				"ps.module_id = em.id",-				"e.symbol_id = s.id",-				"e.module_id = em.id"],-			qNSymbol "m" "s"])-		(Only mcabal)-	return $ M.fromList $ do-		group' <- groupBy ((==) `on` fst) . sortBy (comparing fst) $ [(m, s) | (Only m :. s) <- env]-		let-			(gmod:_, gsyms) = unzip group'-		return (gmod, gsyms)---- | Load fixities from sql-loadFixities :: SessionMonad m => Maybe Path -> m FixitiesTable-loadFixities mcabal = transaction_ Deferred $ do-	fixities' <- query @_ @(Only Value)-		(toQuery $ mconcat [-			select_ ["m.fixities"],-			from_ ["projects_modules_scope as ps", "modules as m"],-			where_ [-				"ps.cabal is ?",-				"ps.module_id = m.id",-				"m.fixities is not null"]])-		(Only mcabal)-	return $ mconcat [M.singleton n f |-		f@(H.Fixity _ _ n) <- concat (mapMaybe (fromJSON' . fromOnly) fixities')]---- | Run with temporary table for environment-withEnv :: SessionMonad m => Maybe Path -> m a -> m a-withEnv mcabal = (initEnv >>) where-	initEnv = do-		execute_ "create temporary table if not exists resolve (cabal text);"-		execute_ "create temporary table if not exists env (module text not null, name text not null, what text not null, id integer not null);"-		execute_ "create unique index if not exists env_id_index on env (id);"-		execute_ "create unique index if not exists env_symbol_index on env (module, name, what);"--		curEnv <- query_ "select cabal from resolve;"-		unless (fmap fromOnly (listToMaybe curEnv) == Just mcabal) $ do-			execute_ "delete from resolve;"-			execute "insert into resolve values (?);" (Only mcabal)-			execute_ "delete from env;"-			executeNamed "insert into env select m.name, s.name, s.what, min(s.id) from modules as m, symbols as s where m.id = s.module_id and s.id in (select distinct e.symbol_id from exports as e where e.module_id in (select ps.module_id from projects_modules_scope as ps where ps.cabal is :cabal)) group by m.name, s.name, s.what;" [-				":cabal" := mcabal]--		[Only cnt] <- query_ @(Only Int) "select count(*) from env;"-		sendLog Trace $ "created env table with {} symbols" ~~ cnt---- | Save results in sql, also updates temporary environment table-updateResolved :: SessionMonad m => InspectedResolved -> m ()-updateResolved im = scope "update-resolved" $ do-	_ <- upsertResolved im-	insertResolvedSymbols im---- | Save results in sql, updated temporary env table-updateResolveds :: SessionMonad m => Maybe Path -> [InspectedResolved] -> m ()-updateResolveds mcabal ims = scope "update-resolveds" $ withEnv mcabal $ do-	ids <- transaction_ Immediate $ mapM upsertResolved ims-	updateResolvedsSymbols (zip ids ims)--upsertResolved :: SessionMonad m => InspectedResolved -> m Int-upsertResolved im = do-	mmid <- lookupModuleLocation (im ^. inspectedKey)-	case mmid of-		Nothing -> do-			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) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"-				moduleData-			lastRow-		Just mid' -> do-			execute "update modules set file = ?, cabal = ?, install_dirs = ?, package_name = ?, package_version = ?, installed_name = ?, exposed = ?, other_location = ?, name = ?, docs = ?, fixities = ?, tags = ?, inspection_error = ?, inspection_time = ?, inspection_opts = ? where id == ?;"-				(moduleData :. Only mid')-			return mid'-	where-		moduleData = (-			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 . resolvedModule . moduleName_, im ^? inspectedKey . installedModuleName],-			Nothing @Text,-			fmap encode $ im ^? inspected . resolvedFixities,-			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]--insertResolvedSymbols :: SessionMonad m => InspectedResolved -> m ()-insertResolvedSymbols im = do-	Just mid <- lookupModuleLocation (im ^. inspectedKey)-	removeModuleContents mid-	insertModuleImports mid (im ^?! inspected . resolvedSource)-	insertModuleDefs mid (im ^.. inspected . resolvedDefs . each)-	insertExportSymbols mid (im ^.. inspected . resolvedExports . each)-	insertScopeSymbols mid (M.toList (im ^?! inspected . resolvedScope))-	insertResolvedNames mid (im ^?! inspected . resolvedSource)-	updateEnvironment mid-	where-		insertModuleImports :: SessionMonad m => Int -> Parsed -> m ()-		insertModuleImports mid p = scope "imports" $ do-			let-				imps = childrenBi p :: [H.ImportDecl Ann]-				importRow idecl@(H.ImportDecl _ mname qual _ _ _ alias specList) = (-					mid,-					idecl ^. pos . positionLine,-					idecl ^. pos . positionColumn,-					getModuleName mname,-					qual,-					fmap getModuleName alias,-					maybe False getHiding specList,-					fmap makeImportList specList)-			executeMany "insert into imports (module_id, line, column, module_name, qualified, alias, hiding, import_list) values (?, ?, ?, ?, ?, ?, ?, ?);"-				(map importRow imps)-			executeNamed "update imports set import_module_id = (select im.id from modules as im, projects_modules_scope as ps where ((ps.cabal is null and :cabal is null) or (ps.cabal == :cabal)) and ps.module_id == im.id and im.name == imports.module_name) where module_id == :module_id;" [-			 ":cabal" := im ^? inspectedKey . moduleProject . _Just . projectCabal,-			 ":module_id" := mid]-			where-				getModuleName (H.ModuleName _ s) = s-				getHiding (H.ImportSpecList _ h _) = h--				makeImportList (H.ImportSpecList _ _ specs) = encode $ map asJson specs-				asJson (H.IVar _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "var"]-				asJson (H.IAbs _ ns nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "abs", "ns" .= fromNamespace ns] where-					fromNamespace :: H.Namespace l -> Maybe String-					fromNamespace (H.NoNamespace _) = Nothing-					fromNamespace (H.TypeNamespace _) = Just "type"-					fromNamespace (H.PatternNamespace _) = Just "pat"-				asJson (H.IThingAll _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "all"]-				asJson (H.IThingWith _ nm cs) = object ["name" .= fromName_ (void nm), "what" .= id @String "with", "list" .= map (fromName_ . void . toName') cs] where-					toName' (H.VarName _ n') = n'-					toName' (H.ConName _ n') = n'--		insertModuleDefs :: SessionMonad m => Int -> [Symbol] -> m ()-		insertModuleDefs mid syms = scope "defs" $ do-			executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do-				sym <- syms-				return $ (-					sym ^. symbolId . symbolName,-					mid,-					sym ^. symbolDocs,-					sym ^? symbolPosition . _Just . positionLine,-					sym ^? symbolPosition . _Just . positionColumn)-					:.-					(sym ^. symbolInfo)-			execute "insert or replace into env (module, name, what, id) select ?, s.name, s.what, s.id from symbols as s where s.module_id = ?;" (im ^?! inspected . resolvedModule . moduleName_, mid)--		insertExportSymbols :: SessionMonad m => Int -> [N.Symbol] -> m ()-		insertExportSymbols mid syms = scope "exports" $ do-			executeMany "insert into exports (module_id, symbol_id) select ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do-				sym <- syms-				return (-					mid,-					N.symbolModule sym,-					N.symbolName sym,-					symbolType (HN.fromSymbol sym))--		insertScopeSymbols :: SessionMonad m => Int -> [(Name, [N.Symbol])] -> m ()-		insertScopeSymbols mid snames = scope "scope" $ do-			executeMany "insert into scopes (module_id, qualifier, name, symbol_id) select ?, ?, ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do-				(qn, syms) <- snames-				sym <- syms-				return (-					mid,-					nameModule qn,-					nameIdent qn,-					N.symbolModule sym,-					N.symbolName sym,-					symbolType (HN.fromSymbol sym))--		insertResolvedNames :: SessionMonad m => Int -> Parsed -> m ()-		insertResolvedNames mid p = scope "resolved" $ do-			insertNames-			replaceQNames-			executeNamed "update names set resolved_module = :module, (resolved_name, resolved_what) = (select s.name, s.what from symbols as s where s.module_id = names.module_id and s.line = names.line and s.column = names.column) where module_id = :module_id and (line, column) = (def_line, def_column) and resolved_module is null and resolved_name is null;" [-				":module" := im ^?! inspected . resolvedModule . moduleName_,-				":module_id" := mid]-			setResolvedSymbolIds-			where-				insertNames = executeMany insertQuery namesData-				replaceQNames = executeMany insertQuery qnamesData-				setResolvedSymbolIds = execute "update names set symbol_id = (select sc.symbol_id from scopes as sc, symbols as s, modules as m where names.module_id == sc.module_id and ((names.qualifier is null and sc.qualifier is null) or (names.qualifier == sc.qualifier)) and names.name == sc.name and s.id == sc.symbol_id and m.id == s.module_id and s.name == names.resolved_name and s.what == names.resolved_what and m.name == names.resolved_module) where module_id == ? and resolved_module is not null and resolved_name is not null and resolved_what is not null;" (Only mid)-				insertQuery = "insert or replace into names (module_id, qualifier, name, line, column, line_to, column_to, def_line, def_column, resolved_module, resolved_name, resolved_what, resolve_error) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"-				namesData = map toData $ p ^.. P.names-				qnamesData = map toQData $ p ^.. P.qnames-				toData name = (-					mid,-					Nothing :: Maybe Text,-					fromName_ $ void name,-					name ^. P.pos . positionLine,-					name ^. P.pos . positionColumn,-					name ^. P.regionL . regionTo . positionLine,-					name ^. P.regionL . regionTo . positionColumn)-					:. (-					name ^? P.defPos . positionLine,-					name ^? P.defPos . positionColumn,-					(name ^? P.resolvedName) >>= nameModule,-					nameIdent <$> (name ^? P.resolvedName),-					fmap (symbolType . HN.fromSymbol) $ name ^? P.symbolL,-					P.resolveError name)-				toQData qname = (-					mid,-					nameModule $ void qname,-					nameIdent $ void qname,-					qname ^. P.pos . positionLine,-					qname ^. P.pos . positionColumn,-					qname ^. P.regionL . regionTo . positionLine,-					qname ^. P.regionL . regionTo . positionColumn)-					:. (-					qname ^? P.defPos . positionLine,-					qname ^? P.defPos . positionColumn,-					(qname ^? P.resolvedName) >>= nameModule,-					nameIdent <$> (qname ^? P.resolvedName),-					fmap (symbolType . HN.fromSymbol) $ qname ^? P.symbolL,-					P.resolveError qname)--		updateEnvironment :: SessionMonad m => Int -> m ()-		updateEnvironment mid = do-			execute "insert or replace into env (module, name, what, id) select m.name, s.name, s.what, min(s.id) from modules as m, symbols as s, exports as e where m.id = s.module_id and s.id = e.symbol_id and e.module_id = ? group by m.name, s.name, s.what;" (Only mid)--updateResolvedsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m ()-updateResolvedsSymbols ims = bracket_ initTemps dropTemps $ do-	initUpdatedIds ims--	removeModulesContents-	transaction_ Immediate $ insertModulesDefs ims-	transaction_ Immediate $ insertModulesImports ims-	transaction_ Immediate $ insertExportsSymbols ims-	transaction_ Immediate $ do-		insertScopesSymbols ims-		insertResolvedsNames ims-	commitTemps--	where-		initTemps :: SessionMonad m => m ()-		initTemps = do-			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);"-			execute_ "create temporary table updating_scopes as select * from scopes where 0;"-			execute_ "create index updating_scopes_name_index on updating_scopes (module_id, name);"-			execute_ "create temporary table updating_names as select * from names where 0;"-			execute_ "create unique index updating_names_position_index on updating_names (module_id, line, column, line_to, column_to);"--		dropTemps :: SessionMonad m => m ()-		dropTemps = do-			execute_ "drop table if exists updated_ids;"-			execute_ "drop table if exists updating_scopes;"-			execute_ "drop table if exists updating_names;"--		commitTemps :: SessionMonad m => m ()-		commitTemps = do-			transaction_ Immediate $ execute_ "insert into scopes select * from updating_scopes;"-			transaction_ Immediate $ execute_ "insert into names select * from updating_names;"--		initUpdatedIds :: SessionMonad m => [(Int, InspectedResolved)] -> 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 . resolvedModule . 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);"--		insertModulesImports :: SessionMonad m => [(Int, InspectedResolved)] -> m ()-		insertModulesImports imods = scope "imports" $ do-			executeMany "insert into imports (module_id, line, column, module_name, qualified, alias, hiding, import_list) values (?, ?, ?, ?, ?, ?, ?, ?);" $ do-				(mid, im) <- imods-				let-					p = im ^?! inspected . resolvedSource-				idecl@(H.ImportDecl _ mname qual _ _ _ alias specList) <- childrenBi p :: [H.ImportDecl Ann]-				return (-					mid,-					idecl ^. pos . positionLine,-					idecl ^. pos . positionColumn,-					getModuleName mname,-					qual,-					fmap getModuleName alias,-					maybe False getHiding specList,-					fmap makeImportList specList)-			execute_ "update imports set import_module_id = (select im.id from updated_ids as u, modules as im, projects_modules_scope as ps where ((ps.cabal is null and u.cabal is null) or (ps.cabal == u.cabal)) and ps.module_id == im.id and im.name == imports.module_name) where module_id in (select u.id from updated_ids as u);"-			where-				getModuleName (H.ModuleName _ s) = s-				getHiding (H.ImportSpecList _ h _) = h--				makeImportList (H.ImportSpecList _ _ specs) = encode $ map asJson specs-				asJson (H.IVar _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "var"]-				asJson (H.IAbs _ ns nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "abs", "ns" .= fromNamespace ns] where-					fromNamespace :: H.Namespace l -> Maybe String-					fromNamespace (H.NoNamespace _) = Nothing-					fromNamespace (H.TypeNamespace _) = Just "type"-					fromNamespace (H.PatternNamespace _) = Just "pat"-				asJson (H.IThingAll _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "all"]-				asJson (H.IThingWith _ nm cs) = object ["name" .= fromName_ (void nm), "what" .= id @String "with", "list" .= map (fromName_ . void . toName') cs] where-					toName' (H.VarName _ n') = n'-					toName' (H.ConName _ n') = n'--		insertModulesDefs :: SessionMonad m => [(Int, InspectedResolved)] -> m ()-		insertModulesDefs imods = scope "defs" $ do-			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-				sym <- im ^.. inspected . resolvedDefs . each-				return $ (-					sym ^. symbolId . symbolName,-					mid,-					sym ^. symbolDocs,-					sym ^? symbolPosition . _Just . positionLine,-					sym ^? symbolPosition . _Just . positionColumn)-					:.-					(sym ^. symbolInfo)-			execute_ "insert or replace into env (module, name, what, id) select m.name, s.name, s.what, s.id from modules as m, symbols as s where m.id in (select id from updated_ids) and s.module_id = m.id;"--		insertExportsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m ()-		insertExportsSymbols imods = scope "exports" $ executeMany "insert into exports (module_id, symbol_id) select ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do-			(mid, im) <- imods-			sym <- im ^.. inspected . resolvedExports . each-			return (-				mid,-				N.symbolModule sym,-				N.symbolName sym,-				symbolType (HN.fromSymbol sym))--		insertScopesSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m ()-		insertScopesSymbols imods = scope "scope" $ executeMany "insert into updating_scopes (module_id, qualifier, name, symbol_id) select ?, ?, ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do-			(mid, im) <- imods-			(qn, syms) <- M.toList (im ^. inspected . resolvedScope)-			sym <- syms-			return (-				mid,-				nameModule qn,-				nameIdent qn,-				N.symbolModule sym,-				N.symbolName sym,-				symbolType (HN.fromSymbol sym))--		insertResolvedsNames :: SessionMonad m => [(Int, InspectedResolved)] -> m ()-		insertResolvedsNames imods = scope "names" $ do-			insertNames-			replaceQNames-			resolveGlobalBinders-			setResolvedsSymbolIds-			where-				insertNames = executeMany insertQuery namesData-				replaceQNames = executeMany insertQuery qnamesData-				resolveGlobalBinders = execute_ "update updating_names set (resolved_module, resolved_name, resolved_what) = (select u.module, s.name, s.what from updated_ids as u, symbols as s where u.id = s.module_id and s.module_id = updating_names.module_id and s.line = updating_names.line and s.column = updating_names.column) where (line, column) = (def_line, def_column) and resolved_module is null and resolved_name is null;"-				setResolvedsSymbolIds = execute_ "update updating_names set symbol_id = (select sc.symbol_id from updating_scopes as sc, symbols as s, modules as m where updating_names.module_id == sc.module_id and ((updating_names.qualifier is null and sc.qualifier is null) or (updating_names.qualifier == sc.qualifier)) and updating_names.name == sc.name and s.id == sc.symbol_id and m.id == s.module_id and s.name == updating_names.resolved_name and s.what == updating_names.resolved_what and m.name == updating_names.resolved_module) where resolved_module is not null and resolved_name is not null and resolved_what is not null;"-				insertQuery = "insert or replace into updating_names (module_id, qualifier, name, line, column, line_to, column_to, def_line, def_column, resolved_module, resolved_name, resolved_what, resolve_error) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"--				namesData = map (uncurry toData) $ do-					(mid, im) <- imods-					n <- im ^.. inspected . resolvedSource . P.names-					return (mid, n)-				qnamesData = map (uncurry toQData) $ do-					(mid, im) <- imods-					n <- im ^.. inspected . resolvedSource . P.qnames-					return (mid, n)--				toData mid name = (-					mid,-					Nothing :: Maybe Text,-					fromName_ $ void name,-					name ^. P.pos . positionLine,-					name ^. P.pos . positionColumn,-					name ^. P.regionL . regionTo . positionLine,-					name ^. P.regionL . regionTo . positionColumn)-					:. (-					name ^? P.defPos . positionLine,-					name ^? P.defPos . positionColumn,-					(name ^? P.resolvedName) >>= nameModule,-					nameIdent <$> (name ^? P.resolvedName),-					fmap (symbolType . HN.fromSymbol) $ name ^? P.symbolL,-					P.resolveError name)-				toQData mid qname = (-					mid,-					nameModule $ void qname,-					nameIdent $ void qname,-					qname ^. P.pos . positionLine,-					qname ^. P.pos . positionColumn,-					qname ^. P.regionL . regionTo . positionLine,-					qname ^. P.regionL . regionTo . positionColumn)-					:. (-					qname ^? P.defPos . positionLine,-					qname ^? P.defPos . positionColumn,-					(qname ^? P.resolvedName) >>= nameModule,-					nameIdent <$> (qname ^? P.resolvedName),-					fmap (symbolType . HN.fromSymbol) $ qname ^? P.symbolL,-					P.resolveError qname)+{-# LANGUAGE OverloadedStrings, TypeApplications, TypeOperators #-}
+
+module HsDev.Inspect.Resolve (
+	-- * Prepare
+	loadEnv, saveEnv,
+	loadEnvironment, loadFixities, withEnv,
+	-- * Resolving
+	resolveModule, resolvePreloaded, resolve,
+	-- * Saving results
+	updateResolveds
+	) where
+
+import Control.Lens hiding ((.=))
+import Control.Monad.Catch
+import Data.Aeson
+import Data.Generics.Uniplate.Operations
+import Data.Functor
+import Data.Function
+import Data.List
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Ord
+import Data.String
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Language.Haskell.Exts as H
+import qualified Language.Haskell.Names as N
+import qualified Language.Haskell.Names.Open as N
+import qualified Language.Haskell.Names.Annotated as N
+import qualified Language.Haskell.Names.Imports as N
+import qualified Language.Haskell.Names.Exports as N
+import qualified Language.Haskell.Names.ModuleSymbols as N
+import qualified Language.Haskell.Names.SyntaxUtils as N
+import System.Log.Simple
+import Text.Format
+
+import Data.LookupTable
+import System.Directory.Paths
+import HsDev.Database.SQLite as SQLite
+import qualified HsDev.Display as Display
+import HsDev.Error
+import HsDev.Inspect.Definitions
+import HsDev.Inspect.Types
+import HsDev.Symbols
+import qualified HsDev.Symbols.HaskellNames as HN
+import HsDev.Symbols.Parsed as P
+import HsDev.Server.Types
+import HsDev.Util
+
+-- | Try resolve module symbols
+resolveModule :: MonadThrow m => Environment -> FixitiesTable -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved
+resolveModule env fixities p = inspectTag ResolvedNamesTag $ inspectUntag OnlyHeaderTag $ case H.parseFileContentsWithMode (p' ^. preloadedMode) (T.unpack $ p ^. preloaded) of
+	H.ParseFailed loc reason -> hsdevError $ InspectError $ "Parse failed at " ++ show loc ++ ": " ++ reason
+	H.ParseOk m -> return (resolve env m)
+	where
+		qimps = M.keys $ N.importTable env (p ^. preloadedModule)
+		p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` fixities) qimps) } }
+
+-- | Resolve just preloaded part of module, this will give imports and scope
+resolvePreloaded :: MonadThrow m => Environment -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved
+resolvePreloaded env = inspectTag ResolvedNamesTag . return . resolve env . view preloadedModule
+
+-- | Resolve parsed module
+resolve :: Environment -> H.Module H.SrcSpanInfo -> Resolved
+resolve env m = Resolved {
+	_resolvedModule = void mn,
+	_resolvedSource = annotated,
+	_resolvedDefs = getSymbols decls',
+	_resolvedImports = map (toImport . dropScope) idecls',
+	_resolvedExports = N.exportedSymbols tbl m,
+	_resolvedScope = tbl,
+	_resolvedFixities = [H.Fixity (void assoc) (fromMaybe 0 pr) (fixName opName)
+		| H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops] }
+	where
+		getOpName (H.VarOp _ nm) = nm
+		getOpName (H.ConOp _ nm) = nm
+		fixName o = H.Qual () (void mn) (void o)
+		itbl = N.importTable env m
+		tbl = N.moduleTable itbl m
+		-- Not using 'annotate' because we already computed needed tables
+		annotated = H.Module (noScope l) mhead' mpragmas' idecls' decls'
+		H.Module l mhead mpragmas idecls decls = m
+		mhead' = fmap scopeHead mhead
+		mpragmas' = fmap withNoScope mpragmas
+		scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead (noScope lh) (withNoScope mname) (fmap withNoScope mwarns) $
+			fmap (N.annotateExportSpecList tbl) mexports
+		idecls' = N.annotateImportDecls mn env idecls
+		decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl)) decls
+		mn = N.getModuleName m
+
+-- | Load environment and fixities from cache or sql
+loadEnv :: SessionMonad m => Maybe Path -> m (Environment, FixitiesTable)
+loadEnv mcabal = do
+	envTable <- askSession sessionResolveEnvironment
+	cacheInTableM envTable mcabal $ (,) <$> loadEnvironment mcabal <*> loadFixities mcabal
+
+-- | Save environment and fixities to cache
+saveEnv :: SessionMonad m => Maybe Path -> Environment -> FixitiesTable -> m ()
+saveEnv mcabal env fixities = do
+	envTable <- askSession sessionResolveEnvironment
+	void $ insertTable mcabal (env, fixities) envTable
+
+-- | Load environment from sql
+loadEnvironment :: SessionMonad m => Maybe Path -> m Environment
+loadEnvironment mcabal = transaction_ Deferred $ do
+	sendLog Trace $ "loading environment for {}" ~~ fromMaybe "<standalone>" mcabal
+	env <- query @_ @(Only (H.ModuleName ()) :. N.Symbol)
+		(toQuery $ mconcat [
+			select_ ["em.name"],
+			from_ ["projects_modules_scope as ps", "exports as e", "modules as em"],
+			where_ [
+				"ps.cabal is ?",
+				"ps.module_id = em.id",
+				"e.symbol_id = s.id",
+				"e.module_id = em.id"],
+			qNSymbol "m" "s"])
+		(Only mcabal)
+	return $ M.fromList $ do
+		group' <- groupBy ((==) `on` fst) . sortBy (comparing fst) $ [(m, s) | (Only m :. s) <- env]
+		let
+			(gmod:_, gsyms) = unzip group'
+		return (gmod, gsyms)
+
+-- | Load fixities from sql
+loadFixities :: SessionMonad m => Maybe Path -> m FixitiesTable
+loadFixities mcabal = transaction_ Deferred $ do
+	fixities' <- query @_ @(Only Value)
+		(toQuery $ mconcat [
+			select_ ["m.fixities"],
+			from_ ["projects_modules_scope as ps", "modules as m"],
+			where_ [
+				"ps.cabal is ?",
+				"ps.module_id = m.id",
+				"m.fixities is not null"]])
+		(Only mcabal)
+	return $ mconcat [M.singleton n f |
+		f@(H.Fixity _ _ n) <- concat (mapMaybe (fromJSON' . fromOnly) fixities')]
+
+-- | Run with temporary table for environment
+withEnv :: SessionMonad m => Maybe Path -> m a -> m a
+withEnv mcabal = (initEnv >>) where
+	initEnv = do
+		execute_ "create temporary table if not exists resolve (cabal text);"
+		execute_ "create temporary table if not exists env (module text not null, name text not null, what text not null, id integer not null);"
+		execute_ "create unique index if not exists env_id_index on env (id);"
+		execute_ "create unique index if not exists env_symbol_index on env (module, name, what);"
+
+		curEnv <- query_ "select cabal from resolve;"
+		unless (fmap fromOnly (listToMaybe curEnv) == Just mcabal) $ do
+			execute_ "delete from resolve;"
+			execute "insert into resolve values (?);" (Only mcabal)
+			execute_ "delete from env;"
+			executeNamed "insert into env select m.name, s.name, s.what, min(s.id) from modules as m, symbols as s where m.id = s.module_id and s.id in (select distinct e.symbol_id from exports as e where e.module_id in (select ps.module_id from projects_modules_scope as ps where ps.cabal is :cabal)) group by m.name, s.name, s.what;" [
+				":cabal" := mcabal]
+
+		[Only cnt] <- query_ @(Only Int) "select count(*) from env;"
+		sendLog Trace $ "created env table with {} symbols" ~~ cnt
+
+-- | Save results in sql, updated temporary env table
+updateResolveds :: SessionMonad m => Maybe Path -> [InspectedResolved] -> m ()
+updateResolveds mcabal ims = scope "update-resolveds" $ withEnv mcabal $ do
+	ids <- upsertResolveds ims
+	updateResolvedsSymbols (zip ids ims)
+
+upsertResolveds :: SessionMonad m => [InspectedResolved] -> m [Int]
+upsertResolveds ims = scope "upsert-resolveds" $ 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 . resolvedModule . moduleName_, im ^? inspectedKey . installedModuleName],
+			Nothing @Text,
+			fmap encode $ im ^? inspected . resolvedFixities,
+			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]
+
+updateResolvedsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m ()
+updateResolvedsSymbols ims = bracket_ initTemps dropTemps $ do
+	initUpdatedIds ims
+
+	removeModulesContents
+	transaction_ Immediate $ insertModulesDefs ims
+	transaction_ Immediate $ insertModulesImports ims
+	transaction_ Immediate $ insertExportsSymbols ims
+	transaction_ Immediate $ do
+		insertScopesSymbols ims
+		insertResolvedsNames ims
+	commitTemps
+
+	where
+		initTemps :: SessionMonad m => m ()
+		initTemps = do
+			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);"
+			execute_ "create temporary table updating_scopes as select * from scopes where 0;"
+			execute_ "create index updating_scopes_name_index on updating_scopes (module_id, name);"
+			execute_ "create temporary table updating_names as select * from names where 0;"
+			execute_ "create unique index updating_names_position_index on updating_names (module_id, line, column, line_to, column_to);"
+
+		dropTemps :: SessionMonad m => m ()
+		dropTemps = do
+			execute_ "drop table if exists updated_ids;"
+			execute_ "drop table if exists updating_scopes;"
+			execute_ "drop table if exists updating_names;"
+
+		commitTemps :: SessionMonad m => m ()
+		commitTemps = do
+			transaction_ Immediate $ execute_ "insert into scopes select * from updating_scopes;"
+			transaction_ Immediate $ execute_ "insert into names select * from updating_names;"
+
+		initUpdatedIds :: SessionMonad m => [(Int, InspectedResolved)] -> 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 . resolvedModule . 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);"
+
+		insertModulesImports :: SessionMonad m => [(Int, InspectedResolved)] -> m ()
+		insertModulesImports imods = scope "imports" $ do
+			executeMany "insert into imports (module_id, line, column, module_name, qualified, alias, hiding, import_list) values (?, ?, ?, ?, ?, ?, ?, ?);" $ do
+				(mid, im) <- imods
+				let
+					p = im ^?! inspected . resolvedSource
+				idecl@(H.ImportDecl _ mname qual _ _ _ alias specList) <- childrenBi p :: [H.ImportDecl Ann]
+				return (
+					mid,
+					idecl ^. pos . positionLine,
+					idecl ^. pos . positionColumn,
+					getModuleName mname,
+					qual,
+					fmap getModuleName alias,
+					maybe False getHiding specList,
+					fmap makeImportList specList)
+			execute_ "update imports set import_module_id = (select im.id from updated_ids as u, modules as im, projects_modules_scope as ps where ((ps.cabal is null and u.cabal is null) or (ps.cabal == u.cabal)) and ps.module_id == im.id and im.name == imports.module_name) where module_id in (select u.id from updated_ids as u);"
+			where
+				getModuleName (H.ModuleName _ s) = s
+				getHiding (H.ImportSpecList _ h _) = h
+
+				makeImportList (H.ImportSpecList _ _ specs) = encode $ map asJson specs
+				asJson (H.IVar _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "var"]
+				asJson (H.IAbs _ ns nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "abs", "ns" .= fromNamespace ns] where
+					fromNamespace :: H.Namespace l -> Maybe String
+					fromNamespace (H.NoNamespace _) = Nothing
+					fromNamespace (H.TypeNamespace _) = Just "type"
+					fromNamespace (H.PatternNamespace _) = Just "pat"
+				asJson (H.IThingAll _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "all"]
+				asJson (H.IThingWith _ nm cs) = object ["name" .= fromName_ (void nm), "what" .= id @String "with", "list" .= map (fromName_ . void . toName') cs] where
+					toName' (H.VarName _ n') = n'
+					toName' (H.ConName _ n') = n'
+
+		insertModulesDefs :: SessionMonad m => [(Int, InspectedResolved)] -> m ()
+		insertModulesDefs imods = scope "defs" $ do
+			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
+				sym <- im ^.. inspected . resolvedDefs . each
+				return $ (
+					sym ^. symbolId . symbolName,
+					mid,
+					sym ^. symbolDocs,
+					sym ^? symbolPosition . _Just . positionLine,
+					sym ^? symbolPosition . _Just . positionColumn)
+					:.
+					(sym ^. symbolInfo)
+			execute_ "insert or replace into env (module, name, what, id) select m.name, s.name, s.what, s.id from modules as m, symbols as s where m.id in (select id from updated_ids) and s.module_id = m.id;"
+
+		insertExportsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m ()
+		insertExportsSymbols imods = scope "exports" $ executeMany "insert into exports (module_id, symbol_id) select ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do
+			(mid, im) <- imods
+			sym <- im ^.. inspected . resolvedExports . each
+			return (
+				mid,
+				N.symbolModule sym,
+				N.symbolName sym,
+				symbolType (HN.fromSymbol sym))
+
+		insertScopesSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m ()
+		insertScopesSymbols imods = scope "scope" $ executeMany "insert into updating_scopes (module_id, qualifier, name, symbol_id) select ?, ?, ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do
+			(mid, im) <- imods
+			(qn, syms) <- M.toList (im ^. inspected . resolvedScope)
+			sym <- syms
+			return (
+				mid,
+				nameModule qn,
+				nameIdent qn,
+				N.symbolModule sym,
+				N.symbolName sym,
+				symbolType (HN.fromSymbol sym))
+
+		insertResolvedsNames :: SessionMonad m => [(Int, InspectedResolved)] -> m ()
+		insertResolvedsNames imods = scope "names" $ do
+			insertNames
+			replaceQNames
+			resolveGlobalBinders
+			setResolvedsSymbolIds
+			where
+				insertNames = executeMany insertQuery namesData
+				replaceQNames = executeMany insertQuery qnamesData
+				resolveGlobalBinders = execute_ "update updating_names set (resolved_module, resolved_name, resolved_what) = (select u.module, s.name, s.what from updated_ids as u, symbols as s where u.id = s.module_id and s.module_id = updating_names.module_id and s.line = updating_names.line and s.column = updating_names.column) where (line, column) = (def_line, def_column) and resolved_module is null and resolved_name is null;"
+				setResolvedsSymbolIds = execute_ "update updating_names set symbol_id = (select sc.symbol_id from updating_scopes as sc, symbols as s, modules as m where updating_names.module_id == sc.module_id and ((updating_names.qualifier is null and sc.qualifier is null) or (updating_names.qualifier == sc.qualifier)) and updating_names.name == sc.name and s.id == sc.symbol_id and m.id == s.module_id and s.name == updating_names.resolved_name and s.what == updating_names.resolved_what and m.name == updating_names.resolved_module) where resolved_module is not null and resolved_name is not null and resolved_what is not null;"
+				insertQuery = "insert or replace into updating_names (module_id, qualifier, name, line, column, line_to, column_to, def_line, def_column, resolved_module, resolved_name, resolved_what, resolve_error) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"
+
+				namesData = map (uncurry toData) $ do
+					(mid, im) <- imods
+					n <- im ^.. inspected . resolvedSource . P.names
+					return (mid, n)
+				qnamesData = map (uncurry toQData) $ do
+					(mid, im) <- imods
+					n <- im ^.. inspected . resolvedSource . P.qnames
+					return (mid, n)
+
+				toData mid name = (
+					mid,
+					Nothing :: Maybe Text,
+					fromName_ $ void name,
+					name ^. P.pos . positionLine,
+					name ^. P.pos . positionColumn,
+					name ^. P.regionL . regionTo . positionLine,
+					name ^. P.regionL . regionTo . positionColumn)
+					:. (
+					name ^? P.defPos . positionLine,
+					name ^? P.defPos . positionColumn,
+					(name ^? P.resolvedName) >>= nameModule,
+					nameIdent <$> (name ^? P.resolvedName),
+					fmap (symbolType . HN.fromSymbol) $ name ^? P.symbolL,
+					P.resolveError name)
+				toQData mid qname = (
+					mid,
+					nameModule $ void qname,
+					nameIdent $ void qname,
+					qname ^. P.pos . positionLine,
+					qname ^. P.pos . positionColumn,
+					qname ^. P.regionL . regionTo . positionLine,
+					qname ^. P.regionL . regionTo . positionColumn)
+					:. (
+					qname ^? P.defPos . positionLine,
+					qname ^? P.defPos . positionColumn,
+					(qname ^? P.resolvedName) >>= nameModule,
+					nameIdent <$> (qname ^? P.resolvedName),
+					fmap (symbolType . HN.fromSymbol) $ qname ^? P.symbolL,
+					P.resolveError qname)
src/HsDev/Inspect/Types.hs view
@@ -1,104 +1,104 @@-{-# LANGUAGE TemplateHaskell #-}--module HsDev.Inspect.Types (-	Preloaded(..), preloadedId, preloadedMode, preloadedModule, asModule, toImport, preloaded,-	InspectedPreloaded,-	Environment, FixitiesTable,-	Resolved(..), resolvedModule, resolvedSource, resolvedDefs, resolvedImports, resolvedExports, resolvedScope, resolvedFixities,-	InspectedResolved,--	resolvedEnv, resolvedFixitiesTable,--	dropScope, noScope, withNoScope-	) where--import Control.DeepSeq-import Control.Lens-import Data.Map (Map)-import qualified Data.Map as M-import Data.String-import Data.Text (Text)-import qualified Language.Haskell.Exts as H-import qualified Language.Haskell.Names as N-import qualified Language.Haskell.Names.GlobalSymbolTable as N--import HsDev.Symbols.Types-import HsDev.Symbols.Parsed (Parsed, pos)---- | Preloaded module with contents and extensions-data Preloaded = Preloaded {-	_preloadedId :: ModuleId,-	_preloadedMode :: H.ParseMode,-	_preloadedModule :: H.Module H.SrcSpanInfo,-	-- ^ Loaded module head without declarations-	_preloaded :: Text }--instance NFData Preloaded where-	rnf (Preloaded mid _ _ cts) = rnf mid `seq` rnf cts--asModule :: Lens' Preloaded Module-asModule = lens g' s' where-	g' p = Module {-		_moduleId = _preloadedId p,-		_moduleDocs = Nothing,-		_moduleImports = map toImport idecls,-		_moduleExports = mempty,-		_moduleFixities = mempty,-		_moduleScope = mempty,-		_moduleSource = Just $ fmap (N.Scoped N.None) $ _preloadedModule p }-		where-			H.Module _ _ _ idecls _ = _preloadedModule p-	s' p m = p {-		_preloadedId = _moduleId m,-		_preloadedModule = maybe (_preloadedModule p) dropScope (_moduleSource m) }--toImport :: H.ImportDecl H.SrcSpanInfo -> Import-toImport idecl@(H.ImportDecl _ mname qual _ _ _ alias _) = Import (idecl ^. pos) (fromString $ getModuleName mname) qual (fmap (fromString . getModuleName) alias) where-	getModuleName (H.ModuleName _ s) = s--type InspectedPreloaded = Inspected ModuleLocation ModuleTag Preloaded---- | Symbols environment, used to resolve names in source-type Environment = N.Environment---- | Fixities environment, needed to parse source-type FixitiesTable = Map Name H.Fixity---- | Resolved module-data Resolved = Resolved {-	_resolvedModule :: H.ModuleName (),-	_resolvedSource :: Parsed,-	_resolvedDefs :: [Symbol],-	_resolvedImports :: [Import],-	_resolvedExports :: [N.Symbol],-	_resolvedScope :: N.Table,-	_resolvedFixities :: [H.Fixity] }--instance NFData Resolved where-	rnf (Resolved _ _ defs imps _ _ _) = rnf defs `seq` rnf imps---- | Like @InspectedModule@, but for @Resolved@-type InspectedResolved = Inspected ModuleLocation ModuleTag Resolved---- | Get environment for resolved module-resolvedEnv :: Resolved -> Environment-resolvedEnv r = M.singleton (_resolvedModule r) (_resolvedExports r)---- | Get fixities table from resolved module-resolvedFixitiesTable :: Resolved -> FixitiesTable-resolvedFixitiesTable r = mconcat [M.singleton n f | f@(H.Fixity _ _ n) <- _resolvedFixities r]---- | Drop extra info-dropScope :: Functor f => f (N.Scoped l) -> f l-dropScope = fmap (\(N.Scoped _ a) -> a)---- | Empty scope info-noScope :: l -> N.Scoped l-noScope = N.Scoped N.None---- | Set empty scope-withNoScope :: Functor f => f l -> f (N.Scoped l)-withNoScope = fmap noScope--makeLenses ''Preloaded-makeLenses ''Resolved+{-# LANGUAGE TemplateHaskell #-}
+
+module HsDev.Inspect.Types (
+	Preloaded(..), preloadedId, preloadedMode, preloadedModule, asModule, toImport, preloaded,
+	InspectedPreloaded,
+	Environment, FixitiesTable,
+	Resolved(..), resolvedModule, resolvedSource, resolvedDefs, resolvedImports, resolvedExports, resolvedScope, resolvedFixities,
+	InspectedResolved,
+
+	resolvedEnv, resolvedFixitiesTable,
+
+	dropScope, noScope, withNoScope
+	) where
+
+import Control.DeepSeq
+import Control.Lens
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.String
+import Data.Text (Text)
+import qualified Language.Haskell.Exts as H
+import qualified Language.Haskell.Names as N
+import qualified Language.Haskell.Names.GlobalSymbolTable as N
+
+import HsDev.Symbols.Types
+import HsDev.Symbols.Parsed (Parsed, pos)
+
+-- | Preloaded module with contents and extensions
+data Preloaded = Preloaded {
+	_preloadedId :: ModuleId,
+	_preloadedMode :: H.ParseMode,
+	_preloadedModule :: H.Module H.SrcSpanInfo,
+	-- ^ Loaded module head without declarations
+	_preloaded :: Text }
+
+instance NFData Preloaded where
+	rnf (Preloaded mid _ _ cts) = rnf mid `seq` rnf cts
+
+asModule :: Lens' Preloaded Module
+asModule = lens g' s' where
+	g' p = Module {
+		_moduleId = _preloadedId p,
+		_moduleDocs = Nothing,
+		_moduleImports = map toImport idecls,
+		_moduleExports = mempty,
+		_moduleFixities = mempty,
+		_moduleScope = mempty,
+		_moduleSource = Just $ fmap (N.Scoped N.None) $ _preloadedModule p }
+		where
+			H.Module _ _ _ idecls _ = _preloadedModule p
+	s' p m = p {
+		_preloadedId = _moduleId m,
+		_preloadedModule = maybe (_preloadedModule p) dropScope (_moduleSource m) }
+
+toImport :: H.ImportDecl H.SrcSpanInfo -> Import
+toImport idecl@(H.ImportDecl _ mname qual _ _ _ alias _) = Import (idecl ^. pos) (fromString $ getModuleName mname) qual (fmap (fromString . getModuleName) alias) where
+	getModuleName (H.ModuleName _ s) = s
+
+type InspectedPreloaded = Inspected ModuleLocation ModuleTag Preloaded
+
+-- | Symbols environment, used to resolve names in source
+type Environment = N.Environment
+
+-- | Fixities environment, needed to parse source
+type FixitiesTable = Map Name H.Fixity
+
+-- | Resolved module
+data Resolved = Resolved {
+	_resolvedModule :: H.ModuleName (),
+	_resolvedSource :: Parsed,
+	_resolvedDefs :: [Symbol],
+	_resolvedImports :: [Import],
+	_resolvedExports :: [N.Symbol],
+	_resolvedScope :: N.Table,
+	_resolvedFixities :: [H.Fixity] }
+
+instance NFData Resolved where
+	rnf (Resolved _ _ defs imps _ _ _) = rnf defs `seq` rnf imps
+
+-- | Like @InspectedModule@, but for @Resolved@
+type InspectedResolved = Inspected ModuleLocation ModuleTag Resolved
+
+-- | Get environment for resolved module
+resolvedEnv :: Resolved -> Environment
+resolvedEnv r = M.singleton (_resolvedModule r) (_resolvedExports r)
+
+-- | Get fixities table from resolved module
+resolvedFixitiesTable :: Resolved -> FixitiesTable
+resolvedFixitiesTable r = mconcat [M.singleton n f | f@(H.Fixity _ _ n) <- _resolvedFixities r]
+
+-- | Drop extra info
+dropScope :: Functor f => f (N.Scoped l) -> f l
+dropScope = fmap (\(N.Scoped _ a) -> a)
+
+-- | Empty scope info
+noScope :: l -> N.Scoped l
+noScope = N.Scoped N.None
+
+-- | Set empty scope
+withNoScope :: Functor f => f l -> f (N.Scoped l)
+withNoScope = fmap noScope
+
+makeLenses ''Preloaded
+makeLenses ''Resolved
src/HsDev/PackageDb.hs view
@@ -1,65 +1,69 @@-{-# LANGUAGE OverloadedStrings #-}--module HsDev.PackageDb (-	module HsDev.PackageDb.Types,--	packageDbPath, readPackageDb-	) where--import Control.Lens-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe (listToMaybe)-import Data.Text (pack, unpack)-import Data.Traversable-import Distribution.InstalledPackageInfo-import Distribution.Package-import Distribution.Text (disp)-import System.FilePath--import GHC.Paths--import HsDev.PackageDb.Types-import HsDev.Error-import HsDev.Symbols.Location-import HsDev.Tools.Base-import HsDev.Util (directoryContents, readFileUtf8)-import System.Directory.Paths---- | Get path to package-db-packageDbPath :: PackageDb -> IO Path-packageDbPath GlobalDb = do-	out <- fmap lines $ runTool_ ghc_pkg ["list", "--global"]-	case out of-		(fpath:_) -> return $ fromFilePath $ normalise fpath-		[] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to global package-db"-packageDbPath UserDb = do-	out <- fmap lines $ runTool_ ghc_pkg ["list", "--user"]-	case out of-		(fpath:_) -> return $ fromFilePath $ normalise fpath-		[] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to user package db"-packageDbPath (PackageDb fpath) = return fpath---- | Read package-db conf files-readPackageDb :: PackageDb -> IO (Map ModulePackage [ModuleLocation])-readPackageDb pdb = do-	p <- packageDbPath pdb-	mlibdir <- fmap (listToMaybe . lines) $ runTool_ ghc ["--print-libdir"]-	confs <- fmap (filter isConf) $ directoryContents (p ^. path)-	fmap M.unions $ forM confs $ \conf -> do-		cts <- readFileUtf8 conf-		case parseInstalledPackageInfo (unpack cts) of-			ParseFailed _ -> return M.empty  -- FIXME: Should log as warning-			ParseOk _ res -> return $ over (each . each . moduleInstallDirs . each) (subst mlibdir) $ listMods res-	where-		isConf f = takeExtension f == ".conf"-		listMods pinfo = M.singleton pname pmods where-			pname = ModulePackage-				(pack . show . disp . pkgName $ sourcePackageId pinfo)-				(pack . show . disp . pkgVersion $ sourcePackageId pinfo)-			pmods = [InstalledModule (map fromFilePath $ libraryDirs pinfo) pname nm exposed' | (nm, exposed') <- names]-			names = zip (map (pack . show . disp) (exposedModules pinfo)) (repeat True) ++ zip (map (pack . show . disp) (hiddenModules pinfo)) (repeat False)-		subst Nothing f = f-		subst (Just libdir') f = case splitPaths f of-			("$topdir":rest) -> joinPaths (fromFilePath libdir' : rest)-			_ -> f+{-# LANGUAGE OverloadedStrings #-}
+
+module HsDev.PackageDb (
+        module HsDev.PackageDb.Types,
+
+        packageDbPath, readPackageDb
+        ) where
+
+import Control.Lens
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe (listToMaybe)
+import Data.Text (pack, unpack)
+import Data.Traversable
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Distribution.Text (disp)
+import System.FilePath
+
+import GHC.Paths
+
+import HsDev.PackageDb.Types
+import HsDev.Error
+import HsDev.Symbols.Location
+import HsDev.Tools.Base
+import HsDev.Util (directoryContents, readFileUtf8)
+import System.Directory.Paths
+
+-- | Get path to package-db
+packageDbPath :: PackageDb -> IO Path
+packageDbPath GlobalDb = do
+        out <- fmap lines $ runTool_ ghc_pkg ["list", "--global"]
+        case out of
+                (fpath:_) -> return $ fromFilePath $ normalise fpath
+                [] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to global package-db"
+packageDbPath UserDb = do
+        out <- fmap lines $ runTool_ ghc_pkg ["list", "--user"]
+        case out of
+                (fpath:_) -> return $ fromFilePath $ normalise fpath
+         -- Bailing on the user package db if there isn't one doesn't seem quite correct. 'stack' and 'cabal'
+         -- can report no path...
+         --     [] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to user package db"
+         -- Report an empty path instead.
+                [] -> return $ fromFilePath ""
+packageDbPath (PackageDb fpath) = return fpath
+
+-- | Read package-db conf files
+readPackageDb :: PackageDb -> IO (Map ModulePackage [ModuleLocation])
+readPackageDb pdb = do
+        p <- packageDbPath pdb
+        mlibdir <- fmap (listToMaybe . lines) $ runTool_ ghc ["--print-libdir"]
+        confs <- fmap (filter isConf) $ directoryContents (p ^. path)
+        fmap M.unions $ forM confs $ \conf -> do
+                cts <- readFileUtf8 conf
+                case parseInstalledPackageInfo (unpack cts) of
+                        ParseFailed _ -> return M.empty  -- FIXME: Should log as warning
+                        ParseOk _ res -> return $ over (each . each . moduleInstallDirs . each) (subst mlibdir) $ listMods res
+        where
+                isConf f = takeExtension f == ".conf"
+                listMods pinfo = M.singleton pname pmods where
+                        pname = ModulePackage
+                                (pack . show . disp . pkgName $ sourcePackageId pinfo)
+                                (pack . show . disp . pkgVersion $ sourcePackageId pinfo)
+                        pmods = [InstalledModule (map fromFilePath $ libraryDirs pinfo) pname nm exposed' | (nm, exposed') <- names]
+                        names = zip (map (pack . show . disp) (exposedModules pinfo)) (repeat True) ++ zip (map (pack . show . disp) (hiddenModules pinfo)) (repeat False)
+                subst Nothing f = f
+                subst (Just libdir') f = case splitPaths f of
+                        ("$topdir":rest) -> joinPaths (fromFilePath libdir' : rest)
+                        _ -> f
src/HsDev/PackageDb/Types.hs view
@@ -1,136 +1,136 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}--module HsDev.PackageDb.Types (-	PackageDb(..), packageDb,-	PackageDbStack(..), packageDbStack, mkPackageDbStack,-	globalDb, userDb, fromPackageDbs,-	topPackageDb, packageDbs, packageDbStacks,-	isSubStack,--	packageDbOpt, packageDbStackOpts-	) where--import Control.Applicative-import Control.Monad (guard)-import Control.Lens (makeLenses, each, (^.))-import Control.DeepSeq (NFData(..))-import Data.Aeson-import Data.List (tails, isSuffixOf, intercalate)-import qualified Data.Text as T-import Data.String-import Text.Format--import System.Directory.Paths-import HsDev.Display--data PackageDb = GlobalDb | UserDb | PackageDb { _packageDb :: Path } deriving (Eq, Ord)--makeLenses ''PackageDb--instance NFData PackageDb where-	rnf GlobalDb = ()-	rnf UserDb = ()-	rnf (PackageDb p) = rnf p--instance Show PackageDb where-	show GlobalDb = "global-db"-	show UserDb = "user-db"-	show (PackageDb p) = "package-db:" ++ p ^. path--instance Display PackageDb where-	display GlobalDb = "global-db"-	display UserDb = "user-db"-	display (PackageDb p) = "package-db " ++ display p-	displayType _ = "package-db"--instance Formattable PackageDb where-	formattable = formattable . display--instance ToJSON PackageDb where-	toJSON GlobalDb = "global-db"-	toJSON UserDb = "user-db"-	toJSON (PackageDb p) = fromString $ "package-db:" ++ p ^. path--instance FromJSON PackageDb where-	parseJSON v = globalP v <|> userP v <|> dbP v where-		globalP = withText "global-db" (\s -> guard (s == "global-db") >> return GlobalDb)-		userP = withText "user-db" (\s -> guard (s == "user-db") >> return UserDb)-		dbP = withText "package-db" $ \s -> case T.stripPrefix "package-db:" s of-			Nothing -> fail ("Can't parse package-db: " ++ T.unpack s)-			Just p' -> return $ PackageDb p'--instance Paths PackageDb where-	paths _ GlobalDb = pure GlobalDb-	paths _ UserDb = pure UserDb-	paths f (PackageDb p) = PackageDb <$> paths f p---- | Stack of PackageDb in reverse order-newtype PackageDbStack = PackageDbStack { _packageDbStack :: [PackageDb] } deriving (Eq, Ord, Show)--makeLenses ''PackageDbStack--instance NFData PackageDbStack where-	rnf (PackageDbStack ps) = rnf ps--instance Display PackageDbStack where-	display = intercalate "/" . map display . packageDbs-	displayType _ = "package-db-stack"--instance Formattable PackageDbStack where-	formattable = formattable . display--instance ToJSON PackageDbStack where-	toJSON (PackageDbStack ps) = toJSON ps--instance FromJSON PackageDbStack where-	parseJSON = fmap PackageDbStack . parseJSON--instance Paths PackageDbStack where-	paths f (PackageDbStack ps) = PackageDbStack <$> (each . paths) f ps---- | Make @PackageDbStack@ from list of @PackageDb@-mkPackageDbStack :: [PackageDb] -> PackageDbStack-mkPackageDbStack = PackageDbStack . reverse . dropWhile (== GlobalDb)---- | Global db stack-globalDb :: PackageDbStack-globalDb = PackageDbStack []---- | User db stack-userDb :: PackageDbStack-userDb = PackageDbStack [UserDb]---- | Make package-db stack from paths-fromPackageDbs :: [Path] -> PackageDbStack-fromPackageDbs = PackageDbStack . map PackageDb . reverse---- | Get top package-db for package-db stack-topPackageDb :: PackageDbStack -> PackageDb-topPackageDb (PackageDbStack []) = GlobalDb-topPackageDb (PackageDbStack (d:_)) = d---- | Get list of package-db in stack, adds additional global-db at bottom-packageDbs :: PackageDbStack -> [PackageDb]-packageDbs = (GlobalDb :) . reverse . _packageDbStack---- | Get stacks for each package-db in stack-packageDbStacks :: PackageDbStack -> [PackageDbStack]-packageDbStacks = map PackageDbStack . tails . _packageDbStack---- | Is one package-db stack substack of another-isSubStack :: PackageDbStack -> PackageDbStack -> Bool-isSubStack (PackageDbStack l) (PackageDbStack r) = l `isSuffixOf` r---- | Get ghc options for package-db-packageDbOpt :: PackageDb -> String-packageDbOpt GlobalDb = "-global-package-db"-packageDbOpt UserDb = "-user-package-db"-packageDbOpt (PackageDb p) = "-package-db " ++ p ^. path---- | Get ghc options for package-db stack-packageDbStackOpts :: PackageDbStack -> [String]-packageDbStackOpts (PackageDbStack ps)-	| "-user-package-db" `elem` opts' = opts'-	| otherwise = "-no-user-package-db" : opts'-	where-		opts' = map packageDbOpt (reverse ps)+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module HsDev.PackageDb.Types (
+	PackageDb(..), packageDb,
+	PackageDbStack(..), packageDbStack, mkPackageDbStack,
+	globalDb, userDb, fromPackageDbs,
+	topPackageDb, packageDbs, packageDbStacks,
+	isSubStack,
+
+	packageDbOpt, packageDbStackOpts
+	) where
+
+import Control.Applicative
+import Control.Monad (guard)
+import Control.Lens (makeLenses, each, (^.))
+import Control.DeepSeq (NFData(..))
+import Data.Aeson
+import Data.List (tails, isSuffixOf, intercalate)
+import qualified Data.Text as T
+import Data.String
+import Text.Format
+
+import System.Directory.Paths
+import HsDev.Display
+
+data PackageDb = GlobalDb | UserDb | PackageDb { _packageDb :: Path } deriving (Eq, Ord)
+
+makeLenses ''PackageDb
+
+instance NFData PackageDb where
+	rnf GlobalDb = ()
+	rnf UserDb = ()
+	rnf (PackageDb p) = rnf p
+
+instance Show PackageDb where
+	show GlobalDb = "global-db"
+	show UserDb = "user-db"
+	show (PackageDb p) = "package-db:" ++ p ^. path
+
+instance Display PackageDb where
+	display GlobalDb = "global-db"
+	display UserDb = "user-db"
+	display (PackageDb p) = "package-db " ++ display p
+	displayType _ = "package-db"
+
+instance Formattable PackageDb where
+	formattable = formattable . display
+
+instance ToJSON PackageDb where
+	toJSON GlobalDb = "global-db"
+	toJSON UserDb = "user-db"
+	toJSON (PackageDb p) = fromString $ "package-db:" ++ p ^. path
+
+instance FromJSON PackageDb where
+	parseJSON v = globalP v <|> userP v <|> dbP v where
+		globalP = withText "global-db" (\s -> guard (s == "global-db") >> return GlobalDb)
+		userP = withText "user-db" (\s -> guard (s == "user-db") >> return UserDb)
+		dbP = withText "package-db" $ \s -> case T.stripPrefix "package-db:" s of
+			Nothing -> fail ("Can't parse package-db: " ++ T.unpack s)
+			Just p' -> return $ PackageDb p'
+
+instance Paths PackageDb where
+	paths _ GlobalDb = pure GlobalDb
+	paths _ UserDb = pure UserDb
+	paths f (PackageDb p) = PackageDb <$> paths f p
+
+-- | Stack of PackageDb in reverse order
+newtype PackageDbStack = PackageDbStack { _packageDbStack :: [PackageDb] } deriving (Eq, Ord, Show)
+
+makeLenses ''PackageDbStack
+
+instance NFData PackageDbStack where
+	rnf (PackageDbStack ps) = rnf ps
+
+instance Display PackageDbStack where
+	display = intercalate "/" . map display . packageDbs
+	displayType _ = "package-db-stack"
+
+instance Formattable PackageDbStack where
+	formattable = formattable . display
+
+instance ToJSON PackageDbStack where
+	toJSON (PackageDbStack ps) = toJSON ps
+
+instance FromJSON PackageDbStack where
+	parseJSON = fmap PackageDbStack . parseJSON
+
+instance Paths PackageDbStack where
+	paths f (PackageDbStack ps) = PackageDbStack <$> (each . paths) f ps
+
+-- | Make @PackageDbStack@ from list of @PackageDb@
+mkPackageDbStack :: [PackageDb] -> PackageDbStack
+mkPackageDbStack = PackageDbStack . reverse . dropWhile (== GlobalDb)
+
+-- | Global db stack
+globalDb :: PackageDbStack
+globalDb = PackageDbStack []
+
+-- | User db stack
+userDb :: PackageDbStack
+userDb = PackageDbStack [UserDb]
+
+-- | Make package-db stack from paths
+fromPackageDbs :: [Path] -> PackageDbStack
+fromPackageDbs = PackageDbStack . map PackageDb . reverse
+
+-- | Get top package-db for package-db stack
+topPackageDb :: PackageDbStack -> PackageDb
+topPackageDb (PackageDbStack []) = GlobalDb
+topPackageDb (PackageDbStack (d:_)) = d
+
+-- | Get list of package-db in stack, adds additional global-db at bottom
+packageDbs :: PackageDbStack -> [PackageDb]
+packageDbs = (GlobalDb :) . reverse . _packageDbStack
+
+-- | Get stacks for each package-db in stack
+packageDbStacks :: PackageDbStack -> [PackageDbStack]
+packageDbStacks = map PackageDbStack . tails . _packageDbStack
+
+-- | Is one package-db stack substack of another
+isSubStack :: PackageDbStack -> PackageDbStack -> Bool
+isSubStack (PackageDbStack l) (PackageDbStack r) = l `isSuffixOf` r
+
+-- | Get ghc options for package-db
+packageDbOpt :: PackageDb -> String
+packageDbOpt GlobalDb = "-global-package-db"
+packageDbOpt UserDb = "-user-package-db"
+packageDbOpt (PackageDb p) = "-package-db " ++ p ^. path
+
+-- | Get ghc options for package-db stack
+packageDbStackOpts :: PackageDbStack -> [String]
+packageDbStackOpts (PackageDbStack ps)
+	| "-user-package-db" `elem` opts' = opts'
+	| otherwise = "-no-user-package-db" : opts'
+	where
+		opts' = map packageDbOpt (reverse ps)
src/HsDev/Project.hs view
@@ -1,197 +1,197 @@-{-# LANGUAGE OverloadedStrings, CPP #-}--module HsDev.Project (-	module HsDev.Project.Types,--	infoSourceDirsDef, targetFiles, projectTargetFiles,-	analyzeCabal,-	readProject, loadProject,-	withExtensions,-	fileInTarget, fileTarget, fileTargets, findSourceDir, sourceDirs,-	targetOpts,--	-- * Helpers-	showExtension, flagExtension, extensionFlag,-	extensionsOpts-	) where--import Control.Arrow-import Control.Lens hiding ((.=), (%=), (<.>), set')-import Control.Monad.Except-import Control.Monad.Loops-import Data.List-import Data.Maybe-import Data.Text (Text, pack, unpack)-import qualified Data.Text as T (intercalate)-import Data.Text.Lens (unpacked)-import Distribution.Compiler (CompilerFlavor(GHC))-import qualified Distribution.Package as P-import qualified Distribution.PackageDescription as PD-import qualified Distribution.ModuleName as PD (toFilePath)-import Distribution.PackageDescription.Parse-import Distribution.ModuleName (components)-import Distribution.Text (display)-import Language.Haskell.Extension-import System.FilePath-import System.Log.Simple hiding (Level(..))-import qualified System.Log.Simple as Log (Level(..))-import Text.Format--import System.Directory.Paths-import HsDev.Project.Compat-import HsDev.Project.Types-import HsDev.Error-import HsDev.Util---- | infoSourceDirs lens with default-infoSourceDirsDef :: Lens' Info [Path]-infoSourceDirsDef = lens get' set' where-	get' i = case _infoSourceDirs i of-		[] -> ["."]-		dirs -> dirs-	set' i ["."] = i { _infoSourceDirs = [] }-	set' i dirs = i { _infoSourceDirs = dirs }---- | Get all source file names of target without prepending them with source-dirs-targetFiles :: Target t => t -> [Path]-targetFiles target' = concat [-	maybeToList (targetMain target'),-	map toFile $ targetModules target',-	map toFile $ target' ^.. buildInfo . infoOtherModules . each]-	where-		toFile ps = fromFilePath (joinPath (ps ^.. each . unpacked) <.> "hs")---- | Get all source file names relative to project root-projectTargetFiles :: (MonadLog m, Target t) => Project -> t -> m [Path]-projectTargetFiles proj t = do-	liftM concat $ forM files $ \file' -> do-		candidate <- liftIO $ firstM (fileExists . absolutise (proj ^. projectPath)) [subPath srcDir file' | srcDir <- srcDirs]-		case candidate of-			Nothing -> do-				sendLog Log.Warning $ "Unable to locate source file: {} in source-dirs: {}" ~~ file' ~~ (T.intercalate ", " srcDirs)-				return []-			Just file'' -> return [normPath file'']-	where-		files = targetFiles t-		srcDirs = t ^.. buildInfo . infoSourceDirsDef . each---- | Analyze cabal file-analyzeCabal :: String -> Either String ProjectDescription-analyzeCabal source = case liftM flattenDescr $ parsePackageDesc source of-	ParseOk _ r -> Right ProjectDescription {-		_projectVersion = pack $ showVer $ P.pkgVersion $ PD.package r,-		_projectLibrary = fmap toLibrary $ PD.library r,-		_projectExecutables = fmap toExecutable $ PD.executables r,-		_projectTests = fmap toTest $ PD.testSuites r }-	ParseFailed e -> Left $ "Parse failed: " ++ show e-	where-		toLibrary lib = Library (map (map pack . components) $ PD.exposedModules lib) (toInfo $ PD.libBuildInfo lib)-		toExecutable exe = Executable (componentName $ PD.exeName exe) (fromFilePath $ PD.modulePath exe) (toInfo $ PD.buildInfo exe)-		toTest test = Test (componentName $ PD.testName test) (testSuiteEnabled test) (fmap fromFilePath mainFile) (toInfo $ PD.testBuildInfo test) where-			mainFile = case PD.testInterface test of-				PD.TestSuiteExeV10 _ fpath -> Just fpath-				PD.TestSuiteLibV09 _ mname -> Just $ PD.toFilePath mname-				_ -> Nothing-		toInfo info = Info {-			_infoDepends = map pkgName (PD.targetBuildDepends info),-			_infoLanguage = PD.defaultLanguage info,-			_infoExtensions = PD.defaultExtensions info ++ PD.otherExtensions info ++ PD.oldExtensions info,-			_infoGHCOptions = maybe [] (map pack) $ lookup GHC (PD.options info),-			_infoSourceDirs = map pack $ PD.hsSourceDirs info,-			_infoOtherModules = map (map pack . components) (PD.otherModules info) }--		pkgName :: P.Dependency -> Text-		pkgName (P.Dependency dep _) = pack $ P.unPackageName dep--		flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription-		flattenDescr gpkg = pkg {-			PD.library = flip fmap mlib $ flattenCondTree-				(insertInfo PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })),-			PD.executables = flip fmap mexes $-				second (flattenCondTree (insertInfo PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>>-				(\(n, e) -> e { PD.exeName = n }),-			PD.testSuites = flip fmap mtests $-				second (flattenCondTree (insertInfo PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>>-				(\(n, t) -> t { PD.testName = n }) }-			where-				pkg = PD.packageDescription gpkg-				mlib = PD.condLibrary gpkg-				mexes = PD.condExecutables gpkg-				mtests = PD.condTestSuites gpkg--				insertInfo :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a-				insertInfo f s deps' x = s ((f x) { PD.targetBuildDepends = deps' }) x---- | Read project info from .cabal-readProject :: FilePath -> IO Project-readProject file' = do-	source <- readFile file'-	length source `seq` either (hsdevError . InspectCabalError file') (return . mkProject) $ analyzeCabal source-	where-		mkProject desc = (project file') {-			_projectDescription = Just desc }---- | Load project description-loadProject :: Project -> IO Project-loadProject p-	| isJust (_projectDescription p) = return p-	| otherwise = readProject (_projectCabal p ^. path)---- | Extensions for target-withExtensions :: a -> Info -> Extensions a-withExtensions x i = Extensions {-	_extensions = _infoExtensions i,-	_ghcOptions = _infoGHCOptions i,-	_entity = x }---- | Check if source related to target, source must be relative to project directory-fileInTarget :: Path -> Info -> Bool-fileInTarget src info = any (`isParent` src) $ view infoSourceDirsDef info---- | Get first target for source file-fileTarget :: Project -> Path -> Maybe Info-fileTarget p f = listToMaybe $ fileTargets p f---- | Get possible targets for source file--- There can be many candidates in case of module related to several executables or tests-fileTargets :: Project -> Path -> [Info]-fileTargets p f = case filter ((`isParent` f') . view executablePath) exes of-	[] -> filter (f' `fileInTarget`) (p ^.. projectDescription . _Just . infos)-	exes' -> map _executableBuildInfo exes'-	where-		f' = relPathTo (_projectPath p) f-		exes = p ^. projectDescription . _Just . projectExecutables---- | Finds source dir file belongs to-findSourceDir :: Project -> Path -> Maybe (Extensions Path)-findSourceDir p f = do-	info <- listToMaybe $ fileTargets p f-	fmap (`withExtensions` info) $ listToMaybe $ filter (`isParent` f) $ map (_projectPath p `subPath`) (info ^. infoSourceDirsDef)---- | Returns source dirs for library, executables and tests-sourceDirs :: ProjectDescription -> [Extensions Path]-sourceDirs = ordNub . concatMap dirs . toListOf infos where-	dirs i = map (`withExtensions` i) (i ^. infoSourceDirsDef)---- | Get options for specific target-targetOpts :: Info -> [String]-targetOpts info' = concat [-	["-i" ++ unpack s | s <- _infoSourceDirs info'],-	extensionsOpts $ withExtensions () info',-	["-package " ++ unpack p | p <- _infoDepends info']]---- | Extension as flag name-showExtension :: Extension -> String-showExtension = display---- | Convert -Xext to ext-flagExtension :: String -> Maybe String-flagExtension = stripPrefix "-X"---- | Convert ext to -Xext-extensionFlag :: String -> String-extensionFlag = ("-X" ++)---- | Extensions as opts to GHC-extensionsOpts :: Extensions a -> [String]-extensionsOpts e = map (extensionFlag . showExtension) (_extensions e) ++ map unpack (_ghcOptions e)+{-# LANGUAGE OverloadedStrings, CPP #-}
+
+module HsDev.Project (
+	module HsDev.Project.Types,
+
+	infoSourceDirsDef, targetFiles, projectTargetFiles,
+	analyzeCabal,
+	readProject, loadProject,
+	withExtensions,
+	fileInTarget, fileTarget, fileTargets, findSourceDir, sourceDirs,
+	targetOpts,
+
+	-- * Helpers
+	showExtension, flagExtension, extensionFlag,
+	extensionsOpts
+	) where
+
+import Control.Arrow
+import Control.Lens hiding ((.=), (%=), (<.>), set')
+import Control.Monad.Except
+import Control.Monad.Loops
+import Data.List
+import Data.Maybe
+import Data.Text (Text, pack, unpack)
+import qualified Data.Text as T (intercalate)
+import Data.Text.Lens (unpacked)
+import Distribution.Compiler (CompilerFlavor(GHC))
+import qualified Distribution.Package as P
+import qualified Distribution.PackageDescription as PD
+import qualified Distribution.ModuleName as PD (toFilePath)
+import Distribution.PackageDescription.Parse
+import Distribution.ModuleName (components)
+import Distribution.Text (display)
+import Language.Haskell.Extension
+import System.FilePath
+import System.Log.Simple hiding (Level(..))
+import qualified System.Log.Simple as Log (Level(..))
+import Text.Format
+
+import System.Directory.Paths
+import HsDev.Project.Compat
+import HsDev.Project.Types
+import HsDev.Error
+import HsDev.Util
+
+-- | infoSourceDirs lens with default
+infoSourceDirsDef :: Lens' Info [Path]
+infoSourceDirsDef = lens get' set' where
+	get' i = case _infoSourceDirs i of
+		[] -> ["."]
+		dirs -> dirs
+	set' i ["."] = i { _infoSourceDirs = [] }
+	set' i dirs = i { _infoSourceDirs = dirs }
+
+-- | Get all source file names of target without prepending them with source-dirs
+targetFiles :: Target t => t -> [Path]
+targetFiles target' = concat [
+	maybeToList (targetMain target'),
+	map toFile $ targetModules target',
+	map toFile $ target' ^.. buildInfo . infoOtherModules . each]
+	where
+		toFile ps = fromFilePath (joinPath (ps ^.. each . unpacked) <.> "hs")
+
+-- | Get all source file names relative to project root
+projectTargetFiles :: (MonadLog m, Target t) => Project -> t -> m [Path]
+projectTargetFiles proj t = do
+	liftM concat $ forM files $ \file' -> do
+		candidate <- liftIO $ firstM (fileExists . absolutise (proj ^. projectPath)) [subPath srcDir file' | srcDir <- srcDirs]
+		case candidate of
+			Nothing -> do
+				sendLog Log.Warning $ "Unable to locate source file: {} in source-dirs: {}" ~~ file' ~~ (T.intercalate ", " srcDirs)
+				return []
+			Just file'' -> return [normPath file'']
+	where
+		files = targetFiles t
+		srcDirs = t ^.. buildInfo . infoSourceDirsDef . each
+
+-- | Analyze cabal file
+analyzeCabal :: String -> Either String ProjectDescription
+analyzeCabal source = case liftM flattenDescr $ parsePackageDesc source of
+	ParseOk _ r -> Right ProjectDescription {
+		_projectVersion = pack $ showVer $ P.pkgVersion $ PD.package r,
+		_projectLibrary = fmap toLibrary $ PD.library r,
+		_projectExecutables = fmap toExecutable $ PD.executables r,
+		_projectTests = fmap toTest $ PD.testSuites r }
+	ParseFailed e -> Left $ "Parse failed: " ++ show e
+	where
+		toLibrary lib = Library (map (map pack . components) $ PD.exposedModules lib) (toInfo $ PD.libBuildInfo lib)
+		toExecutable exe = Executable (componentName $ PD.exeName exe) (fromFilePath $ PD.modulePath exe) (toInfo $ PD.buildInfo exe)
+		toTest test = Test (componentName $ PD.testName test) (testSuiteEnabled test) (fmap fromFilePath mainFile) (toInfo $ PD.testBuildInfo test) where
+			mainFile = case PD.testInterface test of
+				PD.TestSuiteExeV10 _ fpath -> Just fpath
+				PD.TestSuiteLibV09 _ mname -> Just $ PD.toFilePath mname
+				_ -> Nothing
+		toInfo info = Info {
+			_infoDepends = map pkgName (PD.targetBuildDepends info),
+			_infoLanguage = PD.defaultLanguage info,
+			_infoExtensions = PD.defaultExtensions info ++ PD.otherExtensions info ++ PD.oldExtensions info,
+			_infoGHCOptions = maybe [] (map pack) $ lookup GHC (PD.options info),
+			_infoSourceDirs = map pack $ PD.hsSourceDirs info,
+			_infoOtherModules = map (map pack . components) (PD.otherModules info) }
+
+		pkgName :: P.Dependency -> Text
+		pkgName (P.Dependency dep _) = pack $ P.unPackageName dep
+
+		flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription
+		flattenDescr gpkg = pkg {
+			PD.library = flip fmap mlib $ flattenCondTree
+				(insertInfo PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })),
+			PD.executables = flip fmap mexes $
+				second (flattenCondTree (insertInfo PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>>
+				(\(n, e) -> e { PD.exeName = n }),
+			PD.testSuites = flip fmap mtests $
+				second (flattenCondTree (insertInfo PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>>
+				(\(n, t) -> t { PD.testName = n }) }
+			where
+				pkg = PD.packageDescription gpkg
+				mlib = PD.condLibrary gpkg
+				mexes = PD.condExecutables gpkg
+				mtests = PD.condTestSuites gpkg
+
+				insertInfo :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a
+				insertInfo f s deps' x = s ((f x) { PD.targetBuildDepends = deps' }) x
+
+-- | Read project info from .cabal
+readProject :: FilePath -> IO Project
+readProject file' = do
+	source <- readFile file'
+	length source `seq` either (hsdevError . InspectCabalError file') (return . mkProject) $ analyzeCabal source
+	where
+		mkProject desc = (project file') {
+			_projectDescription = Just desc }
+
+-- | Load project description
+loadProject :: Project -> IO Project
+loadProject p
+	| isJust (_projectDescription p) = return p
+	| otherwise = readProject (_projectCabal p ^. path)
+
+-- | Extensions for target
+withExtensions :: a -> Info -> Extensions a
+withExtensions x i = Extensions {
+	_extensions = _infoExtensions i,
+	_ghcOptions = _infoGHCOptions i,
+	_entity = x }
+
+-- | Check if source related to target, source must be relative to project directory
+fileInTarget :: Path -> Info -> Bool
+fileInTarget src info = any (`isParent` src) $ view infoSourceDirsDef info
+
+-- | Get first target for source file
+fileTarget :: Project -> Path -> Maybe Info
+fileTarget p f = listToMaybe $ fileTargets p f
+
+-- | Get possible targets for source file
+-- There can be many candidates in case of module related to several executables or tests
+fileTargets :: Project -> Path -> [Info]
+fileTargets p f = case filter ((`isParent` f') . view executablePath) exes of
+	[] -> filter (f' `fileInTarget`) (p ^.. projectDescription . _Just . infos)
+	exes' -> map _executableBuildInfo exes'
+	where
+		f' = relPathTo (_projectPath p) f
+		exes = p ^. projectDescription . _Just . projectExecutables
+
+-- | Finds source dir file belongs to
+findSourceDir :: Project -> Path -> Maybe (Extensions Path)
+findSourceDir p f = do
+	info <- listToMaybe $ fileTargets p f
+	fmap (`withExtensions` info) $ listToMaybe $ filter (`isParent` f) $ map (_projectPath p `subPath`) (info ^. infoSourceDirsDef)
+
+-- | Returns source dirs for library, executables and tests
+sourceDirs :: ProjectDescription -> [Extensions Path]
+sourceDirs = ordNub . concatMap dirs . toListOf infos where
+	dirs i = map (`withExtensions` i) (i ^. infoSourceDirsDef)
+
+-- | Get options for specific target
+targetOpts :: Info -> [String]
+targetOpts info' = concat [
+	["-i" ++ unpack s | s <- _infoSourceDirs info'],
+	extensionsOpts $ withExtensions () info',
+	["-package " ++ unpack p | p <- _infoDepends info']]
+
+-- | Extension as flag name
+showExtension :: Extension -> String
+showExtension = display
+
+-- | Convert -Xext to ext
+flagExtension :: String -> Maybe String
+flagExtension = stripPrefix "-X"
+
+-- | Convert ext to -Xext
+extensionFlag :: String -> String
+extensionFlag = ("-X" ++)
+
+-- | Extensions as opts to GHC
+extensionsOpts :: Extensions a -> [String]
+extensionsOpts e = map (extensionFlag . showExtension) (_extensions e) ++ map unpack (_ghcOptions e)
src/HsDev/Project/Compat.hs view
@@ -1,63 +1,63 @@-{-# LANGUAGE CPP #-}--module HsDev.Project.Compat (-	showVer, componentName, testSuiteEnabled,-	flattenCondTree,-	parsePackageDesc-	) where--import Data.Maybe (maybeToList)-import Data.Text (Text, pack)-import qualified Distribution.PackageDescription as PD-import Distribution.PackageDescription.Parse-import Distribution.Version (Version)-import Distribution.Text (display)-#if MIN_VERSION_Cabal(2,0,0)-import Distribution.Types.CondTree-#else -import Distribution.PackageDescription (CondTree(..))-#endif--#if MIN_VERSION_Cabal(2,0,0)-import Distribution.Types.UnqualComponentName-#else-import Data.Version (showVersion)-#endif--showVer :: Version -> String-#if MIN_VERSION_Cabal(2,0,0)-showVer = display-#else-showVer = showVersion-#endif--#if MIN_VERSION_Cabal(2,0,0)-componentName :: UnqualComponentName -> Text-componentName = pack . unUnqualComponentName-#else-componentName :: String -> Text-componentName = pack-#endif--testSuiteEnabled :: PD.TestSuite -> Bool-#if MIN_VERSION_Cabal(2,0,0)-testSuiteEnabled _ = True-#else-testSuiteEnabled = PD.testEnabled-#endif--flattenCondTree :: Monoid a => (c -> a -> a) -> CondTree v c a -> a-flattenCondTree f (PD.CondNode x cs cmps) = f cs x `mappend` mconcat (concatMap flattenBranch cmps) where-#if MIN_VERSION_Cabal(2,0,0)-	flattenBranch (CondBranch _ t mb) = go t mb-#else-	flattenBranch (_, t, mb) = go t mb-#endif-	go t mb = flattenCondTree f t : map (flattenCondTree f) (maybeToList mb)--parsePackageDesc :: String -> ParseResult PD.GenericPackageDescription-#if MIN_VERSION_Cabal(2,0,0)-parsePackageDesc = parseGenericPackageDescription-#else-parsePackageDesc = parsePackageDescription-#endif+{-# LANGUAGE CPP #-}
+
+module HsDev.Project.Compat (
+	showVer, componentName, testSuiteEnabled,
+	flattenCondTree,
+	parsePackageDesc
+	) where
+
+import Data.Maybe (maybeToList)
+import Data.Text (Text, pack)
+import qualified Distribution.PackageDescription as PD
+import Distribution.PackageDescription.Parse
+import Distribution.Version (Version)
+import Distribution.Text (display)
+#if MIN_VERSION_Cabal(2,0,0)
+import Distribution.Types.CondTree
+#else 
+import Distribution.PackageDescription (CondTree(..))
+#endif
+
+#if MIN_VERSION_Cabal(2,0,0)
+import Distribution.Types.UnqualComponentName
+#else
+import Data.Version (showVersion)
+#endif
+
+showVer :: Version -> String
+#if MIN_VERSION_Cabal(2,0,0)
+showVer = display
+#else
+showVer = showVersion
+#endif
+
+#if MIN_VERSION_Cabal(2,0,0)
+componentName :: UnqualComponentName -> Text
+componentName = pack . unUnqualComponentName
+#else
+componentName :: String -> Text
+componentName = pack
+#endif
+
+testSuiteEnabled :: PD.TestSuite -> Bool
+#if MIN_VERSION_Cabal(2,0,0)
+testSuiteEnabled _ = True
+#else
+testSuiteEnabled = PD.testEnabled
+#endif
+
+flattenCondTree :: Monoid a => (c -> a -> a) -> CondTree v c a -> a
+flattenCondTree f (PD.CondNode x cs cmps) = f cs x `mappend` mconcat (concatMap flattenBranch cmps) where
+#if MIN_VERSION_Cabal(2,0,0)
+	flattenBranch (CondBranch _ t mb) = go t mb
+#else
+	flattenBranch (_, t, mb) = go t mb
+#endif
+	go t mb = flattenCondTree f t : map (flattenCondTree f) (maybeToList mb)
+
+parsePackageDesc :: String -> ParseResult PD.GenericPackageDescription
+#if MIN_VERSION_Cabal(2,0,0)
+parsePackageDesc = parseGenericPackageDescription
+#else
+parsePackageDesc = parsePackageDescription
+#endif
src/HsDev/Project/Types.hs view
@@ -1,365 +1,366 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Project.Types (-	Project(..), projectName, projectPath, projectCabal, projectDescription, projectPackageDbStack, project,-	ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests, infos, targetInfos,-	Target(..), TargetInfo(..), targetInfoName, targetBuildInfo, targetInfoMain, targetInfoModules, targetInfo,-	Library(..), libraryModules, libraryBuildInfo,-	Executable(..), executableName, executablePath, executableBuildInfo,-	Test(..), testName, testEnabled, testBuildInfo, testMain,-	Info(..), infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs, infoOtherModules,-	Extensions(..), extensions, ghcOptions, entity,-	) where--import Control.DeepSeq (NFData(..))-import Control.Lens hiding ((.=), (<.>))-import Data.Aeson-import Data.Maybe-import Data.Monoid-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T-import qualified Distribution.Text as D (display)-import Language.Haskell.Extension-import System.FilePath-import Text.Format--import System.Directory.Paths-import HsDev.Display-import HsDev.PackageDb.Types-import HsDev.Util---- | Cabal project-data Project = Project {-	_projectName :: Text,-	_projectPath :: Path,-	_projectCabal :: Path,-	_projectDescription :: Maybe ProjectDescription,-	_projectPackageDbStack :: Maybe PackageDbStack }--instance NFData Project where-	rnf (Project n p c _ dbs) = rnf n `seq` rnf p `seq` rnf c `seq` rnf dbs--instance Eq Project where-	l == r = _projectCabal l == _projectCabal r--instance Ord Project where-	compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r)--instance Show Project where-	show p = unlines $ [-		"project " ++ _projectName p ^. path,-		"\tcabal: " ++ _projectCabal p ^. path,-		"\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p)--instance Display Project where-	display = T.unpack . _projectName-	displayType _ = "project"--instance Formattable Project where-	formattable = formattable . display--instance ToJSON Project where-	toJSON p = object [-		"name" .= _projectName p,-		"path" .= _projectPath p,-		"cabal" .= _projectCabal p,-		"description" .= _projectDescription p,-		"package-db-stack" .= _projectPackageDbStack p]--instance FromJSON Project where-	parseJSON = withObject "project" $ \v -> Project <$>-		v .:: "name" <*>-		v .:: "path" <*>-		v .:: "cabal" <*>-		v .:: "description" <*>-		v .:: "package-db-stack"--instance Paths Project where-	paths f (Project nm p c desc dbs) = Project nm <$> paths f p <*> paths f c <*> traverse (paths f) desc <*> pure dbs---- | Make project by .cabal file-project :: FilePath -> Project-project file = Project {-	_projectName = fromFilePath . takeBaseName . takeDirectory $ cabal,-	_projectPath = fromFilePath . takeDirectory $ cabal,-	_projectCabal = fromFilePath cabal,-	_projectDescription = Nothing,-	_projectPackageDbStack = Nothing }-	where-		file' = dropTrailingPathSeparator $ normalise file-		cabal-			| takeExtension file' == ".cabal" = file'-			| otherwise = file' </> (takeBaseName file' <.> "cabal")--data ProjectDescription = ProjectDescription {-	_projectVersion :: Text,-	_projectLibrary :: Maybe Library,-	_projectExecutables :: [Executable],-	_projectTests :: [Test] }-		deriving (Eq, Read)---- | Build target infos-infos :: Traversal' ProjectDescription Info-infos f desc = (\lib exes tests -> desc { _projectLibrary = lib, _projectExecutables = exes, _projectTests = tests }) <$>-	(_Just . buildInfo) f (_projectLibrary desc) <*>-	(each . buildInfo) f (_projectExecutables desc) <*>-	(each . buildInfo) f (_projectTests desc)---- | Build target infos, more detailed-targetInfos :: ProjectDescription -> [TargetInfo]-targetInfos desc = concat [-	map targetInfo $ maybeToList (_projectLibrary desc),-	map targetInfo $ _projectExecutables desc,-	map targetInfo $ _projectTests desc]--instance Show ProjectDescription where-	show pd = unlines $-		concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++-		concatMap (lines . show) (_projectExecutables pd) ++-		concatMap (lines . show) (_projectTests pd)--instance ToJSON ProjectDescription where-	toJSON d = object [-		"version" .= _projectVersion d,-		"library" .= _projectLibrary d,-		"executables" .= _projectExecutables d,-		"tests" .= _projectTests d]--instance FromJSON ProjectDescription where-	parseJSON = withObject "project description" $ \v -> ProjectDescription <$>-		v .:: "version" <*>-		v .:: "library" <*>-		v .:: "executables" <*>-		v .:: "tests"--instance Paths ProjectDescription where-	paths f (ProjectDescription v lib exes tests) = ProjectDescription v <$> traverse (paths f) lib <*> traverse (paths f) exes <*> traverse (paths f) tests--class Target a where-	targetName :: Traversal' a Text-	buildInfo :: Lens' a Info-	targetMain :: a -> Maybe Path-	targetModules :: a -> [[Text]]--data TargetInfo = TargetInfo {-	_targetInfoName :: Maybe Text,-	_targetBuildInfo :: Info,-	_targetInfoMain :: Maybe Path,-	_targetInfoModules :: [[Text]] }-		deriving (Eq, Ord, Show)--targetInfo :: Target a => a -> TargetInfo-targetInfo t = TargetInfo (t ^? targetName) (t ^. buildInfo) (targetMain t) (targetModules t)--instance Paths TargetInfo where-	paths f (TargetInfo n i mp ms) = TargetInfo n <$> paths f i <*> traverse (paths f) mp <*> pure ms---- | Library in project-data Library = Library {-	_libraryModules :: [[Text]],-	_libraryBuildInfo :: Info }-		deriving (Eq, Read)--instance Show Library where-	show l = unlines $-		["library", "\tmodules:"] ++-		(map (tab 2 . T.unpack . T.intercalate ".") $ _libraryModules l) ++-		(map (tab 1) . lines . show $ _libraryBuildInfo l)--instance ToJSON Library where-	toJSON l = object [-		"modules" .= fmap (T.intercalate ".") (_libraryModules l),-		"info" .= _libraryBuildInfo l]--instance FromJSON Library where-	parseJSON = withObject "library" $ \v -> Library <$> (fmap (T.split (== '.')) <$> v .:: "modules") <*> v .:: "info"--instance Paths Library where-	paths f (Library ms info) = Library ms <$> paths f info---- | Executable-data Executable = Executable {-	_executableName :: Text,-	_executablePath :: Path,-	_executableBuildInfo :: Info }-		deriving (Eq, Read)--instance Show Executable where-	show e = unlines $-		["executable " ++ T.unpack (_executableName e), "\tpath: " ++ (_executablePath e ^. path)] ++-		(map (tab 1) . lines . show $ _executableBuildInfo e)--instance ToJSON Executable where-	toJSON e = object [-		"name" .= _executableName e,-		"path" .= _executablePath e,-		"info" .= _executableBuildInfo e]--instance FromJSON Executable where-	parseJSON = withObject "executable" $ \v -> Executable <$>-		v .:: "name" <*>-		v .:: "path" <*>-		v .:: "info"--instance Paths Executable where-	paths f (Executable n p info) = Executable n <$> paths f p <*> paths f info---- | Test-data Test = Test {-	_testName :: Text,-	_testEnabled :: Bool,-	_testMain :: Maybe Path,-	_testBuildInfo :: Info }-		deriving (Eq, Read)--instance Show Test where-	show t = unlines $-		["test " ++ T.unpack (_testName t), "\tenabled: " ++ show (_testEnabled t)] ++-		maybe [] (\f -> ["\tmain-is: " ++ f ^. path]) (_testMain t) ++-		(map (tab 1) . lines . show $ _testBuildInfo t)--instance ToJSON Test where-	toJSON t = object [-		"name" .= _testName t,-		"enabled" .= _testEnabled t,-		"main" .= _testMain t,-		"info" .= _testBuildInfo t]--instance FromJSON Test where-	parseJSON = withObject "test" $ \v -> Test <$>-		v .:: "name" <*>-		v .:: "enabled" <*>-		v .::? "main" <*>-		v .:: "info"--instance Paths Test where-	paths f (Test n e m info) = Test n e <$> traverse (paths f) m <*> paths f info---- | Build info-data Info = Info {-	_infoDepends :: [Text],-	_infoLanguage :: Maybe Language,-	_infoExtensions :: [Extension],-	_infoGHCOptions :: [Text],-	_infoSourceDirs :: [Path],-	_infoOtherModules :: [[Text]] }-		deriving (Eq, Read)--instance Monoid Info where-	mempty = Info [] Nothing [] [] [] []-	mappend l r = Info-		(ordNub $ _infoDepends l ++ _infoDepends r)-		(getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r))-		(_infoExtensions l ++ _infoExtensions r)-		(_infoGHCOptions l ++ _infoGHCOptions r)-		(ordNub $ _infoSourceDirs l ++ _infoSourceDirs r)-		(ordNub $ _infoOtherModules l ++ _infoOtherModules r)--instance Ord Info where-	compare l r = compare (_infoSourceDirs l, _infoDepends l, _infoGHCOptions l) (_infoSourceDirs r, _infoDepends r, _infoGHCOptions r)--instance Show Info where-	show i = unlines $ lang ++ exts ++ opts ++ sources ++ otherMods where-		lang = maybe [] (\l -> ["default-language: " ++ D.display l]) $ _infoLanguage i-		exts-			| null (_infoExtensions i) = []-			| otherwise = "extensions:" : map (tab 1 . D.display) (_infoExtensions i)-		opts-			| null (_infoGHCOptions i) = []-			| otherwise = "ghc-options:" : map (tab 1 . T.unpack) (_infoGHCOptions i)-		sources = "source-dirs:" : map (tab 1 . T.unpack) (_infoSourceDirs i)-		otherMods = "other-modules:" : (map (tab 1 . T.unpack) . fmap (T.intercalate ".") $ _infoOtherModules i)--instance ToJSON Info where-	toJSON i = object [-		"build-depends" .= _infoDepends i,-		"language" .= _infoLanguage i,-		"extensions" .= _infoExtensions i,-		"ghc-options" .= _infoGHCOptions i,-		"source-dirs" .= _infoSourceDirs i,-		"other-modules" .= _infoOtherModules i]--instance FromJSON Info where-	parseJSON = withObject "info" $ \v -> Info <$>-		v .: "build-depends" <*>-		v .:: "language" <*>-		v .:: "extensions" <*>-		v .:: "ghc-options" <*>-		v .:: "source-dirs" <*>-		v .:: "other-modules"--instance ToJSON Language where-	toJSON = toJSON . D.display--instance FromJSON Language where-	parseJSON = withText "language" $ \txt -> parseDT "Language" (T.unpack txt)--instance ToJSON Extension where-	toJSON = toJSON . D.display--instance FromJSON Extension where-	parseJSON = withText "extension" $ \txt -> parseDT "Extension" (T.unpack txt)--instance Paths Info where-	paths f (Info deps lang exts opts dirs omods) = Info deps lang exts opts <$> traverse (paths f) dirs <*> pure omods---- | Entity with project extensions-data Extensions a = Extensions {-	_extensions :: [Extension],-	_ghcOptions :: [Text],-	_entity :: a }-		deriving (Eq, Read, Show)--instance Ord a => Ord (Extensions a) where-	compare = comparing _entity--instance Functor Extensions where-	fmap f (Extensions e o x) = Extensions e o (f x)--instance Applicative Extensions where-	pure = Extensions [] []-	(Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x)--instance Foldable Extensions where-	foldMap f (Extensions _ _ x) = f x--instance Traversable Extensions where-	traverse f (Extensions e o x) = Extensions e o <$> f x--makeLenses ''Project-makeLenses ''ProjectDescription-makeLenses ''TargetInfo-makeLenses ''Library-makeLenses ''Executable-makeLenses ''Test-makeLenses ''Info-makeLenses ''Extensions--instance Target Library where-	targetName _ = pure-	buildInfo = libraryBuildInfo-	targetMain _ = Nothing-	targetModules lib' = lib' ^.. libraryModules . each--instance Target Executable where-	targetName = executableName-	buildInfo = executableBuildInfo-	targetMain exe' = Just $ exe' ^. executablePath-	targetModules _ = []--instance Target Test where-	targetName = testName-	buildInfo = testBuildInfo-	targetMain test' = fmap toPath (test' ^? testMain . _Just . path) where-		toPath f-			| haskellSource f = fromFilePath f-			| otherwise = fromFilePath (f <.> "hs")-	targetModules _ = []--instance Target TargetInfo where-	targetName = targetInfoName . _Just-	buildInfo = targetBuildInfo-	targetMain = _targetInfoMain-	targetModules = _targetInfoModules+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Project.Types (
+	Project(..), projectName, projectPath, projectCabal, projectDescription, projectPackageDbStack, project,
+	ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests, infos, targetInfos,
+	Target(..), TargetInfo(..), targetInfoName, targetBuildInfo, targetInfoMain, targetInfoModules, targetInfo,
+	Library(..), libraryModules, libraryBuildInfo,
+	Executable(..), executableName, executablePath, executableBuildInfo,
+	Test(..), testName, testEnabled, testBuildInfo, testMain,
+	Info(..), infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs, infoOtherModules,
+	Extensions(..), extensions, ghcOptions, entity,
+	) where
+
+import Control.DeepSeq (NFData(..))
+import Control.Lens hiding ((.=), (<.>))
+import Data.Aeson
+import Data.Maybe
+import Data.Monoid
+import Data.Ord
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Distribution.Text as D (display)
+import Language.Haskell.Extension
+import System.FilePath
+import Text.Format
+
+import System.Directory.Paths
+import HsDev.Display
+import HsDev.PackageDb.Types
+import HsDev.Util
+
+-- | Cabal project
+data Project = Project {
+	_projectName :: Text,
+	_projectPath :: Path,
+	_projectCabal :: Path,
+	_projectDescription :: Maybe ProjectDescription,
+	_projectPackageDbStack :: Maybe PackageDbStack }
+
+instance NFData Project where
+	rnf (Project n p c _ dbs) = rnf n `seq` rnf p `seq` rnf c `seq` rnf dbs
+
+instance Eq Project where
+	l == r = _projectCabal l == _projectCabal r
+
+instance Ord Project where
+	compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r)
+
+instance Show Project where
+	show p = unlines $ [
+		"project " ++ _projectName p ^. path,
+		"\tcabal: " ++ _projectCabal p ^. path,
+		"\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p)
+
+instance Display Project where
+	display = T.unpack . _projectName
+	displayType _ = "project"
+
+instance Formattable Project where
+	formattable = formattable . display
+
+instance ToJSON Project where
+	toJSON p = object [
+		"name" .= _projectName p,
+		"path" .= _projectPath p,
+		"cabal" .= _projectCabal p,
+		"description" .= _projectDescription p,
+		"package-db-stack" .= _projectPackageDbStack p]
+
+instance FromJSON Project where
+	parseJSON = withObject "project" $ \v -> Project <$>
+		v .:: "name" <*>
+		v .:: "path" <*>
+		v .:: "cabal" <*>
+		v .:: "description" <*>
+		v .:: "package-db-stack"
+
+instance Paths Project where
+	paths f (Project nm p c desc dbs) = Project nm <$> paths f p <*> paths f c <*> traverse (paths f) desc <*> pure dbs
+
+-- | Make project by .cabal file
+project :: FilePath -> Project
+project file = Project {
+	-- Should not be the directory of the cabal, s/b the base name of the cabal file.
+	_projectName = fromFilePath . dropExtension . takeBaseName $ cabal,
+	_projectPath = fromFilePath . takeDirectory $ cabal,
+	_projectCabal = fromFilePath cabal,
+	_projectDescription = Nothing,
+	_projectPackageDbStack = Nothing }
+	where
+		file' = dropTrailingPathSeparator $ normalise file
+		cabal
+			| takeExtension file' == ".cabal" = file'
+			| otherwise = file' </> (takeBaseName file' <.> "cabal")
+
+data ProjectDescription = ProjectDescription {
+	_projectVersion :: Text,
+	_projectLibrary :: Maybe Library,
+	_projectExecutables :: [Executable],
+	_projectTests :: [Test] }
+		deriving (Eq, Read)
+
+-- | Build target infos
+infos :: Traversal' ProjectDescription Info
+infos f desc = (\lib exes tests -> desc { _projectLibrary = lib, _projectExecutables = exes, _projectTests = tests }) <$>
+	(_Just . buildInfo) f (_projectLibrary desc) <*>
+	(each . buildInfo) f (_projectExecutables desc) <*>
+	(each . buildInfo) f (_projectTests desc)
+
+-- | Build target infos, more detailed
+targetInfos :: ProjectDescription -> [TargetInfo]
+targetInfos desc = concat [
+	map targetInfo $ maybeToList (_projectLibrary desc),
+	map targetInfo $ _projectExecutables desc,
+	map targetInfo $ _projectTests desc]
+
+instance Show ProjectDescription where
+	show pd = unlines $
+		concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++
+		concatMap (lines . show) (_projectExecutables pd) ++
+		concatMap (lines . show) (_projectTests pd)
+
+instance ToJSON ProjectDescription where
+	toJSON d = object [
+		"version" .= _projectVersion d,
+		"library" .= _projectLibrary d,
+		"executables" .= _projectExecutables d,
+		"tests" .= _projectTests d]
+
+instance FromJSON ProjectDescription where
+	parseJSON = withObject "project description" $ \v -> ProjectDescription <$>
+		v .:: "version" <*>
+		v .:: "library" <*>
+		v .:: "executables" <*>
+		v .:: "tests"
+
+instance Paths ProjectDescription where
+	paths f (ProjectDescription v lib exes tests) = ProjectDescription v <$> traverse (paths f) lib <*> traverse (paths f) exes <*> traverse (paths f) tests
+
+class Target a where
+	targetName :: Traversal' a Text
+	buildInfo :: Lens' a Info
+	targetMain :: a -> Maybe Path
+	targetModules :: a -> [[Text]]
+
+data TargetInfo = TargetInfo {
+	_targetInfoName :: Maybe Text,
+	_targetBuildInfo :: Info,
+	_targetInfoMain :: Maybe Path,
+	_targetInfoModules :: [[Text]] }
+		deriving (Eq, Ord, Show)
+
+targetInfo :: Target a => a -> TargetInfo
+targetInfo t = TargetInfo (t ^? targetName) (t ^. buildInfo) (targetMain t) (targetModules t)
+
+instance Paths TargetInfo where
+	paths f (TargetInfo n i mp ms) = TargetInfo n <$> paths f i <*> traverse (paths f) mp <*> pure ms
+
+-- | Library in project
+data Library = Library {
+	_libraryModules :: [[Text]],
+	_libraryBuildInfo :: Info }
+		deriving (Eq, Read)
+
+instance Show Library where
+	show l = unlines $
+		["library", "\tmodules:"] ++
+		(map (tab 2 . T.unpack . T.intercalate ".") $ _libraryModules l) ++
+		(map (tab 1) . lines . show $ _libraryBuildInfo l)
+
+instance ToJSON Library where
+	toJSON l = object [
+		"modules" .= fmap (T.intercalate ".") (_libraryModules l),
+		"info" .= _libraryBuildInfo l]
+
+instance FromJSON Library where
+	parseJSON = withObject "library" $ \v -> Library <$> (fmap (T.split (== '.')) <$> v .:: "modules") <*> v .:: "info"
+
+instance Paths Library where
+	paths f (Library ms info) = Library ms <$> paths f info
+
+-- | Executable
+data Executable = Executable {
+	_executableName :: Text,
+	_executablePath :: Path,
+	_executableBuildInfo :: Info }
+		deriving (Eq, Read)
+
+instance Show Executable where
+	show e = unlines $
+		["executable " ++ T.unpack (_executableName e), "\tpath: " ++ (_executablePath e ^. path)] ++
+		(map (tab 1) . lines . show $ _executableBuildInfo e)
+
+instance ToJSON Executable where
+	toJSON e = object [
+		"name" .= _executableName e,
+		"path" .= _executablePath e,
+		"info" .= _executableBuildInfo e]
+
+instance FromJSON Executable where
+	parseJSON = withObject "executable" $ \v -> Executable <$>
+		v .:: "name" <*>
+		v .:: "path" <*>
+		v .:: "info"
+
+instance Paths Executable where
+	paths f (Executable n p info) = Executable n <$> paths f p <*> paths f info
+
+-- | Test
+data Test = Test {
+	_testName :: Text,
+	_testEnabled :: Bool,
+	_testMain :: Maybe Path,
+	_testBuildInfo :: Info }
+		deriving (Eq, Read)
+
+instance Show Test where
+	show t = unlines $
+		["test " ++ T.unpack (_testName t), "\tenabled: " ++ show (_testEnabled t)] ++
+		maybe [] (\f -> ["\tmain-is: " ++ f ^. path]) (_testMain t) ++
+		(map (tab 1) . lines . show $ _testBuildInfo t)
+
+instance ToJSON Test where
+	toJSON t = object [
+		"name" .= _testName t,
+		"enabled" .= _testEnabled t,
+		"main" .= _testMain t,
+		"info" .= _testBuildInfo t]
+
+instance FromJSON Test where
+	parseJSON = withObject "test" $ \v -> Test <$>
+		v .:: "name" <*>
+		v .:: "enabled" <*>
+		v .::? "main" <*>
+		v .:: "info"
+
+instance Paths Test where
+	paths f (Test n e m info) = Test n e <$> traverse (paths f) m <*> paths f info
+
+-- | Build info
+data Info = Info {
+	_infoDepends :: [Text],
+	_infoLanguage :: Maybe Language,
+	_infoExtensions :: [Extension],
+	_infoGHCOptions :: [Text],
+	_infoSourceDirs :: [Path],
+	_infoOtherModules :: [[Text]] }
+		deriving (Eq, Read)
+
+instance Monoid Info where
+	mempty = Info [] Nothing [] [] [] []
+	mappend l r = Info
+		(ordNub $ _infoDepends l ++ _infoDepends r)
+		(getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r))
+		(_infoExtensions l ++ _infoExtensions r)
+		(_infoGHCOptions l ++ _infoGHCOptions r)
+		(ordNub $ _infoSourceDirs l ++ _infoSourceDirs r)
+		(ordNub $ _infoOtherModules l ++ _infoOtherModules r)
+
+instance Ord Info where
+	compare l r = compare (_infoSourceDirs l, _infoDepends l, _infoGHCOptions l) (_infoSourceDirs r, _infoDepends r, _infoGHCOptions r)
+
+instance Show Info where
+	show i = unlines $ lang ++ exts ++ opts ++ sources ++ otherMods where
+		lang = maybe [] (\l -> ["default-language: " ++ D.display l]) $ _infoLanguage i
+		exts
+			| null (_infoExtensions i) = []
+			| otherwise = "extensions:" : map (tab 1 . D.display) (_infoExtensions i)
+		opts
+			| null (_infoGHCOptions i) = []
+			| otherwise = "ghc-options:" : map (tab 1 . T.unpack) (_infoGHCOptions i)
+		sources = "source-dirs:" : map (tab 1 . T.unpack) (_infoSourceDirs i)
+		otherMods = "other-modules:" : (map (tab 1 . T.unpack) . fmap (T.intercalate ".") $ _infoOtherModules i)
+
+instance ToJSON Info where
+	toJSON i = object [
+		"build-depends" .= _infoDepends i,
+		"language" .= _infoLanguage i,
+		"extensions" .= _infoExtensions i,
+		"ghc-options" .= _infoGHCOptions i,
+		"source-dirs" .= _infoSourceDirs i,
+		"other-modules" .= _infoOtherModules i]
+
+instance FromJSON Info where
+	parseJSON = withObject "info" $ \v -> Info <$>
+		v .: "build-depends" <*>
+		v .:: "language" <*>
+		v .:: "extensions" <*>
+		v .:: "ghc-options" <*>
+		v .:: "source-dirs" <*>
+		v .:: "other-modules"
+
+instance ToJSON Language where
+	toJSON = toJSON . D.display
+
+instance FromJSON Language where
+	parseJSON = withText "language" $ \txt -> parseDT "Language" (T.unpack txt)
+
+instance ToJSON Extension where
+	toJSON = toJSON . D.display
+
+instance FromJSON Extension where
+	parseJSON = withText "extension" $ \txt -> parseDT "Extension" (T.unpack txt)
+
+instance Paths Info where
+	paths f (Info deps lang exts opts dirs omods) = Info deps lang exts opts <$> traverse (paths f) dirs <*> pure omods
+
+-- | Entity with project extensions
+data Extensions a = Extensions {
+	_extensions :: [Extension],
+	_ghcOptions :: [Text],
+	_entity :: a }
+		deriving (Eq, Read, Show)
+
+instance Ord a => Ord (Extensions a) where
+	compare = comparing _entity
+
+instance Functor Extensions where
+	fmap f (Extensions e o x) = Extensions e o (f x)
+
+instance Applicative Extensions where
+	pure = Extensions [] []
+	(Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x)
+
+instance Foldable Extensions where
+	foldMap f (Extensions _ _ x) = f x
+
+instance Traversable Extensions where
+	traverse f (Extensions e o x) = Extensions e o <$> f x
+
+makeLenses ''Project
+makeLenses ''ProjectDescription
+makeLenses ''TargetInfo
+makeLenses ''Library
+makeLenses ''Executable
+makeLenses ''Test
+makeLenses ''Info
+makeLenses ''Extensions
+
+instance Target Library where
+	targetName _ = pure
+	buildInfo = libraryBuildInfo
+	targetMain _ = Nothing
+	targetModules lib' = lib' ^.. libraryModules . each
+
+instance Target Executable where
+	targetName = executableName
+	buildInfo = executableBuildInfo
+	targetMain exe' = Just $ exe' ^. executablePath
+	targetModules _ = []
+
+instance Target Test where
+	targetName = testName
+	buildInfo = testBuildInfo
+	targetMain test' = fmap toPath (test' ^? testMain . _Just . path) where
+		toPath f
+			| haskellSource f = fromFilePath f
+			| otherwise = fromFilePath (f <.> "hs")
+	targetModules _ = []
+
+instance Target TargetInfo where
+	targetName = targetInfoName . _Just
+	buildInfo = targetBuildInfo
+	targetMain = _targetInfoMain
+	targetModules = _targetInfoModules
src/HsDev/Sandbox.hs view
@@ -1,195 +1,195 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}--module HsDev.Sandbox (-	SandboxType(..), Sandbox(..), sandboxType, sandbox,-	isSandbox, guessSandboxType, sandboxFromPath,-	findSandbox, searchSandbox, projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack,--	-- * package-db-	userPackageDb,--	-- * cabal-sandbox util-	cabalSandboxPackageDb,--	getModuleOpts, getProjectTargetOpts,--	getProjectSandbox,-	getProjectPackageDbStack-	) where--import Control.Applicative-import Control.DeepSeq (NFData(..))-import Control.Monad-import Control.Monad.Trans.Maybe-import Control.Monad.Except-import Control.Lens (view, makeLenses)-import Data.Aeson-import Data.List (find, intercalate)-import Data.Maybe (isJust, fromMaybe)-import Data.Maybe.JustIf-import qualified Data.Text as T (unpack)-import System.Directory (getAppUserDataDirectory, doesDirectoryExist)-import System.FilePath-import System.Log.Simple (MonadLog(..))-import Text.Format--import System.Directory.Paths-import HsDev.Display-import HsDev.Error-import HsDev.PackageDb-import HsDev.Project.Types-import HsDev.Scan.Browse (browsePackages)-import HsDev.Stack hiding (path)-import HsDev.Symbols (moduleOpts, projectTargetOpts)-import HsDev.Symbols.Types (moduleId, Module(..), ModuleLocation(..), moduleLocation)-import HsDev.Tools.Ghc.Worker (GhcM)-import HsDev.Tools.Ghc.System (buildPath)-import HsDev.Util (searchPath, directoryContents, cabalFile)--data SandboxType = CabalSandbox | StackWork deriving (Eq, Ord, Read, Show, Enum, Bounded)--data Sandbox = Sandbox { _sandboxType :: SandboxType, _sandbox :: Path } deriving (Eq, Ord)--makeLenses ''Sandbox--instance NFData SandboxType where-	rnf CabalSandbox = ()-	rnf StackWork = ()--instance NFData Sandbox where-	rnf (Sandbox t p) = rnf t `seq` rnf p--instance Show Sandbox where-	show (Sandbox _ p) = T.unpack p--instance Display Sandbox where-	display (Sandbox _ fpath) = display fpath-	displayType (Sandbox CabalSandbox _) = "cabal-sandbox"-	displayType (Sandbox StackWork _) = "stack-work"--instance Formattable Sandbox where-	formattable = formattable . display--instance ToJSON Sandbox where-	toJSON (Sandbox _ p) = toJSON p--instance FromJSON Sandbox where-	parseJSON = withText "sandbox" sandboxPath where-		sandboxPath = maybe (fail "Not a sandbox") return . sandboxFromPath--instance Paths Sandbox where-	paths f (Sandbox st p) = Sandbox st <$> paths f p--isSandbox :: Path -> Bool-isSandbox = isJust . guessSandboxType--guessSandboxType :: Path -> Maybe SandboxType-guessSandboxType fpath-	| takeFileName (view path fpath) == ".cabal-sandbox" = Just CabalSandbox-	| takeFileName (view path fpath) == ".stack-work" = Just StackWork-	| otherwise = Nothing--sandboxFromPath :: Path -> Maybe Sandbox-sandboxFromPath fpath = Sandbox <$> guessSandboxType fpath <*> pure fpath---- | Find sandbox in path-findSandbox :: Path -> IO (Maybe Sandbox)-findSandbox fpath = do-	fpath' <- canonicalize fpath-	isDir <- dirExists fpath'-	if isDir-		then do-			dirs <- liftM ((fpath' :) . map fromFilePath) $ directoryContents (view path fpath')-			return $ msum $ map sandboxFromDir dirs-		else return Nothing-	where-		sandboxFromDir :: Path -> Maybe Sandbox-		sandboxFromDir fdir-			| takeFileName (view path fdir) == "stack.yaml" = sandboxFromPath (fromFilePath (takeDirectory (view path fdir) </> ".stack-work"))-			| otherwise = sandboxFromPath fdir---- | Search sandbox by parent directory-searchSandbox :: Path -> IO (Maybe Sandbox)-searchSandbox p = runMaybeT $ searchPath (view path p) (MaybeT . findSandbox . fromFilePath)---- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents-projectSandbox :: Path -> IO (Maybe Sandbox)-projectSandbox fpath = runMaybeT $ do-	p <- searchPath (view path fpath) (MaybeT . getCabalFile)-	MaybeT (findSandbox $ fromFilePath p) <|> searchPath p (MaybeT . findSbox')-	where-		getCabalFile = directoryContents >=> return . find cabalFile-		findSbox' = directoryContents >=> return . msum . map (sandboxFromPath . fromFilePath)---- | Get package-db stack for sandbox-sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack-sandboxPackageDbStack (Sandbox CabalSandbox fpath) = do-	dir <- cabalSandboxPackageDb $ view path fpath-	return $ PackageDbStack [PackageDb $ fromFilePath dir]-sandboxPackageDbStack (Sandbox StackWork fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory (view path fpath)---- | Search package-db stack with user-db as default-searchPackageDbStack :: Path -> GhcM PackageDbStack-searchPackageDbStack p = do-	mbox <- liftIO $ projectSandbox p-	case mbox of-		Nothing -> return userDb-		Just sbox -> sandboxPackageDbStack sbox---- | Restore package-db stack by package-db-restorePackageDbStack :: PackageDb -> GhcM PackageDbStack-restorePackageDbStack GlobalDb = return globalDb-restorePackageDbStack UserDb = return userDb-restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDbs [p]) $ runMaybeT $ do-	sbox <- MaybeT $ liftIO $ searchSandbox p-	lift $ sandboxPackageDbStack sbox---- | User package-db: <arch>-<os>-<version>-userPackageDb :: GhcM FilePath-userPackageDb = do-	root <- liftIO $ getAppUserDataDirectory "ghc"-	dir <- buildPath "{arch}-{os}-{version}"-	return $ root </> dir---- | Get sandbox package-db: <arch>-<os>-<compiler>-<version>-packages.conf.d-cabalSandboxPackageDb :: FilePath -> GhcM FilePath-cabalSandboxPackageDb root = do-	dirs <- mapM (fmap (root </>) . buildPath) [-		"{arch}-{os}-{compiler}-{version}-packages.conf.d",-		"{arch}-{os/cabal}-{compiler}-{version}-packages.conf.d"]-	mdir <- liftM msum $ forM dirs $ \dir -> do-		justIf dir <$> liftIO (doesDirectoryExist dir)-	case mdir of-		Nothing -> hsdevError $ OtherError $ unlines [-			"No suitable package-db found in sandbox, is it configured?",-			"Searched in: {}" ~~ intercalate ", " dirs]-		Just dir -> return dir---- | Options for GHC for module and project-getModuleOpts :: [String] -> Module -> GhcM (PackageDbStack, [String])-getModuleOpts opts m = do-	pdbs <- case view (moduleId . moduleLocation) m of-		FileModule fpath _ -> searchPackageDbStack fpath-		InstalledModule{} -> return userDb-		_ -> return userDb-	pkgs <- browsePackages opts pdbs-	return $ (pdbs, concat [-		moduleOpts pkgs m,-		opts])---- | Options for GHC for project target-getProjectTargetOpts :: [String] -> Project -> Info -> GhcM (PackageDbStack, [String])-getProjectTargetOpts opts proj t = do-	pdbs <- searchPackageDbStack $ view projectPath proj-	pkgs <- browsePackages opts pdbs-	return $ (pdbs, concat [-		projectTargetOpts pkgs proj t,-		opts])---- | Get sandbox of project (if any)-getProjectSandbox :: MonadLog m => Project -> m (Maybe Sandbox)-getProjectSandbox = liftIO . projectSandbox . view projectPath---- | Get project package-db stack-getProjectPackageDbStack :: Project -> GhcM PackageDbStack-getProjectPackageDbStack = getProjectSandbox >=> maybe (return userDb) sandboxPackageDbStack+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+
+module HsDev.Sandbox (
+	SandboxType(..), Sandbox(..), sandboxType, sandbox,
+	isSandbox, guessSandboxType, sandboxFromPath,
+	findSandbox, searchSandbox, projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack,
+
+	-- * package-db
+	userPackageDb,
+
+	-- * cabal-sandbox util
+	cabalSandboxPackageDb,
+
+	getModuleOpts, getProjectTargetOpts,
+
+	getProjectSandbox,
+	getProjectPackageDbStack
+	) where
+
+import Control.Applicative
+import Control.DeepSeq (NFData(..))
+import Control.Monad
+import Control.Monad.Trans.Maybe
+import Control.Monad.Except
+import Control.Lens (view, makeLenses)
+import Data.Aeson
+import Data.List (find, intercalate)
+import Data.Maybe (isJust, fromMaybe)
+import Data.Maybe.JustIf
+import qualified Data.Text as T (unpack)
+import System.Directory (getAppUserDataDirectory, doesDirectoryExist)
+import System.FilePath
+import System.Log.Simple (MonadLog(..))
+import Text.Format
+
+import System.Directory.Paths
+import HsDev.Display
+import HsDev.Error
+import HsDev.PackageDb
+import HsDev.Project.Types
+import HsDev.Scan.Browse (browsePackages)
+import HsDev.Stack hiding (path)
+import HsDev.Symbols (moduleOpts, projectTargetOpts)
+import HsDev.Symbols.Types (moduleId, Module(..), ModuleLocation(..), moduleLocation)
+import HsDev.Tools.Ghc.Worker (GhcM)
+import HsDev.Tools.Ghc.System (buildPath)
+import HsDev.Util (searchPath, directoryContents, cabalFile)
+
+data SandboxType = CabalSandbox | StackWork deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+data Sandbox = Sandbox { _sandboxType :: SandboxType, _sandbox :: Path } deriving (Eq, Ord)
+
+makeLenses ''Sandbox
+
+instance NFData SandboxType where
+	rnf CabalSandbox = ()
+	rnf StackWork = ()
+
+instance NFData Sandbox where
+	rnf (Sandbox t p) = rnf t `seq` rnf p
+
+instance Show Sandbox where
+	show (Sandbox _ p) = T.unpack p
+
+instance Display Sandbox where
+	display (Sandbox _ fpath) = display fpath
+	displayType (Sandbox CabalSandbox _) = "cabal-sandbox"
+	displayType (Sandbox StackWork _) = "stack-work"
+
+instance Formattable Sandbox where
+	formattable = formattable . display
+
+instance ToJSON Sandbox where
+	toJSON (Sandbox _ p) = toJSON p
+
+instance FromJSON Sandbox where
+	parseJSON = withText "sandbox" sandboxPath where
+		sandboxPath = maybe (fail "Not a sandbox") return . sandboxFromPath
+
+instance Paths Sandbox where
+	paths f (Sandbox st p) = Sandbox st <$> paths f p
+
+isSandbox :: Path -> Bool
+isSandbox = isJust . guessSandboxType
+
+guessSandboxType :: Path -> Maybe SandboxType
+guessSandboxType fpath
+	| takeFileName (view path fpath) == ".cabal-sandbox" = Just CabalSandbox
+	| takeFileName (view path fpath) == ".stack-work" = Just StackWork
+	| otherwise = Nothing
+
+sandboxFromPath :: Path -> Maybe Sandbox
+sandboxFromPath fpath = Sandbox <$> guessSandboxType fpath <*> pure fpath
+
+-- | Find sandbox in path
+findSandbox :: Path -> IO (Maybe Sandbox)
+findSandbox fpath = do
+	fpath' <- canonicalize fpath
+	isDir <- dirExists fpath'
+	if isDir
+		then do
+			dirs <- liftM ((fpath' :) . map fromFilePath) $ directoryContents (view path fpath')
+			return $ msum $ map sandboxFromDir dirs
+		else return Nothing
+	where
+		sandboxFromDir :: Path -> Maybe Sandbox
+		sandboxFromDir fdir
+			| takeFileName (view path fdir) == "stack.yaml" = sandboxFromPath (fromFilePath (takeDirectory (view path fdir) </> ".stack-work"))
+			| otherwise = sandboxFromPath fdir
+
+-- | Search sandbox by parent directory
+searchSandbox :: Path -> IO (Maybe Sandbox)
+searchSandbox p = runMaybeT $ searchPath (view path p) (MaybeT . findSandbox . fromFilePath)
+
+-- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents
+projectSandbox :: Path -> IO (Maybe Sandbox)
+projectSandbox fpath = runMaybeT $ do
+	p <- searchPath (view path fpath) (MaybeT . getCabalFile)
+	MaybeT (findSandbox $ fromFilePath p) <|> searchPath p (MaybeT . findSbox')
+	where
+		getCabalFile = directoryContents >=> return . find cabalFile
+		findSbox' = directoryContents >=> return . msum . map (sandboxFromPath . fromFilePath)
+
+-- | Get package-db stack for sandbox
+sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack
+sandboxPackageDbStack (Sandbox CabalSandbox fpath) = do
+	dir <- cabalSandboxPackageDb $ view path fpath
+	return $ PackageDbStack [PackageDb $ fromFilePath dir]
+sandboxPackageDbStack (Sandbox StackWork fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory (view path fpath)
+
+-- | Search package-db stack with user-db as default
+searchPackageDbStack :: Path -> GhcM PackageDbStack
+searchPackageDbStack p = do
+	mbox <- liftIO $ projectSandbox p
+	case mbox of
+		Nothing -> return userDb
+		Just sbox -> sandboxPackageDbStack sbox
+
+-- | Restore package-db stack by package-db
+restorePackageDbStack :: PackageDb -> GhcM PackageDbStack
+restorePackageDbStack GlobalDb = return globalDb
+restorePackageDbStack UserDb = return userDb
+restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDbs [p]) $ runMaybeT $ do
+	sbox <- MaybeT $ liftIO $ searchSandbox p
+	lift $ sandboxPackageDbStack sbox
+
+-- | User package-db: <arch>-<os>-<version>
+userPackageDb :: GhcM FilePath
+userPackageDb = do
+	root <- liftIO $ getAppUserDataDirectory "ghc"
+	dir <- buildPath "{arch}-{os}-{version}"
+	return $ root </> dir
+
+-- | Get sandbox package-db: <arch>-<os>-<compiler>-<version>-packages.conf.d
+cabalSandboxPackageDb :: FilePath -> GhcM FilePath
+cabalSandboxPackageDb root = do
+	dirs <- mapM (fmap (root </>) . buildPath) [
+		"{arch}-{os}-{compiler}-{version}-packages.conf.d",
+		"{arch}-{os/cabal}-{compiler}-{version}-packages.conf.d"]
+	mdir <- liftM msum $ forM dirs $ \dir -> do
+		justIf dir <$> liftIO (doesDirectoryExist dir)
+	case mdir of
+		Nothing -> hsdevError $ OtherError $ unlines [
+			"No suitable package-db found in sandbox, is it configured?",
+			"Searched in: {}" ~~ intercalate ", " dirs]
+		Just dir -> return dir
+
+-- | Options for GHC for module and project
+getModuleOpts :: [String] -> Module -> GhcM (PackageDbStack, [String])
+getModuleOpts opts m = do
+	pdbs <- case view (moduleId . moduleLocation) m of
+		FileModule fpath _ -> searchPackageDbStack fpath
+		InstalledModule{} -> return userDb
+		_ -> return userDb
+	pkgs <- browsePackages opts pdbs
+	return $ (pdbs, concat [
+		moduleOpts pkgs m,
+		opts])
+
+-- | Options for GHC for project target
+getProjectTargetOpts :: [String] -> Project -> Info -> GhcM (PackageDbStack, [String])
+getProjectTargetOpts opts proj t = do
+	pdbs <- searchPackageDbStack $ view projectPath proj
+	pkgs <- browsePackages opts pdbs
+	return $ (pdbs, concat [
+		projectTargetOpts pkgs proj t,
+		opts])
+
+-- | Get sandbox of project (if any)
+getProjectSandbox :: MonadLog m => Project -> m (Maybe Sandbox)
+getProjectSandbox = liftIO . projectSandbox . view projectPath
+
+-- | Get project package-db stack
+getProjectPackageDbStack :: Project -> GhcM PackageDbStack
+getProjectPackageDbStack = getProjectSandbox >=> maybe (return userDb) sandboxPackageDbStack
src/HsDev/Scan.hs view
@@ -1,255 +1,255 @@-{-# LANGUAGE FlexibleInstances, TypeOperators, TypeApplications, OverloadedStrings #-}--module HsDev.Scan (-	-- * Enumerate functions-	CompileFlag, ModuleToScan, ProjectToScan, PackageDbToScan, ScanContents(..),-	EnumContents(..),-	enumRescan, enumDependent, enumProject, enumSandbox, enumDirectory,--	-- * Scan-	scanProjectFile,-	scanModify,-	upToDate, changedModules,-	getFileContents,--	-- * Reexportss-	module HsDev.Symbols.Types,-	module Control.Monad.Except,-	) where--import Control.DeepSeq-import Control.Lens-import Control.Monad.Except-import Data.Deps-import Data.Maybe (catMaybes, isJust, listToMaybe)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.List (intercalate)-import Data.Text (Text)-import Data.Text.Lens (unpacked)-import qualified Data.Text as T-import Data.Time.Clock.POSIX (POSIXTime)-import Data.Traversable (for)-import Data.String (IsString, fromString)-import qualified Data.Set as S-import System.Directory-import Text.Format-import qualified System.Log.Simple as Log--import HsDev.Error-import qualified HsDev.Database.SQLite as SQLite-import HsDev.Database.SQLite.Select-import HsDev.Scan.Browse (browsePackages)-import HsDev.Server.Types (FileSource(..), SessionMonad(..), CommandMonad(..), inSessionGhc, postSessionUpdater)-import HsDev.Sandbox-import HsDev.Symbols-import HsDev.Symbols.Types-import HsDev.Display-import HsDev.Inspect-import HsDev.Util-import System.Directory.Paths---- | Compile flags-type CompileFlag = String--- | Module with flags ready to scan-type ModuleToScan = (ModuleLocation, [CompileFlag], Maybe Text)--- | Project ready to scan-type ProjectToScan = (Project, [ModuleToScan])--- | Package-db sandbox to scan (top of stack)-type PackageDbToScan = PackageDbStack---- | Scan info-data ScanContents = ScanContents {-	modulesToScan :: [ModuleToScan],-	projectsToScan :: [ProjectToScan],-	sandboxesToScan :: [PackageDbStack] }--instance NFData ScanContents where-	rnf (ScanContents ms ps ss) = rnf ms `seq` rnf ps `seq` rnf ss--instance Monoid ScanContents where-	mempty = ScanContents [] [] []-	mappend (ScanContents lm lp ls) (ScanContents rm rp rs) = ScanContents-		(uniqueBy (view _1) $ lm ++ rm)-		(uniqueBy (view _1) $ lp ++ rp)-		(ordNub $ ls ++ rs)--instance Formattable ScanContents where-	formattable (ScanContents ms ps cs) = formattable str where-		str :: String-		str = format "modules: {}, projects: {}, package-dbs: {}"-			~~ (T.intercalate comma $ ms ^.. each . _1 . moduleFile)-			~~ (T.intercalate comma $ ps ^.. each . _1 . projectPath)-			~~ (intercalate comma $ map (display . topPackageDb) $ cs ^.. each)-		comma :: IsString s => s-		comma = fromString ", "--class EnumContents a where-	enumContents :: CommandMonad m => a -> m ScanContents--instance EnumContents ModuleLocation where-	enumContents mloc = return $ ScanContents [(mloc, [], Nothing)] [] []--instance EnumContents (Extensions ModuleLocation) where-	enumContents ex = return $ ScanContents [(view entity ex, extensionsOpts ex, Nothing)] [] []--instance EnumContents Project where-	enumContents = enumProject--instance EnumContents PackageDbStack where-	enumContents pdbs = return $ ScanContents [] [] (packageDbStacks pdbs)--instance EnumContents Sandbox where-	enumContents = enumSandbox--instance {-# OVERLAPPABLE #-} EnumContents a => EnumContents [a] where-	enumContents = liftM mconcat . tries . map enumContents--instance {-# OVERLAPPING #-} EnumContents FilePath where-	enumContents f-		| haskellSource f = hsdevLiftIO $ do-			mproj <- liftIO $ locateProject f-			case mproj of-				Nothing -> enumContents $ FileModule (fromFilePath f) Nothing-				Just proj -> do-					ScanContents _ [(_, mods)] _ <- enumContents proj-					return $ ScanContents (filter ((== Just f) . preview (_1 . moduleFile . path)) mods) [] []-		| otherwise = enumDirectory f--instance {-# OVERLAPPING #-} EnumContents Path where-	enumContents = enumContents . view path--instance EnumContents FileSource where-	enumContents (FileSource f mcts)-		| haskellSource (view path f) = do-			ScanContents [(m, opts, _)] _ _ <- enumContents f-			return $ ScanContents [(m, opts, mcts)] [] []-		| otherwise = return mempty---- | Enum rescannable (i.e. already scanned) file-enumRescan :: CommandMonad m => FilePath -> m ScanContents-enumRescan fpath = Log.scope "enum-rescan" $ do-	ms <- SQLite.query @_ @(ModuleLocation SQLite.:. Inspection)-		(toQuery $ mconcat [-			qModuleLocation "ml",-			select_ ["ml.inspection_time", "ml.inspection_opts"],-			where_ ["ml.file == ?"]])-		(SQLite.Only fpath)-	case ms of-		[] -> do-			Log.sendLog Log.Warning $ "file {} not found" ~~ fpath-			return mempty-		((mloc SQLite.:. insp):_) -> do-			when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath-			return $ ScanContents [(mloc, insp ^.. inspectionOpts . each . unpacked, Nothing)] [] []---- | Enum file dependent-enumDependent :: CommandMonad m => FilePath -> m ScanContents-enumDependent fpath = Log.scope "enum-dependent" $ do-	ms <- SQLite.query @_ @ModuleId-		(toQuery $ qModuleId `mappend` where_ ["mu.file == ?"]) (SQLite.Only fpath)-	case ms of-		[] -> do-			Log.sendLog Log.Warning $ "file {} not found" ~~ fpath-			return mempty-		(mid:_) -> do-			when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath-			let-				mcabal = mid ^? moduleLocation . moduleProject . _Just . projectCabal-			depList <- SQLite.query @_ @(Path, Path) "select d.module_file, d.depends_file from sources_depends as d, projects_modules_scope as ps where ps.cabal is ? and ps.module_id == d.module_id;"-				(SQLite.Only mcabal)-			let-				rdeps = inverse . either (const mempty) id . flatten . mconcat . map (uncurry dep) $ depList-				dependent = rdeps ^. ix (fromFilePath fpath)-			liftM mconcat $ mapM (enumRescan . view path) dependent---- | Enum project sources-enumProject :: CommandMonad m => Project -> m ScanContents-enumProject p = hsdevLiftIO $ do-	p' <- liftIO $ loadProject p-	pdbs <- inSessionGhc $ searchPackageDbStack (view projectPath p')-	pkgs <- inSessionGhc $ liftM (S.fromList . map (view (package . packageName))) $ browsePackages [] pdbs-	let-		projOpts :: Path -> [Text]-		projOpts f = map fromString $ concatMap makeOpts $ fileTargets p' f where-			makeOpts :: Info -> [String]-			makeOpts i = concat [-				["-hide-all-packages"],-				["-package " ++ view (projectName . path) p'],-				["-package " ++ T.unpack dep' | dep' <- view infoDepends i, dep' `S.member` pkgs]]-	srcs <- liftIO $ projectSources p'-	let-		mlocs = over each (\src -> over ghcOptions (++ projOpts (view entity src)) . over entity (\f -> FileModule f (Just p')) $ src) srcs-	mods <- liftM modulesToScan $ enumContents mlocs-	return $ ScanContents [] [(p', mods)] [] -- (sandboxCabals sboxes)---- | Enum sandbox-enumSandbox :: CommandMonad m => Sandbox -> m ScanContents-enumSandbox = (inSessionGhc . sandboxPackageDbStack) >=> enumContents---- | Enum directory modules-enumDirectory :: CommandMonad m => FilePath -> m ScanContents-enumDirectory dir = hsdevLiftIO $ do-	cts <- liftIO $ traverseDirectory dir-	let-		projects = filter cabalFile cts-		sources = filter haskellSource cts-	dirs <- liftIO $ filterM doesDirectoryExist cts-	sboxes <- liftM catMaybes $ triesMap (liftIO . findSandbox . fromFilePath) dirs-	pdbs <- mapM enumSandbox sboxes-	projs <- liftM mconcat $ triesMap (enumProject . project) projects-	let-		projPaths = map (view projectPath . fst) $ projectsToScan projs-		standalone = map (`FileModule` Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) $ map fromFilePath sources-	return $ mconcat [-		ScanContents [(s, [], Nothing) | s <- standalone] [] [],-		projs,-		mconcat pdbs]---- | Scan project file-scanProjectFile :: CommandMonad m => [String] -> Path -> m Project-scanProjectFile _ f = hsdevLiftIO $ do-	proj <- (liftIO $ locateProject (view path f)) >>= maybe (hsdevError $ FileNotFound f) return-	liftIO $ loadProject proj---- | Scan additional info and modify scanned module-scanModify :: CommandMonad m => ([String] -> Module -> m Module) -> InspectedModule -> m InspectedModule-scanModify f im = traverse f' im where-	f' m = f (toListOf (inspection . inspectionOpts . each . unpacked) im) m---- | Is inspected module up to date?-upToDate :: SessionMonad m => ModuleLocation -> [String] -> Inspection -> m Bool-upToDate mloc opts insp = do-	insp' <- liftIO $ moduleInspection mloc opts-	mfinsp <- fmap join $ for (mloc ^? moduleFile) $ \fpath -> do-		tm <- SQLite.query @_ @(SQLite.Only Double) "select mtime from file_contents where file = ?;" (SQLite.Only fpath)-		return $ fmap (fileContentsInspection_ opts . fromRational . toRational . SQLite.fromOnly) (listToMaybe tm)-	let-		lastInsp = maybe insp' (max insp') mfinsp-	return $ fresh insp lastInsp---- | Returns new (to scan) and changed (to rescan) modules-changedModules :: SessionMonad m => Map ModuleLocation Inspection -> [String] -> [ModuleToScan] -> m [ModuleToScan]-changedModules inspMap opts = filterM $ \m -> if isJust (m ^. _3)-	then return True-	else maybe-		(return True)-		(liftM not . upToDate (m ^. _1) (opts ++ (m ^. _2)))-		(M.lookup (m ^. _1) inspMap)---- | Returns file contents if it was set and still actual-getFileContents :: SessionMonad m => Path -> m (Maybe (POSIXTime, Text))-getFileContents fpath = do-	mcts <- SQLite.query @_ @(Double, Text) "select mtime, contents from file_contents where file = ?;" (SQLite.Only fpath)-	insp <- liftIO $ fileInspection fpath []-	case listToMaybe mcts of-		Nothing -> return Nothing-		Just (tm, cts) -> do-			let-				tm' = fromRational (toRational tm)-			fmtime <- maybe (hsdevError $ OtherError "impossible: inspection time not set after call to `fileInspection`") return $ insp ^? inspectionAt-			if fmtime < tm'-				then return (Just (tm', cts))-				else do-					void $ postSessionUpdater $ SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath)-					return Nothing+{-# LANGUAGE FlexibleInstances, TypeOperators, TypeApplications, OverloadedStrings #-}
+
+module HsDev.Scan (
+	-- * Enumerate functions
+	CompileFlag, ModuleToScan, ProjectToScan, PackageDbToScan, ScanContents(..),
+	EnumContents(..),
+	enumRescan, enumDependent, enumProject, enumSandbox, enumDirectory,
+
+	-- * Scan
+	scanProjectFile,
+	scanModify,
+	upToDate, changedModules,
+	getFileContents,
+
+	-- * Reexportss
+	module HsDev.Symbols.Types,
+	module Control.Monad.Except,
+	) where
+
+import Control.DeepSeq
+import Control.Lens
+import Control.Monad.Except
+import Data.Deps
+import Data.Maybe (catMaybes, isJust, listToMaybe)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.List (intercalate)
+import Data.Text (Text)
+import Data.Text.Lens (unpacked)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (POSIXTime)
+import Data.Traversable (for)
+import Data.String (IsString, fromString)
+import qualified Data.Set as S
+import System.Directory
+import Text.Format
+import qualified System.Log.Simple as Log
+
+import HsDev.Error
+import qualified HsDev.Database.SQLite as SQLite
+import HsDev.Database.SQLite.Select
+import HsDev.Scan.Browse (browsePackages)
+import HsDev.Server.Types (FileSource(..), SessionMonad(..), CommandMonad(..), inSessionGhc, postSessionUpdater)
+import HsDev.Sandbox
+import HsDev.Symbols
+import HsDev.Symbols.Types
+import HsDev.Display
+import HsDev.Inspect
+import HsDev.Util
+import System.Directory.Paths
+
+-- | Compile flags
+type CompileFlag = String
+-- | Module with flags ready to scan
+type ModuleToScan = (ModuleLocation, [CompileFlag], Maybe Text)
+-- | Project ready to scan
+type ProjectToScan = (Project, [ModuleToScan])
+-- | Package-db sandbox to scan (top of stack)
+type PackageDbToScan = PackageDbStack
+
+-- | Scan info
+data ScanContents = ScanContents {
+	modulesToScan :: [ModuleToScan],
+	projectsToScan :: [ProjectToScan],
+	sandboxesToScan :: [PackageDbStack] }
+
+instance NFData ScanContents where
+	rnf (ScanContents ms ps ss) = rnf ms `seq` rnf ps `seq` rnf ss
+
+instance Monoid ScanContents where
+	mempty = ScanContents [] [] []
+	mappend (ScanContents lm lp ls) (ScanContents rm rp rs) = ScanContents
+		(uniqueBy (view _1) $ lm ++ rm)
+		(uniqueBy (view _1) $ lp ++ rp)
+		(ordNub $ ls ++ rs)
+
+instance Formattable ScanContents where
+	formattable (ScanContents ms ps cs) = formattable str where
+		str :: String
+		str = format "modules: {}, projects: {}, package-dbs: {}"
+			~~ (T.intercalate comma $ ms ^.. each . _1 . moduleFile)
+			~~ (T.intercalate comma $ ps ^.. each . _1 . projectPath)
+			~~ (intercalate comma $ map (display . topPackageDb) $ cs ^.. each)
+		comma :: IsString s => s
+		comma = fromString ", "
+
+class EnumContents a where
+	enumContents :: CommandMonad m => a -> m ScanContents
+
+instance EnumContents ModuleLocation where
+	enumContents mloc = return $ ScanContents [(mloc, [], Nothing)] [] []
+
+instance EnumContents (Extensions ModuleLocation) where
+	enumContents ex = return $ ScanContents [(view entity ex, extensionsOpts ex, Nothing)] [] []
+
+instance EnumContents Project where
+	enumContents = enumProject
+
+instance EnumContents PackageDbStack where
+	enumContents pdbs = return $ ScanContents [] [] (packageDbStacks pdbs)
+
+instance EnumContents Sandbox where
+	enumContents = enumSandbox
+
+instance {-# OVERLAPPABLE #-} EnumContents a => EnumContents [a] where
+	enumContents = liftM mconcat . tries . map enumContents
+
+instance {-# OVERLAPPING #-} EnumContents FilePath where
+	enumContents f
+		| haskellSource f = hsdevLiftIO $ do
+			mproj <- liftIO $ locateProject f
+			case mproj of
+				Nothing -> enumContents $ FileModule (fromFilePath f) Nothing
+				Just proj -> do
+					ScanContents _ [(_, mods)] _ <- enumContents proj
+					return $ ScanContents (filter ((== Just f) . preview (_1 . moduleFile . path)) mods) [] []
+		| otherwise = enumDirectory f
+
+instance {-# OVERLAPPING #-} EnumContents Path where
+	enumContents = enumContents . view path
+
+instance EnumContents FileSource where
+	enumContents (FileSource f mcts)
+		| haskellSource (view path f) = do
+			ScanContents [(m, opts, _)] _ _ <- enumContents f
+			return $ ScanContents [(m, opts, mcts)] [] []
+		| otherwise = return mempty
+
+-- | Enum rescannable (i.e. already scanned) file
+enumRescan :: CommandMonad m => FilePath -> m ScanContents
+enumRescan fpath = Log.scope "enum-rescan" $ do
+	ms <- SQLite.query @_ @(ModuleLocation SQLite.:. Inspection)
+		(toQuery $ mconcat [
+			qModuleLocation "ml",
+			select_ ["ml.inspection_time", "ml.inspection_opts"],
+			where_ ["ml.file == ?"]])
+		(SQLite.Only fpath)
+	case ms of
+		[] -> do
+			Log.sendLog Log.Warning $ "file {} not found" ~~ fpath
+			return mempty
+		((mloc SQLite.:. insp):_) -> do
+			when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath
+			return $ ScanContents [(mloc, insp ^.. inspectionOpts . each . unpacked, Nothing)] [] []
+
+-- | Enum file dependent
+enumDependent :: CommandMonad m => FilePath -> m ScanContents
+enumDependent fpath = Log.scope "enum-dependent" $ do
+	ms <- SQLite.query @_ @ModuleId
+		(toQuery $ qModuleId `mappend` where_ ["mu.file == ?"]) (SQLite.Only fpath)
+	case ms of
+		[] -> do
+			Log.sendLog Log.Warning $ "file {} not found" ~~ fpath
+			return mempty
+		(mid:_) -> do
+			when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath
+			let
+				mcabal = mid ^? moduleLocation . moduleProject . _Just . projectCabal
+			depList <- SQLite.query @_ @(Path, Path) "select d.module_file, d.depends_file from sources_depends as d, projects_modules_scope as ps where ps.cabal is ? and ps.module_id == d.module_id;"
+				(SQLite.Only mcabal)
+			let
+				rdeps = inverse . either (const mempty) id . flatten . mconcat . map (uncurry dep) $ depList
+				dependent = rdeps ^. ix (fromFilePath fpath)
+			liftM mconcat $ mapM (enumRescan . view path) dependent
+
+-- | Enum project sources
+enumProject :: CommandMonad m => Project -> m ScanContents
+enumProject p = hsdevLiftIO $ do
+	p' <- liftIO $ loadProject p
+	pdbs <- inSessionGhc $ searchPackageDbStack (view projectPath p')
+	pkgs <- inSessionGhc $ liftM (S.fromList . map (view (package . packageName))) $ browsePackages [] pdbs
+	let
+		projOpts :: Path -> [Text]
+		projOpts f = map fromString $ concatMap makeOpts $ fileTargets p' f where
+			makeOpts :: Info -> [String]
+			makeOpts i = concat [
+				["-hide-all-packages"],
+				["-package " ++ view (projectName . path) p'],
+				["-package " ++ T.unpack dep' | dep' <- view infoDepends i, dep' `S.member` pkgs]]
+	srcs <- liftIO $ projectSources p'
+	let
+		mlocs = over each (\src -> over ghcOptions (++ projOpts (view entity src)) . over entity (\f -> FileModule f (Just p')) $ src) srcs
+	mods <- liftM modulesToScan $ enumContents mlocs
+	return $ ScanContents [] [(p', mods)] [] -- (sandboxCabals sboxes)
+
+-- | Enum sandbox
+enumSandbox :: CommandMonad m => Sandbox -> m ScanContents
+enumSandbox = (inSessionGhc . sandboxPackageDbStack) >=> enumContents
+
+-- | Enum directory modules
+enumDirectory :: CommandMonad m => FilePath -> m ScanContents
+enumDirectory dir = hsdevLiftIO $ do
+	cts <- liftIO $ traverseDirectory dir
+	let
+		projects = filter cabalFile cts
+		sources = filter haskellSource cts
+	dirs <- liftIO $ filterM doesDirectoryExist cts
+	sboxes <- liftM catMaybes $ triesMap (liftIO . findSandbox . fromFilePath) dirs
+	pdbs <- mapM enumSandbox sboxes
+	projs <- liftM mconcat $ triesMap (enumProject . project) projects
+	let
+		projPaths = map (view projectPath . fst) $ projectsToScan projs
+		standalone = map (`FileModule` Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) $ map fromFilePath sources
+	return $ mconcat [
+		ScanContents [(s, [], Nothing) | s <- standalone] [] [],
+		projs,
+		mconcat pdbs]
+
+-- | Scan project file
+scanProjectFile :: CommandMonad m => [String] -> Path -> m Project
+scanProjectFile _ f = hsdevLiftIO $ do
+	proj <- (liftIO $ locateProject (view path f)) >>= maybe (hsdevError $ FileNotFound f) return
+	liftIO $ loadProject proj
+
+-- | Scan additional info and modify scanned module
+scanModify :: CommandMonad m => ([String] -> Module -> m Module) -> InspectedModule -> m InspectedModule
+scanModify f im = traverse f' im where
+	f' m = f (toListOf (inspection . inspectionOpts . each . unpacked) im) m
+
+-- | Is inspected module up to date?
+upToDate :: SessionMonad m => ModuleLocation -> [String] -> Inspection -> m Bool
+upToDate mloc opts insp = do
+	insp' <- liftIO $ moduleInspection mloc opts
+	mfinsp <- fmap join $ for (mloc ^? moduleFile) $ \fpath -> do
+		tm <- SQLite.query @_ @(SQLite.Only Double) "select mtime from file_contents where file = ?;" (SQLite.Only fpath)
+		return $ fmap (fileContentsInspection_ opts . fromRational . toRational . SQLite.fromOnly) (listToMaybe tm)
+	let
+		lastInsp = maybe insp' (max insp') mfinsp
+	return $ fresh insp lastInsp
+
+-- | Returns new (to scan) and changed (to rescan) modules
+changedModules :: SessionMonad m => Map ModuleLocation Inspection -> [String] -> [ModuleToScan] -> m [ModuleToScan]
+changedModules inspMap opts = filterM $ \m -> if isJust (m ^. _3)
+	then return True
+	else maybe
+		(return True)
+		(liftM not . upToDate (m ^. _1) (opts ++ (m ^. _2)))
+		(M.lookup (m ^. _1) inspMap)
+
+-- | Returns file contents if it was set and still actual
+getFileContents :: SessionMonad m => Path -> m (Maybe (POSIXTime, Text))
+getFileContents fpath = do
+	mcts <- SQLite.query @_ @(Double, Text) "select mtime, contents from file_contents where file = ?;" (SQLite.Only fpath)
+	insp <- liftIO $ fileInspection fpath []
+	case listToMaybe mcts of
+		Nothing -> return Nothing
+		Just (tm, cts) -> do
+			let
+				tm' = fromRational (toRational tm)
+			fmtime <- maybe (hsdevError $ OtherError "impossible: inspection time not set after call to `fileInspection`") return $ insp ^? inspectionAt
+			if fmtime < tm'
+				then return (Just (tm', cts))
+				else do
+					void $ postSessionUpdater $ SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath)
+					return Nothing
src/HsDev/Scan/Browse.hs view
@@ -1,221 +1,221 @@-module HsDev.Scan.Browse (-	-- * List all packages-	browsePackages, browsePackagesDeps,-	-- * Scan cabal modules-	listModules,-	browseModules, browseModules',-	-- * Helpers-	readPackage, readPackageConfig, ghcModuleLocation,-	packageConfigs, packageDbModules, lookupModule_,-	modulesPackages, modulesPackagesGroups, withEachPackage,--	module Control.Monad.Except-	) where--import Control.Arrow-import Control.Lens (preview)-import Control.Monad.Catch (MonadCatch, catch, SomeException)-import Control.Monad.Except-import Data.Function (on)-import Data.List (groupBy, sort)-import Data.Maybe-import Data.String (fromString)-import qualified Data.Set as S-import Data.Version-import Language.Haskell.Exts.Fixity-import Language.Haskell.Exts.Syntax (Assoc(..), QName(..), Name(Ident), ModuleName(..))--import Data.Deps-import Data.LookupTable-import HsDev.PackageDb-import HsDev.Symbols-import HsDev.Error-import HsDev.Tools.Ghc.Worker (GhcM, tmpSession, formatType)-import HsDev.Tools.Ghc.Compat as Compat-import HsDev.Util (ordNub)--import qualified ConLike as GHC-import qualified DataCon as GHC-import qualified DynFlags as GHC-import qualified GHC-import qualified GHC.PackageDb as GHC-import qualified GhcMonad as GHC (liftIO)-import qualified Name as GHC-import qualified IdInfo as GHC-import qualified Packages as GHC-import qualified PatSyn as GHC-import qualified TyCon as GHC-import qualified Type as GHC-import qualified Var as GHC---- | Browse packages-browsePackages :: [String] -> PackageDbStack -> GhcM [PackageConfig]-browsePackages opts dbs = do-	tmpSession dbs opts-	liftM (map readPackageConfig) packageConfigs---- | Get packages with deps-browsePackagesDeps :: [String] -> PackageDbStack -> GhcM (Deps PackageConfig)-browsePackagesDeps opts dbs = do-	tmpSession dbs opts-	df <- GHC.getSessionDynFlags-	cfgs <- packageConfigs-	return $ mapDeps (toPkg df) $ mconcat [deps (Compat.unitId cfg) (Compat.depends df cfg) | cfg <- cfgs]-	where-		toPkg df' = readPackageConfig . getPackageDetails df'---- | List modules from ghc, accepts ghc-opts, stack of package-db to get modules for--- and list of packages to explicitely expose them with '-package' flag,--- otherwise hidden packages won't be loaded-listModules :: [String] -> PackageDbStack -> [ModulePackage] -> GhcM [ModuleLocation]-listModules opts dbs pkgs = do-	tmpSession dbs (opts ++ packagesOpts)-	ms <- packageDbModules-	return [ghcModuleLocation p m e | (p, m, e) <- ms]-	where-		packagesOpts = ["-package " ++ show p | p <- pkgs]---- | Like @browseModules@, but groups modules by package and inspects each package separately--- Trying to fix error: when there are several same packages (of different version), only @Module@ from--- one of them can be lookuped and therefore modules from different version packages won't be actually inspected-browseModules :: [String] -> PackageDbStack -> [ModuleLocation] -> GhcM [InspectedModule]-browseModules opts dbs mlocs = do-	tmpSession dbs opts-	liftM concat . withEachPackage (const $ browseModules' opts) $ mlocs---- | Inspect installed modules, doesn't set session and package flags!-browseModules' :: [String] -> [ModuleLocation] -> GhcM [InspectedModule]-browseModules' opts mlocs = do-	ms <- packageDbModules-	midTbl <- newLookupTable-	sidTbl <- newLookupTable-	let-		lookupModuleId p' m' e' = lookupTable (ghcModuleLocation p' m' e') (ghcModuleId p' m' e') midTbl-	liftM catMaybes $ sequence [browseModule' lookupModuleId (cacheInTableM sidTbl) p m e | (p, m, e) <- ms, ghcModuleLocation p m e `S.member` mlocs']-	where-		browseModule' :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM (Maybe InspectedModule)-		browseModule' modId' sym' p m e = tryT $ runInspect (ghcModuleLocation p m e) $ inspect_ (return $ InspectionAt 0 (map fromString opts)) (browseModule modId' sym' p m e)-		mlocs' = S.fromList mlocs--browseModule :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM Module-browseModule modId lookSym package' m exposed' = do-	df <- GHC.getSessionDynFlags-	mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return-	ds <- mapM (\n -> lookSym n (toDecl df mi n)) (GHC.modInfoExports mi)-	myModId <- modId package' m exposed'-	let-		dirAssoc GHC.InfixL = AssocLeft ()-		dirAssoc GHC.InfixR = AssocRight ()-		dirAssoc GHC.InfixN = AssocNone ()-		fixName o = Qual () (ModuleName () thisModule) (Ident () (GHC.occNameString o))-	return Module {-		_moduleId = myModId,-		_moduleDocs = Nothing,-		_moduleImports = [],-		_moduleExports = ds,-		_moduleFixities = [Fixity (dirAssoc dir) pr (fixName oname) | (oname, (pr, dir)) <- map (second Compat.getFixity) (maybe [] GHC.mi_fixities (GHC.modInfoIface mi))],-		_moduleScope = mempty,-		_moduleSource = Nothing }-	where-		thisModule = GHC.moduleNameString (GHC.moduleName m)-		mloc df m' = do-			pkg' <- maybe (hsdevError $ OtherError $ "Error getting module package: " ++ GHC.moduleNameString (GHC.moduleName m')) return $-				GHC.lookupPackage df (moduleUnitId m')-			modId pkg' m' (GHC.moduleName m `notElem` GHC.hiddenModules pkg')-		toDecl df minfo n = do-			tyInfo <- GHC.modInfoLookupName minfo n-			tyResult <- maybe (GHC.lookupName n) (return . Just) tyInfo-			declModId <- mloc df (GHC.nameModule n)-			return Symbol {-				_symbolId = SymbolId (fromString $ GHC.getOccString n) declModId,-				_symbolDocs = Nothing,-				_symbolPosition = Nothing,-				_symbolInfo = fromMaybe (Function Nothing) (tyResult >>= showResult df) }-		showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe SymbolInfo-		showResult dflags (GHC.AnId i) = case GHC.idDetails i of-			GHC.RecSelId p _ -> Just $ Selector (Just $ fromString $ formatType dflags $ GHC.varType i) parent ctors where-				parent = fromString $ Compat.recSelParent p-				ctors = map fromString $ Compat.recSelCtors p-			GHC.ClassOpId cls -> Just $ Method (Just $ fromString $ formatType dflags $ GHC.varType i) (fromString $ GHC.getOccString cls)-			_ -> Just $ Function (Just $ fromString $ formatType dflags $GHC.varType i)-		showResult dflags (GHC.AConLike c) = case c of-			GHC.RealDataCon d -> Just $ Constructor-				(map (fromString . formatType dflags) $ GHC.dataConOrigArgTys d)-				(fromString $ GHC.getOccString (GHC.dataConTyCon d))-			GHC.PatSynCon p -> Just $ PatConstructor-				(map (fromString . formatType dflags) $ GHC.patSynArgs p)-				Nothing-			-- TODO: Deal with `patSynFieldLabels` and `patSynFieldType`-		showResult dflags (GHC.ATyCon t)-			| GHC.isTypeSynonymTyCon t = Just $ Type args ctx-			| GHC.isPrimTyCon t = Just $ Type [] []-			| GHC.isNewTyCon t = Just $ NewType args ctx-			| GHC.isDataTyCon t = Just $ Data args ctx-			| GHC.isClassTyCon t = Just $ Class args ctx-			| GHC.isTypeFamilyTyCon t = Just $ TypeFam args ctx Nothing-			| GHC.isDataFamilyTyCon t = Just $ DataFam args ctx Nothing-			| otherwise = Just $ Type [] []-			where-				args = map (fromString . formatType dflags . GHC.mkTyVarTy) $ GHC.tyConTyVars t-				ctx = case GHC.tyConClass_maybe t of-					Nothing -> []-					Just cls -> map (fromString . formatType dflags) $ GHC.classSCTheta cls-		showResult _ _ = Nothing--tryT :: MonadCatch m => m a -> m (Maybe a)-tryT act = catch (fmap Just act) (const (return Nothing) . (id :: SomeException -> SomeException))--readPackage :: GHC.PackageConfig -> ModulePackage-readPackage pc = ModulePackage (fromString $ GHC.packageNameString pc) (fromString $ showVersion (GHC.packageVersion pc))--readPackageConfig :: GHC.PackageConfig -> PackageConfig-readPackageConfig pc = PackageConfig-	(readPackage pc)-	(map (fromString . GHC.moduleNameString . Compat.exposedModuleName) $ GHC.exposedModules pc)-	(GHC.exposed pc)--ghcModuleLocation :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleLocation-ghcModuleLocation p m = InstalledModule (map fromString $ GHC.libraryDirs p) (readPackage p) (fromString $ GHC.moduleNameString $ GHC.moduleName m)--ghcModuleId :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleId-ghcModuleId p m e = ModuleId (fromString mname') (ghcModuleLocation p m e) where-	mname' = GHC.moduleNameString $ GHC.moduleName m--packageConfigs :: GhcM [GHC.PackageConfig]-packageConfigs = liftM (fromMaybe [] . pkgDatabase) GHC.getSessionDynFlags--packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module, Bool)]-packageDbModules = do-	pkgs <- packageConfigs-	dflags <- GHC.getSessionDynFlags-	return [(p, m, exposed') |-		p <- pkgs,-		(mn, exposed') <- zip (map Compat.exposedModuleName (GHC.exposedModules p)) (repeat True) ++ zip (GHC.hiddenModules p) (repeat False),-		m <- lookupModule_ dflags mn]---- Lookup module everywhere-lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]-lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of-	GHC.LookupFound m' _ -> [m']-	GHC.LookupMultiple ms -> map fst ms-	GHC.LookupHidden ls rs -> map fst $ ls ++ rs-	GHC.LookupNotFound _ -> []---- | Get modules packages-modulesPackages :: [ModuleLocation] -> [ModulePackage]-modulesPackages = ordNub . mapMaybe (preview modulePackage)---- | Group modules by packages-modulesPackagesGroups :: [ModuleLocation] -> [(ModulePackage, [ModuleLocation])]-modulesPackagesGroups = map (first head . unzip) . groupBy ((==) `on` fst) . sort . mapMaybe (\m -> (,) <$> preview modulePackage m <*> pure m)---- | Run action for each package with prepared '-package' flags-withEachPackage :: (ModulePackage -> [ModuleLocation] -> GhcM a) -> [ModuleLocation] -> GhcM [a]-withEachPackage act = mapM (uncurry act') . modulesPackagesGroups where-	act' mpkg mlocs = setPackagesOpts >> act mpkg mlocs where-		packagesOpts = "-hide-all-packages" : ["-package " ++ show p | p <- modulesPackages mlocs]-		setPackagesOpts = void $ do-			fs <- GHC.getSessionDynFlags-			(fs', _, _) <- GHC.parseDynamicFlags (fs { GHC.packageFlags = [] }) (map GHC.noLoc packagesOpts)-			(fs'', _) <- GHC.liftIO $ GHC.initPackages fs'-			GHC.setSessionDynFlags fs''+module HsDev.Scan.Browse (
+	-- * List all packages
+	browsePackages, browsePackagesDeps,
+	-- * Scan cabal modules
+	listModules,
+	browseModules, browseModules',
+	-- * Helpers
+	readPackage, readPackageConfig, ghcModuleLocation,
+	packageConfigs, packageDbModules, lookupModule_,
+	modulesPackages, modulesPackagesGroups, withEachPackage,
+
+	module Control.Monad.Except
+	) where
+
+import Control.Arrow
+import Control.Lens (preview)
+import Control.Monad.Catch (MonadCatch, catch, SomeException)
+import Control.Monad.Except
+import Data.Function (on)
+import Data.List (groupBy, sort)
+import Data.Maybe
+import Data.String (fromString)
+import qualified Data.Set as S
+import Data.Version
+import Language.Haskell.Exts.Fixity
+import Language.Haskell.Exts.Syntax (Assoc(..), QName(..), Name(Ident), ModuleName(..))
+
+import Data.Deps
+import Data.LookupTable
+import HsDev.PackageDb
+import HsDev.Symbols
+import HsDev.Error
+import HsDev.Tools.Ghc.Worker (GhcM, tmpSession, formatType)
+import HsDev.Tools.Ghc.Compat as Compat
+import HsDev.Util (ordNub)
+
+import qualified ConLike as GHC
+import qualified DataCon as GHC
+import qualified DynFlags as GHC
+import qualified GHC
+import qualified GHC.PackageDb as GHC
+import qualified GhcMonad as GHC (liftIO)
+import qualified Name as GHC
+import qualified IdInfo as GHC
+import qualified Packages as GHC
+import qualified PatSyn as GHC
+import qualified TyCon as GHC
+import qualified Type as GHC
+import qualified Var as GHC
+
+-- | Browse packages
+browsePackages :: [String] -> PackageDbStack -> GhcM [PackageConfig]
+browsePackages opts dbs = do
+	tmpSession dbs opts
+	liftM (map readPackageConfig) packageConfigs
+
+-- | Get packages with deps
+browsePackagesDeps :: [String] -> PackageDbStack -> GhcM (Deps PackageConfig)
+browsePackagesDeps opts dbs = do
+	tmpSession dbs opts
+	df <- GHC.getSessionDynFlags
+	cfgs <- packageConfigs
+	return $ mapDeps (toPkg df) $ mconcat [deps (Compat.unitId cfg) (Compat.depends df cfg) | cfg <- cfgs]
+	where
+		toPkg df' = readPackageConfig . getPackageDetails df'
+
+-- | List modules from ghc, accepts ghc-opts, stack of package-db to get modules for
+-- and list of packages to explicitely expose them with '-package' flag,
+-- otherwise hidden packages won't be loaded
+listModules :: [String] -> PackageDbStack -> [ModulePackage] -> GhcM [ModuleLocation]
+listModules opts dbs pkgs = do
+	tmpSession dbs (opts ++ packagesOpts)
+	ms <- packageDbModules
+	return [ghcModuleLocation p m e | (p, m, e) <- ms]
+	where
+		packagesOpts = ["-package " ++ show p | p <- pkgs]
+
+-- | Like @browseModules@, but groups modules by package and inspects each package separately
+-- Trying to fix error: when there are several same packages (of different version), only @Module@ from
+-- one of them can be lookuped and therefore modules from different version packages won't be actually inspected
+browseModules :: [String] -> PackageDbStack -> [ModuleLocation] -> GhcM [InspectedModule]
+browseModules opts dbs mlocs = do
+	tmpSession dbs opts
+	liftM concat . withEachPackage (const $ browseModules' opts) $ mlocs
+
+-- | Inspect installed modules, doesn't set session and package flags!
+browseModules' :: [String] -> [ModuleLocation] -> GhcM [InspectedModule]
+browseModules' opts mlocs = do
+	ms <- packageDbModules
+	midTbl <- newLookupTable
+	sidTbl <- newLookupTable
+	let
+		lookupModuleId p' m' e' = lookupTable (ghcModuleLocation p' m' e') (ghcModuleId p' m' e') midTbl
+	liftM catMaybes $ sequence [browseModule' lookupModuleId (cacheInTableM sidTbl) p m e | (p, m, e) <- ms, ghcModuleLocation p m e `S.member` mlocs']
+	where
+		browseModule' :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM (Maybe InspectedModule)
+		browseModule' modId' sym' p m e = tryT $ runInspect (ghcModuleLocation p m e) $ inspect_ (return $ InspectionAt 0 (map fromString opts)) (browseModule modId' sym' p m e)
+		mlocs' = S.fromList mlocs
+
+browseModule :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM Module
+browseModule modId lookSym package' m exposed' = do
+	df <- GHC.getSessionDynFlags
+	mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return
+	ds <- mapM (\n -> lookSym n (toDecl df mi n)) (GHC.modInfoExports mi)
+	myModId <- modId package' m exposed'
+	let
+		dirAssoc GHC.InfixL = AssocLeft ()
+		dirAssoc GHC.InfixR = AssocRight ()
+		dirAssoc GHC.InfixN = AssocNone ()
+		fixName o = Qual () (ModuleName () thisModule) (Ident () (GHC.occNameString o))
+	return Module {
+		_moduleId = myModId,
+		_moduleDocs = Nothing,
+		_moduleImports = [],
+		_moduleExports = ds,
+		_moduleFixities = [Fixity (dirAssoc dir) pr (fixName oname) | (oname, (pr, dir)) <- map (second Compat.getFixity) (maybe [] GHC.mi_fixities (GHC.modInfoIface mi))],
+		_moduleScope = mempty,
+		_moduleSource = Nothing }
+	where
+		thisModule = GHC.moduleNameString (GHC.moduleName m)
+		mloc df m' = do
+			pkg' <- maybe (hsdevError $ OtherError $ "Error getting module package: " ++ GHC.moduleNameString (GHC.moduleName m')) return $
+				GHC.lookupPackage df (moduleUnitId m')
+			modId pkg' m' (GHC.moduleName m `notElem` GHC.hiddenModules pkg')
+		toDecl df minfo n = do
+			tyInfo <- GHC.modInfoLookupName minfo n
+			tyResult <- maybe (GHC.lookupName n) (return . Just) tyInfo
+			declModId <- mloc df (GHC.nameModule n)
+			return Symbol {
+				_symbolId = SymbolId (fromString $ GHC.getOccString n) declModId,
+				_symbolDocs = Nothing,
+				_symbolPosition = Nothing,
+				_symbolInfo = fromMaybe (Function Nothing) (tyResult >>= showResult df) }
+		showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe SymbolInfo
+		showResult dflags (GHC.AnId i) = case GHC.idDetails i of
+			GHC.RecSelId p _ -> Just $ Selector (Just $ fromString $ formatType dflags $ GHC.varType i) parent ctors where
+				parent = fromString $ Compat.recSelParent p
+				ctors = map fromString $ Compat.recSelCtors p
+			GHC.ClassOpId cls -> Just $ Method (Just $ fromString $ formatType dflags $ GHC.varType i) (fromString $ GHC.getOccString cls)
+			_ -> Just $ Function (Just $ fromString $ formatType dflags $GHC.varType i)
+		showResult dflags (GHC.AConLike c) = case c of
+			GHC.RealDataCon d -> Just $ Constructor
+				(map (fromString . formatType dflags) $ GHC.dataConOrigArgTys d)
+				(fromString $ GHC.getOccString (GHC.dataConTyCon d))
+			GHC.PatSynCon p -> Just $ PatConstructor
+				(map (fromString . formatType dflags) $ GHC.patSynArgs p)
+				Nothing
+			-- TODO: Deal with `patSynFieldLabels` and `patSynFieldType`
+		showResult dflags (GHC.ATyCon t)
+			| GHC.isTypeSynonymTyCon t = Just $ Type args ctx
+			| GHC.isPrimTyCon t = Just $ Type [] []
+			| GHC.isNewTyCon t = Just $ NewType args ctx
+			| GHC.isDataTyCon t = Just $ Data args ctx
+			| GHC.isClassTyCon t = Just $ Class args ctx
+			| GHC.isTypeFamilyTyCon t = Just $ TypeFam args ctx Nothing
+			| GHC.isDataFamilyTyCon t = Just $ DataFam args ctx Nothing
+			| otherwise = Just $ Type [] []
+			where
+				args = map (fromString . formatType dflags . GHC.mkTyVarTy) $ GHC.tyConTyVars t
+				ctx = case GHC.tyConClass_maybe t of
+					Nothing -> []
+					Just cls -> map (fromString . formatType dflags) $ GHC.classSCTheta cls
+		showResult _ _ = Nothing
+
+tryT :: MonadCatch m => m a -> m (Maybe a)
+tryT act = catch (fmap Just act) (const (return Nothing) . (id :: SomeException -> SomeException))
+
+readPackage :: GHC.PackageConfig -> ModulePackage
+readPackage pc = ModulePackage (fromString $ GHC.packageNameString pc) (fromString $ showVersion (GHC.packageVersion pc))
+
+readPackageConfig :: GHC.PackageConfig -> PackageConfig
+readPackageConfig pc = PackageConfig
+	(readPackage pc)
+	(map (fromString . GHC.moduleNameString . Compat.exposedModuleName) $ GHC.exposedModules pc)
+	(GHC.exposed pc)
+
+ghcModuleLocation :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleLocation
+ghcModuleLocation p m = InstalledModule (map fromString $ GHC.libraryDirs p) (readPackage p) (fromString $ GHC.moduleNameString $ GHC.moduleName m)
+
+ghcModuleId :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleId
+ghcModuleId p m e = ModuleId (fromString mname') (ghcModuleLocation p m e) where
+	mname' = GHC.moduleNameString $ GHC.moduleName m
+
+packageConfigs :: GhcM [GHC.PackageConfig]
+packageConfigs = liftM (fromMaybe [] . pkgDatabase) GHC.getSessionDynFlags
+
+packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module, Bool)]
+packageDbModules = do
+	pkgs <- packageConfigs
+	dflags <- GHC.getSessionDynFlags
+	return [(p, m, exposed') |
+		p <- pkgs,
+		(mn, exposed') <- zip (map Compat.exposedModuleName (GHC.exposedModules p)) (repeat True) ++ zip (GHC.hiddenModules p) (repeat False),
+		m <- lookupModule_ dflags mn]
+
+-- Lookup module everywhere
+lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]
+lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of
+	GHC.LookupFound m' _ -> [m']
+	GHC.LookupMultiple ms -> map fst ms
+	GHC.LookupHidden ls rs -> map fst $ ls ++ rs
+	GHC.LookupNotFound _ -> []
+
+-- | Get modules packages
+modulesPackages :: [ModuleLocation] -> [ModulePackage]
+modulesPackages = ordNub . mapMaybe (preview modulePackage)
+
+-- | Group modules by packages
+modulesPackagesGroups :: [ModuleLocation] -> [(ModulePackage, [ModuleLocation])]
+modulesPackagesGroups = map (first head . unzip) . groupBy ((==) `on` fst) . sort . mapMaybe (\m -> (,) <$> preview modulePackage m <*> pure m)
+
+-- | Run action for each package with prepared '-package' flags
+withEachPackage :: (ModulePackage -> [ModuleLocation] -> GhcM a) -> [ModuleLocation] -> GhcM [a]
+withEachPackage act = mapM (uncurry act') . modulesPackagesGroups where
+	act' mpkg mlocs = setPackagesOpts >> act mpkg mlocs where
+		packagesOpts = "-hide-all-packages" : ["-package " ++ show p | p <- modulesPackages mlocs]
+		setPackagesOpts = void $ do
+			fs <- GHC.getSessionDynFlags
+			(fs', _, _) <- GHC.parseDynamicFlags (fs { GHC.packageFlags = [] }) (map GHC.noLoc packagesOpts)
+			(fs'', _) <- GHC.liftIO $ GHC.initPackages fs'
+			GHC.setSessionDynFlags fs''
src/HsDev/Server/Base.hs view
@@ -1,417 +1,407 @@-{-# LANGUAGE CPP, OverloadedStrings, CPP, PatternGuards, TypeApplications #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Server.Base (-	initLog, runServer, Server,-	setupServer, shutdownServer,-	startServer, startServer_, stopServer, withServer, withServer_, inServer, clientCommand, parseCommand, readCommand,-	sendServer, sendServer_,-	findPath,-	processRequest, processClient, processClientSocket,--	unMmap, makeSocket, sockAddr,--	module HsDev.Server.Types,-	module HsDev.Server.Message-	) where--import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Concurrent.Chan as C-import Control.Lens (set, traverseOf, view)-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Loops-import Control.Monad.Reader-import Control.Monad.Catch (bracket_, bracket, finally)-import Data.Aeson hiding (Result, Error)-import Data.Default-import qualified Data.ByteString.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Maybe-import Data.String (fromString)-import qualified Data.Text as T (pack)-import Data.Time.Clock.POSIX-import Options.Applicative (info, progDesc)-import System.Log.Simple hiding (Level(..), Message)-import qualified System.Log.Simple.Base as Log (level_)-import qualified System.Log.Simple as Log-import Network.Socket-import qualified Network.Socket.ByteString as Net (send)-import qualified Network.Socket.ByteString.Lazy as Net (getContents)-import System.FilePath-import System.IO-import Text.Format ((~~))--import Control.Concurrent.Util-import qualified Control.Concurrent.FiniteChan as F-import Data.LookupTable-import System.Directory.Paths-import qualified System.Directory.Watcher as Watcher--import qualified HsDev.Client.Commands as Client-import qualified HsDev.Database.SQLite as SQLite-import HsDev.Error-import qualified HsDev.Database.Update as Update-import HsDev.Inspect (getDefines)-import HsDev.Tools.Ghc.Worker hiding (Session)-import HsDev.Server.Types-import HsDev.Server.Message-import HsDev.Symbols.Location (ModuleLocation(..), globalDb)-import qualified HsDev.Watcher as W-import HsDev.Util--#if mingw32_HOST_OS-import Data.Aeson.Types hiding (Result, Error)-import System.Win32.FileMapping.Memory (withMapFile, readMapFile)-import System.Win32.FileMapping.NamePool-#else-import System.Posix.Files (removeLink)-#endif---- | Inits log chan and returns functions (print message, wait channel)-initLog :: ServerOpts -> IO SessionLog-initLog sopts = do-	msgs <- C.newChan-	l <- newLog (logCfg [("", Log.level_ . T.pack . serverLogLevel $ sopts)]) $ concat [-		[logHandler | not $ serverSilent sopts],-		[chaner msgs],-		[handler text (file f) | f <- maybeToList (serverLog sopts)]]-	let-		listenLog = C.dupChan msgs >>= C.getChanContents-	return $ SessionLog l listenLog (stopLog l)-	where-		logHandler-			| serverLogNoColor sopts = handler text console-			| otherwise = handler text coloredConsole---- | Run server-runServer :: ServerOpts -> ServerM IO () -> IO ()-runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> Watcher.withWatcher $ \watcher -> withLog (sessionLogger slog) $ do-	waitSem <- liftIO $ newQSem 0-	sqlDb <- liftIO $ SQLite.initialize (fromMaybe SQLite.sharedMemory $ serverDbFile sopts)-	clientChan <- liftIO F.newChan-#if mingw32_HOST_OS-	mmapPool <- Just <$> liftIO (createPool "hsdev")-#endif-	ghcw <- ghcWorker-	liftIO $ inWorker ghcw $ tmpSession globalDb []-	defs <- liftIO getDefines--	session <- liftIO $ fixIO $ \sess -> do-		let-			setFileCts fpath Nothing = void $ withSession sess $ postSessionUpdater $ do-				Log.sendLog Log.Trace $ "dropping file contents for {}" ~~ fpath-				SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath)-			setFileCts fpath (Just cts) = do-				tm <- getPOSIXTime-				withSession sess $ do-					notChanged <- SQLite.query @_ @(SQLite.Only Bool) "select contents == ? from file_contents where file = ?;" (cts, fpath)-					let-						notChanged' = any SQLite.fromOnly notChanged-					void $ postSessionUpdater $ do-						Log.sendLog Log.Trace $ "setting file contents for {} with mtime = {}" ~~ fpath ~~ show tm-						SQLite.execute "insert or replace into file_contents (file, contents, mtime) values (?, ?, ?);" (fpath, cts, (fromRational (toRational tm) :: Double))-						unless notChanged' $ liftIO $-							writeChan (W.watcherChan watcher) (W.WatchedModule, W.Event W.Modified (view path fpath) tm)--		uw <- startWorker (withSession sess . withSqlConnection) id logAll-		resolveEnvTable <- newLookupTable--		return $ Session-			sqlDb-			(fromMaybe SQLite.sharedMemory $ serverDbFile sopts)-			slog-			watcher-			setFileCts-#if mingw32_HOST_OS-			mmapPool-#endif-			ghcw-			uw-			resolveEnvTable-			(do-				withLog (sessionLogger slog) $ Log.sendLog Log.Trace "stopping server"-				signalQSem waitSem)-			(waitQSem waitSem)-			clientChan-			defs--	_ <- fork $ do-		emptyTask <- async $ return ()-		updaterTask <- newMVar emptyTask-		tasksVar <- newMVar []-		Update.onEvents_ watcher $ \evs -> withSession session $-			void $ Client.runClient def $ Update.processEvents (withSession session . inSessionUpdater . void . Client.runClient def . Update.applyUpdates def) updaterTask tasksVar evs-	liftIO $ runReaderT (runServerM $ (watchDb >> act) `finally` closeSession) session-	where-		closeSession = do-			askSession sessionUpdater >>= liftIO . joinWorker-			Log.sendLog Log.Info "updater worker stopped"-			askSession sessionGhc >>= liftIO . joinWorker-			Log.sendLog Log.Info "ghc worker stopped"-			askSession sessionSqlDatabase >>= liftIO . SQLite.close-			Log.sendLog Log.Info "sql connection closed"----- | Set initial watch: package-dbs, projects and standalone sources-watchDb :: SessionMonad m => m ()-watchDb = do-	w <- askSession sessionWatcher-	-- TODO: Implement watching package-dbs-	cabals <- SQLite.query_ "select cabal from projects;"-	projects <- mapM (SQLite.loadProject . SQLite.fromOnly) cabals-	liftIO $ mapM_ (\proj -> W.watchProject w proj []) projects--	files <- SQLite.query_ "select file from modules where file is not null and cabal is null;"-	liftIO $ mapM_ (\(SQLite.Only f) -> W.watchModule w (FileModule f Nothing)) files--type Server = Worker (ServerM IO)---- | Start listening for incoming connections-setupServer :: ServerOpts -> ServerM IO ()-setupServer sopts = do-	q <- liftIO $ newQSem 0-	clientChan <- askSession sessionClients-	session <- getSession-	_ <- liftIO $ async $ withSession session $ Log.scope "listener" $ flip finally serverExit $-		bracket (liftIO $ makeSocket (serverPort sopts)) (liftIO . close) $ \s -> do-			liftIO $ do-				setSocketOption s ReuseAddr 1-				addr' <- inet_addr "127.0.0.1"-				bind s (sockAddr (serverPort sopts) addr')-				listen s maxListenQueue-			forever $ logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ do-				Log.sendLog Log.Trace "accepting connection..."-				liftIO $ signalQSem q-				(s', addr') <- liftIO $ accept s-				Log.sendLog Log.Trace $ "accepted {}" ~~ show addr'-				fork $ withSession session $ Log.scope (T.pack $ show addr') $-					logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $-						flip finally (liftIO $ close s') $-							bracket (liftIO newEmptyMVar) (liftIO . (`putMVar` ())) $ \done -> do-								me <- liftIO myThreadId-								let-									timeoutWait = withSession session $ do-										notDone <- liftIO $ isEmptyMVar done-										when notDone $ do-											Log.sendLog Log.Trace $ "waiting for {} to complete" ~~ show addr'-											waitAsync <- liftIO $ async $ do-												threadDelay 1000000-												killThread me-											liftIO $ void $ waitCatch waitAsync-								liftIO $ void $ F.sendChan clientChan timeoutWait-								processClientSocket (show addr') s'--	Log.sendLog Log.Trace "waiting for starting accept thread..."-	liftIO $ waitQSem q-	logIO "error writing to stdout: " (Log.sendLog Log.Error . fromString) $ liftIO $ putStrLn $ "Server started at port {}" ~~ serverPort sopts-	Log.sendLog Log.Info $ "Server started at port {}" ~~ serverPort sopts---- | Shutdown server-shutdownServer :: ServerOpts -> ServerM IO ()-shutdownServer sopts = do-	Log.sendLog Log.Trace "waiting for accept thread..."-	serverWait-	Log.sendLog Log.Trace "accept thread stopped"-	liftIO $ unlink (serverPort sopts)-	Log.sendLog Log.Trace "waiting for clients..."-	serverWaitClients-	Log.sendLog Log.Info "server stopped"--startServer :: ServerOpts -> IO Server-startServer sopts = startWorker (runServer sopts) (bracket_ (setupServer sopts) (shutdownServer sopts)) logAll---- Tiny version with no network stuff-startServer_ :: ServerOpts -> IO Server-startServer_ sopts = startWorker (runServer sopts) id logAll--stopServer :: Server -> IO ()-stopServer s = sendServer_ s ["exit"] >> joinWorker s--withServer :: ServerOpts -> (Server -> IO a) -> IO a-withServer sopts = bracket (startServer sopts) stopServer--withServer_ :: ServerOpts -> (Server -> IO a) -> IO a-withServer_ sopts = bracket (startServer_ sopts) stopServer--inServer :: Server -> ServerM IO a -> IO a-inServer = inWorker--clientCommand :: CommandOptions -> Command -> ServerM IO Result-clientCommand copts c = do-	c' <- liftIO $ canonicalize c-	Client.runClient copts (Client.runCommand c')--parseCommand :: [String] -> Either String Command-parseCommand = parseArgs "hsdev" (info cmdP (progDesc "hsdev tool"))--readCommand :: [String] -> Command-readCommand = either error id . parseCommand--sendServer :: Server -> CommandOptions -> [String] -> IO Result-sendServer srv copts args = case parseCommand args of-	Left e -> hsdevError $ RequestError e (unwords args)-	Right c -> inServer srv (clientCommand copts c)--sendServer_ :: Server -> [String] -> IO Result-sendServer_ srv = sendServer srv def--chaner :: C.Chan Log.Message -> Consumer Log.Message-chaner ch = return $ C.writeChan ch--findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath-findPath copts f = liftIO $ canonicalize (normalise f') where-	f' = absolutise (fromFilePath $ commandOptionsRoot copts) f---- | Process request, notifications can be sent during processing-processRequest :: SessionMonad m => CommandOptions -> Command -> m Result-processRequest copts c = do-	c' <- paths (findPath copts) c-	s <- getSession-	withSession s $ Client.runClient copts $ Client.runCommand c'---- | Process client, listen for requests and process them-processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m ()-processClient name rchan send' = do-	Log.sendLog Log.Info "connected"-	respChan <- liftIO newChan-	fork $ getChanContents respChan >>= mapM_ (send' . encodeMessage)-	linkVar <- liftIO $ newMVar $ return ()-	s <- getSession-	exit <- askSession sessionExit-	let-		answer :: SessionMonad m => Msg (Message Response) -> m ()-		answer m = do-			unless (isNotification $ view (msg . message) m) $-				Log.sendLog Log.Trace $ "responsed << {}" ~~ ellipsis (fromUtf8 (encode $ view (msg . message) m))-			liftIO $ writeChan respChan m-			where-				ellipsis :: String -> String-				ellipsis str-					| length str < 100 = str-					| otherwise = take 100 str ++ "..."--	flip finally (disconnected linkVar) $-		whileJust_ (liftIO $ F.getChan rchan) $ \req' -> do-			Log.sendLog Log.Trace $ "received >> {}" ~~ fromUtf8 req'-			case decodeMessage req' of-				Left em -> do-					Log.sendLog Log.Warning $ "Invalid request {}" ~~ fromUtf8 req'-					answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em-				Right m -> fork $ withSession s $ Log.scope (T.pack name) $ Log.scope "req" $-					Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do-						resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do-							let-								onNotify n-									| silent = return ()-									| otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer-							Log.sendLog Log.Trace $ "requested >> {}" ~~ fromUtf8 (encode c)-							resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $-								processRequest-									CommandOptions {-										commandOptionsRoot = cdir,-										commandOptionsNotify = withSession s . onNotify,-										commandOptionsLink = void (swapMVar linkVar exit),-										commandOptionsHold = forever (F.getChan rchan) }-									c-							mmap' noFile resp-						answer resp'-	where-		handleTimeout :: Int -> IO Result -> IO Result-		handleTimeout 0 = id-		handleTimeout tm = fmap (fromMaybe $ Error $ OtherError "timeout") . timeout tm--		mmap' :: SessionMonad m => Bool -> Response -> m Response-#if mingw32_HOST_OS-		mmap' False r = do-			mpool <- askSession sessionMmapPool-			case mpool of-				Just pool -> liftIO $ mmap pool r-				Nothing -> return r-#endif-		mmap' _ r = return r--		-- Call on disconnected, either no action or exit command-		disconnected :: SessionMonad m => MVar (IO ()) -> m ()-		disconnected var = do-			Log.sendLog Log.Info "disconnected"-			liftIO $ join $ takeMVar var---- | Process client by socket-processClientSocket :: SessionMonad m => String -> Socket -> m ()-processClientSocket name s = do-	recvChan <- liftIO F.newChan-	fork $ finally-		(Net.getContents s >>= mapM_ (F.sendChan recvChan) . L.lines)-		(F.closeChan recvChan)-	processClient name recvChan (sendLine s)-	where-		-- NOTE: Network version of `sendAll` goes to infinite loop on client socket close-		-- when server's send is blocked, see https://github.com/haskell/network/issues/155-		-- After that issue fixed we may revert to `processClientHandle`-		sendLine :: Socket -> ByteString -> IO ()-		sendLine sock bs = sendAll sock $ L.toStrict $ L.snoc bs '\n'-		sendAll :: Socket -> BS.ByteString -> IO ()-		sendAll sock bs-			| BS.null bs = return ()-			| otherwise = do-				sent <- Net.send sock bs-				when (sent > 0) $ sendAll sock (BS.drop sent bs)--#if mingw32_HOST_OS-newtype MmapFile = MmapFile String--instance ToJSON MmapFile where-	toJSON (MmapFile f) = object ["file" .= f]--instance FromJSON MmapFile where-	parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file"---- | Push message to mmap and return response which points to this mmap-mmap :: Pool -> Response -> IO Response-mmap mmapPool r-	| L.length msg' <= 1024 = return r-	| otherwise = do-		rvar <- newEmptyMVar-		_ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ catchError-			(withMapFile mmapName (L.toStrict msg') $ liftIO $ do-				_ <- tryPutMVar rvar $ result $ MmapFile mmapName-				-- give 10 seconds for client to read data-				threadDelay 10000000)-			(\_ -> liftIO $ void $ tryPutMVar rvar r)-		takeMVar rvar-	where-		msg' = encode r-#endif---- | If response points to mmap, get its contents and parse-unMmap :: Response -> IO Response-#if mingw32_HOST_OS-unMmap (Response (Right (Result v)))-	| Just (MmapFile f) <- parseMaybe parseJSON v = do-		cts <- runExceptT (fmap L.fromStrict (readMapFile f))-		case cts of-			Left _ -> return $ responseError $ ResponseError "can't read map view of file" f-			Right r' -> case eitherDecode r' of-				Left e' -> return $ responseError $ ResponseError ("can't parse response: {}" ~~ e') (fromUtf8 r')-				Right r'' -> return r''-#endif-unMmap r = return r--makeSocket :: ConnectionPort -> IO Socket-makeSocket (NetworkPort _) = socket AF_INET Stream defaultProtocol-makeSocket (UnixPort _) = socket AF_UNIX Stream defaultProtocol--sockAddr :: ConnectionPort -> HostAddress -> SockAddr-sockAddr (NetworkPort p) addr = SockAddrInet (fromIntegral p) addr-sockAddr (UnixPort s) _ = SockAddrUnix s--unlink :: ConnectionPort -> IO ()-unlink (NetworkPort _) = return ()-#if mingw32_HOST_OS-unlink (UnixPort _) = return ()-#else-unlink (UnixPort s) = removeLink s-#endif+{-# LANGUAGE CPP, OverloadedStrings, CPP, PatternGuards, TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Server.Base (
+	initLog, runServer, Server,
+	setupServer, shutdownServer,
+	startServer, startServer_, stopServer, withServer, withServer_, inServer, clientCommand, parseCommand, readCommand,
+	sendServer, sendServer_,
+	findPath,
+	processRequest, processClient, processClientSocket,
+
+	unMmap, makeSocket, sockAddr,
+
+	module HsDev.Server.Types,
+	module HsDev.Server.Message
+	) where
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import qualified Control.Concurrent.Chan as C
+import Control.Lens (set, traverseOf, view)
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Loops
+import Control.Monad.Reader
+import Control.Monad.Catch (bracket_, bracket, finally)
+import Data.Aeson hiding (Result, Error)
+import Data.Default
+import qualified Data.ByteString.Char8 as BS
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Maybe
+import Data.String (fromString)
+import qualified Data.Text as T (pack)
+import Data.Time.Clock.POSIX
+import Options.Applicative (info, progDesc)
+import System.Log.Simple hiding (Level(..), Message)
+import qualified System.Log.Simple.Base as Log (level_)
+import qualified System.Log.Simple as Log
+import Network.Socket
+import qualified Network.Socket.ByteString.Lazy as Net (getContents, sendAll)
+import System.FilePath
+import System.IO
+import Text.Format ((~~))
+
+import Control.Concurrent.Util
+import qualified Control.Concurrent.FiniteChan as F
+import Data.LookupTable
+import System.Directory.Paths
+import qualified System.Directory.Watcher as Watcher
+
+import qualified HsDev.Client.Commands as Client
+import qualified HsDev.Database.SQLite as SQLite
+import HsDev.Error
+import qualified HsDev.Database.Update as Update
+import HsDev.Inspect (getDefines)
+import HsDev.Tools.Ghc.Worker hiding (Session)
+import HsDev.Server.Types
+import HsDev.Server.Message
+import HsDev.Symbols.Location (ModuleLocation(..), globalDb)
+import qualified HsDev.Watcher as W
+import HsDev.Util
+
+#if mingw32_HOST_OS
+import Data.Aeson.Types hiding (Result, Error)
+import System.Win32.FileMapping.Memory (withMapFile, readMapFile)
+import System.Win32.FileMapping.NamePool
+#else
+import System.Posix.Files (removeLink)
+#endif
+
+-- | Inits log chan and returns functions (print message, wait channel)
+initLog :: ServerOpts -> IO SessionLog
+initLog sopts = do
+	msgs <- C.newChan
+	l <- newLog (logCfg [("", Log.level_ . T.pack . serverLogLevel $ sopts)]) $ concat [
+		[logHandler | not $ serverSilent sopts],
+		[chaner msgs],
+		[handler text (file f) | f <- maybeToList (serverLog sopts)]]
+	let
+		listenLog = C.dupChan msgs >>= C.getChanContents
+	return $ SessionLog l listenLog (stopLog l)
+	where
+		logHandler
+			| serverLogNoColor sopts = handler text console
+			| otherwise = handler text coloredConsole
+
+-- | Run server
+runServer :: ServerOpts -> ServerM IO () -> IO ()
+runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> Watcher.withWatcher $ \watcher -> withLog (sessionLogger slog) $ do
+	waitSem <- liftIO $ newQSem 0
+	sqlDb <- liftIO $ SQLite.initialize (fromMaybe SQLite.sharedMemory $ serverDbFile sopts)
+	clientChan <- liftIO F.newChan
+#if mingw32_HOST_OS
+	mmapPool <- Just <$> liftIO (createPool "hsdev")
+#endif
+	ghcw <- ghcWorker
+	liftIO $ inWorker ghcw $ tmpSession globalDb []
+	defs <- liftIO getDefines
+
+	session <- liftIO $ fixIO $ \sess -> do
+		let
+			setFileCts fpath Nothing = void $ withSession sess $ postSessionUpdater $ do
+				Log.sendLog Log.Trace $ "dropping file contents for {}" ~~ fpath
+				SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath)
+			setFileCts fpath (Just cts) = do
+				tm <- getPOSIXTime
+				withSession sess $ do
+					notChanged <- SQLite.query @_ @(SQLite.Only Bool) "select contents == ? from file_contents where file = ?;" (cts, fpath)
+					let
+						notChanged' = any SQLite.fromOnly notChanged
+					void $ postSessionUpdater $ do
+						Log.sendLog Log.Trace $ "setting file contents for {} with mtime = {}" ~~ fpath ~~ show tm
+						SQLite.execute "insert or replace into file_contents (file, contents, mtime) values (?, ?, ?);" (fpath, cts, (fromRational (toRational tm) :: Double))
+						unless notChanged' $ liftIO $
+							writeChan (W.watcherChan watcher) (W.WatchedModule, W.Event W.Modified (view path fpath) tm)
+
+		uw <- startWorker (withSession sess . withSqlConnection) id logAll
+		resolveEnvTable <- newLookupTable
+
+		return $ Session
+			sqlDb
+			(fromMaybe SQLite.sharedMemory $ serverDbFile sopts)
+			slog
+			watcher
+			setFileCts
+#if mingw32_HOST_OS
+			mmapPool
+#endif
+			ghcw
+			uw
+			resolveEnvTable
+			(do
+				withLog (sessionLogger slog) $ Log.sendLog Log.Trace "stopping server"
+				signalQSem waitSem)
+			(waitQSem waitSem)
+			clientChan
+			defs
+
+	_ <- fork $ do
+		emptyTask <- async $ return ()
+		updaterTask <- newMVar emptyTask
+		tasksVar <- newMVar []
+		Update.onEvents_ watcher $ \evs -> withSession session $
+			void $ Client.runClient def $ Update.processEvents (withSession session . inSessionUpdater . void . Client.runClient def . Update.applyUpdates def) updaterTask tasksVar evs
+	liftIO $ runReaderT (runServerM $ (watchDb >> act) `finally` closeSession) session
+	where
+		closeSession = do
+			askSession sessionUpdater >>= liftIO . joinWorker
+			Log.sendLog Log.Info "updater worker stopped"
+			askSession sessionGhc >>= liftIO . joinWorker
+			Log.sendLog Log.Info "ghc worker stopped"
+			askSession sessionSqlDatabase >>= liftIO . SQLite.close
+			Log.sendLog Log.Info "sql connection closed"
+
+
+-- | Set initial watch: package-dbs, projects and standalone sources
+watchDb :: SessionMonad m => m ()
+watchDb = do
+	w <- askSession sessionWatcher
+	-- TODO: Implement watching package-dbs
+	cabals <- SQLite.query_ "select cabal from projects;"
+	projects <- mapM (SQLite.loadProject . SQLite.fromOnly) cabals
+	liftIO $ mapM_ (\proj -> W.watchProject w proj []) projects
+
+	files <- SQLite.query_ "select file from modules where file is not null and cabal is null;"
+	liftIO $ mapM_ (\(SQLite.Only f) -> W.watchModule w (FileModule f Nothing)) files
+
+type Server = Worker (ServerM IO)
+
+-- | Start listening for incoming connections
+setupServer :: ServerOpts -> ServerM IO ()
+setupServer sopts = do
+	q <- liftIO $ newQSem 0
+	clientChan <- askSession sessionClients
+	session <- getSession
+	_ <- liftIO $ async $ withSession session $ Log.scope "listener" $ flip finally serverExit $
+		bracket (liftIO $ makeSocket (serverPort sopts)) (liftIO . close) $ \s -> do
+			liftIO $ do
+				setSocketOption s ReuseAddr 1
+				addr' <- inet_addr "127.0.0.1"
+				bind s (sockAddr (serverPort sopts) addr')
+				listen s maxListenQueue
+			forever $ logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ do
+				Log.sendLog Log.Trace "accepting connection..."
+				liftIO $ signalQSem q
+				(s', addr') <- liftIO $ accept s
+				Log.sendLog Log.Trace $ "accepted {}" ~~ show addr'
+				fork $ withSession session $ Log.scope (T.pack $ show addr') $
+					logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $
+						flip finally (liftIO $ close s') $
+							bracket (liftIO newEmptyMVar) (liftIO . (`putMVar` ())) $ \done -> do
+								me <- liftIO myThreadId
+								let
+									timeoutWait = withSession session $ do
+										notDone <- liftIO $ isEmptyMVar done
+										when notDone $ do
+											Log.sendLog Log.Trace $ "waiting for {} to complete" ~~ show addr'
+											waitAsync <- liftIO $ async $ do
+												threadDelay 1000000
+												killThread me
+											liftIO $ void $ waitCatch waitAsync
+								liftIO $ void $ F.sendChan clientChan timeoutWait
+								processClientSocket (show addr') s'
+
+	Log.sendLog Log.Trace "waiting for starting accept thread..."
+	liftIO $ waitQSem q
+	logIO "error writing to stdout: " (Log.sendLog Log.Error . fromString) $ liftIO $ putStrLn $ "Server started at port {}" ~~ serverPort sopts
+	Log.sendLog Log.Info $ "Server started at port {}" ~~ serverPort sopts
+
+-- | Shutdown server
+shutdownServer :: ServerOpts -> ServerM IO ()
+shutdownServer sopts = do
+	Log.sendLog Log.Trace "waiting for accept thread..."
+	serverWait
+	Log.sendLog Log.Trace "accept thread stopped"
+	liftIO $ unlink (serverPort sopts)
+	Log.sendLog Log.Trace "waiting for clients..."
+	serverWaitClients
+	Log.sendLog Log.Info "server stopped"
+
+startServer :: ServerOpts -> IO Server
+startServer sopts = startWorker (runServer sopts) (bracket_ (setupServer sopts) (shutdownServer sopts)) logAll
+
+-- Tiny version with no network stuff
+startServer_ :: ServerOpts -> IO Server
+startServer_ sopts = startWorker (runServer sopts) id logAll
+
+stopServer :: Server -> IO ()
+stopServer s = sendServer_ s ["exit"] >> joinWorker s
+
+withServer :: ServerOpts -> (Server -> IO a) -> IO a
+withServer sopts = bracket (startServer sopts) stopServer
+
+withServer_ :: ServerOpts -> (Server -> IO a) -> IO a
+withServer_ sopts = bracket (startServer_ sopts) stopServer
+
+inServer :: Server -> ServerM IO a -> IO a
+inServer = inWorker
+
+clientCommand :: CommandOptions -> Command -> ServerM IO Result
+clientCommand copts c = do
+	c' <- liftIO $ canonicalize c
+	Client.runClient copts (Client.runCommand c')
+
+parseCommand :: [String] -> Either String Command
+parseCommand = parseArgs "hsdev" (info cmdP (progDesc "hsdev tool"))
+
+readCommand :: [String] -> Command
+readCommand = either error id . parseCommand
+
+sendServer :: Server -> CommandOptions -> [String] -> IO Result
+sendServer srv copts args = case parseCommand args of
+	Left e -> hsdevError $ RequestError e (unwords args)
+	Right c -> inServer srv (clientCommand copts c)
+
+sendServer_ :: Server -> [String] -> IO Result
+sendServer_ srv = sendServer srv def
+
+chaner :: C.Chan Log.Message -> Consumer Log.Message
+chaner ch = return $ C.writeChan ch
+
+findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath
+findPath copts f = liftIO $ canonicalize (normalise f') where
+	f' = absolutise (fromFilePath $ commandOptionsRoot copts) f
+
+-- | Process request, notifications can be sent during processing
+processRequest :: SessionMonad m => CommandOptions -> Command -> m Result
+processRequest copts c = do
+	c' <- paths (findPath copts) c
+	s <- getSession
+	withSession s $ Client.runClient copts $ Client.runCommand c'
+
+-- | Process client, listen for requests and process them
+processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m ()
+processClient name rchan send' = do
+	Log.sendLog Log.Info "connected"
+	respChan <- liftIO newChan
+	fork $ getChanContents respChan >>= mapM_ (send' . encodeMessage)
+	linkVar <- liftIO $ newMVar $ return ()
+	s <- getSession
+	exit <- askSession sessionExit
+	let
+		answer :: SessionMonad m => Msg (Message Response) -> m ()
+		answer m = do
+			unless (isNotification $ view (msg . message) m) $
+				Log.sendLog Log.Trace $ "responsed << {}" ~~ ellipsis (fromUtf8 (encode $ view (msg . message) m))
+			liftIO $ writeChan respChan m
+			where
+				ellipsis :: String -> String
+				ellipsis str
+					| length str < 100 = str
+					| otherwise = take 100 str ++ "..."
+
+	flip finally (disconnected linkVar) $
+		whileJust_ (liftIO $ F.getChan rchan) $ \req' -> do
+			Log.sendLog Log.Trace $ "received >> {}" ~~ fromUtf8 req'
+			case decodeMessage req' of
+				Left em -> do
+					Log.sendLog Log.Warning $ "Invalid request {}" ~~ fromUtf8 req'
+					answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em
+				Right m -> fork $ withSession s $ Log.scope (T.pack name) $ Log.scope "req" $
+					Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do
+						resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do
+							let
+								onNotify n
+									| silent = return ()
+									| otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer
+							Log.sendLog Log.Trace $ "requested >> {}" ~~ fromUtf8 (encode c)
+							resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $
+								processRequest
+									CommandOptions {
+										commandOptionsRoot = cdir,
+										commandOptionsNotify = withSession s . onNotify,
+										commandOptionsLink = void (swapMVar linkVar exit),
+										commandOptionsHold = forever (F.getChan rchan) }
+									c
+							mmap' noFile resp
+						answer resp'
+	where
+		handleTimeout :: Int -> IO Result -> IO Result
+		handleTimeout 0 = id
+		handleTimeout tm = fmap (fromMaybe $ Error $ OtherError "timeout") . timeout tm
+
+		mmap' :: SessionMonad m => Bool -> Response -> m Response
+#if mingw32_HOST_OS
+		mmap' False r = do
+			mpool <- askSession sessionMmapPool
+			case mpool of
+				Just pool -> liftIO $ mmap pool r
+				Nothing -> return r
+#endif
+		mmap' _ r = return r
+
+		-- Call on disconnected, either no action or exit command
+		disconnected :: SessionMonad m => MVar (IO ()) -> m ()
+		disconnected var = do
+			Log.sendLog Log.Info "disconnected"
+			liftIO $ join $ takeMVar var
+
+-- | Process client by socket
+processClientSocket :: SessionMonad m => String -> Socket -> m ()
+processClientSocket name s = do
+	recvChan <- liftIO F.newChan
+	fork $ finally
+		(Net.getContents s >>= mapM_ (F.sendChan recvChan) . L.lines)
+		(F.closeChan recvChan)
+	processClient name recvChan (sendLine s)
+	where
+		sendLine :: Socket -> ByteString -> IO ()
+		sendLine sock bs = Net.sendAll sock $ L.snoc bs '\n'
+
+#if mingw32_HOST_OS
+newtype MmapFile = MmapFile String
+
+instance ToJSON MmapFile where
+	toJSON (MmapFile f) = object ["file" .= f]
+
+instance FromJSON MmapFile where
+	parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file"
+
+-- | Push message to mmap and return response which points to this mmap
+mmap :: Pool -> Response -> IO Response
+mmap mmapPool r
+	| L.length msg' <= 1024 = return r
+	| otherwise = do
+		rvar <- newEmptyMVar
+		_ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ catchError
+			(withMapFile mmapName (L.toStrict msg') $ liftIO $ do
+				_ <- tryPutMVar rvar $ result $ MmapFile mmapName
+				-- give 10 seconds for client to read data
+				threadDelay 10000000)
+			(\_ -> liftIO $ void $ tryPutMVar rvar r)
+		takeMVar rvar
+	where
+		msg' = encode r
+#endif
+
+-- | If response points to mmap, get its contents and parse
+unMmap :: Response -> IO Response
+#if mingw32_HOST_OS
+unMmap (Response (Right (Result v)))
+	| Just (MmapFile f) <- parseMaybe parseJSON v = do
+		cts <- runExceptT (fmap L.fromStrict (readMapFile f))
+		case cts of
+			Left _ -> return $ responseError $ ResponseError "can't read map view of file" f
+			Right r' -> case eitherDecode r' of
+				Left e' -> return $ responseError $ ResponseError ("can't parse response: {}" ~~ e') (fromUtf8 r')
+				Right r'' -> return r''
+#endif
+unMmap r = return r
+
+makeSocket :: ConnectionPort -> IO Socket
+makeSocket (NetworkPort _) = socket AF_INET Stream defaultProtocol
+makeSocket (UnixPort _) = socket AF_UNIX Stream defaultProtocol
+
+sockAddr :: ConnectionPort -> HostAddress -> SockAddr
+sockAddr (NetworkPort p) addr = SockAddrInet (fromIntegral p) addr
+sockAddr (UnixPort s) _ = SockAddrUnix s
+
+unlink :: ConnectionPort -> IO ()
+unlink (NetworkPort _) = return ()
+#if mingw32_HOST_OS
+unlink (UnixPort _) = return ()
+#else
+unlink (UnixPort s) = removeLink s
+#endif
src/HsDev/Server/Commands.hs view
@@ -1,179 +1,179 @@-{-# LANGUAGE OverloadedStrings, CPP, LambdaCase, TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Server.Commands (-	ServerCommand(..), ServerOpts(..), ClientOpts(..),-	Request(..),-	Msg, isLisp, msg, jsonMsg, lispMsg, encodeMessage, decodeMessage,-	sendCommand, runServerCommand,-	findPath,-	processRequest, processClient, processClientSocket,-	module HsDev.Server.Types-	) where--import Control.Concurrent.Async-import Control.Lens (set, view)-import Control.Monad-import Control.Monad.Catch (bracket, bracket_)-import Data.Aeson hiding (Result, Error)-import qualified Data.Aeson as A-import Data.Aeson.Encode.Pretty-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Maybe-import Network.Socket hiding (connect)-import qualified Network.Socket as Net hiding (send)-import System.Directory-import System.Exit-import System.IO-import qualified System.Log.Simple as Log--import Text.Format ((~~), (~%))-import Text.Format.Colored (coloredLine)--import HsDev.Server.Base-import HsDev.Server.Types-import HsDev.Error-import HsDev.Util-import HsDev.Version--#if mingw32_HOST_OS-import Data.List-import HsDev.Tools.Base (runTool_)-import System.Environment-import System.Win32.PowerShell (escape, quote, quoteDouble)-#else-import Control.Exception (SomeException, handle)-import System.Posix.Process-import System.Posix.IO-#endif--sendCommand :: ClientOpts -> Bool -> Command -> (Notification -> IO a) -> IO Result-sendCommand copts noFile c onNotification = do-	asyncAct <- async sendReceive-	res <- waitCatch asyncAct-	case res of-		Left e -> return $ Error $ OtherError (show e)-		Right r -> return r-	where-		sendReceive = do-			curDir <- getCurrentDirectory-			input <- if clientStdin copts-				then Just <$> L.getContents-				else return $ toUtf8 <$> Nothing -- arg "data" copts-			let-				parseData :: L.ByteString -> IO Value-				parseData cts = case eitherDecode cts of-					Left err -> putStrLn ("Invalid data: " ++ err) >> exitFailure-					Right v -> return v-			_ <- traverse parseData input -- FIXME: Not used!--			s <- makeSocket (clientPort copts)-			addr' <- inet_addr "127.0.0.1"-			Net.connect s (sockAddr (clientPort copts) addr')-			bracket (socketToHandle s ReadWriteMode) hClose $ \h -> do-				L.hPutStrLn h $ encode $ Message Nothing $ Request c curDir noFile (clientTimeout copts) (clientSilent copts)-				hFlush h-				peekResponse h--		peekResponse h = do-			resp <- hGetLineBS h-			parseResponse h resp--		parseResponse h str = case eitherDecode str of-			Left e -> return $ Error $ ResponseError ("can't parse: {}" ~~ e) (fromUtf8 str)-			Right (Message _ r) -> do-				Response r' <- unMmap r-				case r' of-					Left n -> onNotification n >> peekResponse h-					Right res -> return res--runServerCommand :: ServerCommand -> IO ()-runServerCommand Version = putStrLn $cabalVersion-runServerCommand (Start sopts) = do-#if mingw32_HOST_OS-	let-		args = "run" : serverOptsArgs sopts-	myExe <- getExecutablePath-	curDir <- getCurrentDirectory-	let-		-- one escape for start-process and other for callable process-		-- seems, that start-process just concats arguments into one string-		-- start-process foo 'bar baz' ⇒ foo bar baz -- not expected-		-- start-process foo '"bar baz"' ⇒ foo "bar baz" -- ok-		biescape = escape quote . escape quoteDouble-		script = "try {{ start-process {process} {args} -WindowStyle Hidden -WorkingDirectory {dir} }} catch {{ $_.Exception, $_.InvocationInfo.Line }}"-			~~ ("process" ~% escape quote myExe)-			~~ ("args" ~% intercalate ", " (map biescape args))-			~~ ("dir" ~% escape quote curDir)-	_ <- runTool_ "powershell" [-		"-NoProfile",-		"-Command",-		script]-	putStrLn $ "Server started at port {}" ~~ serverPort sopts-#else-	let-		forkError :: SomeException -> IO ()-		forkError e  = putStrLn $ "Failed to start server: {}" ~~ show e--		proxy :: IO ()-		proxy = do-			_ <- createSession-			_ <- forkProcess serverAction-			exitImmediately ExitSuccess--		serverAction :: IO ()-		serverAction = do-			mapM_ closeFd [stdInput, stdOutput, stdError]-			nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags-			mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError]-			closeFd nullFd-			runServerCommand (Run sopts)--	handle forkError $ do-		_ <- forkProcess proxy-		putStrLn $ "Server started at port {}" ~~ serverPort sopts-#endif-runServerCommand (Run sopts) = runServer sopts $ bracket_ (setupServer sopts) (shutdownServer sopts) $ return ()-runServerCommand (Stop copts) = runServerCommand (Remote copts False Exit)-runServerCommand (Connect copts) = do-	curDir <- getCurrentDirectory-	s <- makeSocket $ clientPort copts-	addr' <- inet_addr "127.0.0.1"-	Net.connect s $ sockAddr (clientPort copts) addr'-	bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do-		input' <- hGetLineBS stdin-		case decodeMsg input' of-			Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError $ OtherError "invalid command") em-			Right m -> do-				L.hPutStrLn h $ encodeMessage $ set msg (Message (Just $ show i) $ Request (view msg m) curDir True (clientTimeout copts) False) m-				waitResp h-	where-		waitResp h = do-			resp <- hGetLineBS h-			parseResp h resp--		parseResp h str = case decodeMessage str of-			Left em -> putStrLn $ "Can't decode response: {}" ~~ view msg em-			Right m -> do-				Response r' <- unMmap $ view (msg . message) m-				putStrLn $ "{id}: {response}"-					~~ ("id" ~% fromMaybe "_" (view (msg . messageId) m))-					~~ ("response" ~% fromUtf8 (encodeMsg $ set msg (Response r') m))-				case unResponse (view (msg . message) m) of-					Left _ -> waitResp h-					_ -> return ()-runServerCommand (Remote copts noFile c@(Listen _)) = sendCommand copts noFile c printLog >>= noResult where-	printLog :: Notification -> IO ()-	printLog (Notification v) = case fromJSON v of-		A.Error _ -> putStrLn "incorrect notification"-		A.Success m -> coloredLine . Log.text $ m-	noResult :: Result -> IO ()-	noResult _ = return ()-runServerCommand (Remote copts noFile c) = sendCommand copts noFile c printValue >>= printResult where-	printValue :: ToJSON a => a -> IO ()-	printValue = L.putStrLn . encodeValue-	printResult :: Result -> IO ()-	printResult (Result r) = printValue r-	printResult e = printValue e-	encodeValue :: ToJSON a => a -> L.ByteString-	encodeValue = if clientPretty copts then encodePretty else encode+{-# LANGUAGE OverloadedStrings, CPP, LambdaCase, TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Server.Commands (
+	ServerCommand(..), ServerOpts(..), ClientOpts(..),
+	Request(..),
+	Msg, isLisp, msg, jsonMsg, lispMsg, encodeMessage, decodeMessage,
+	sendCommand, runServerCommand,
+	findPath,
+	processRequest, processClient, processClientSocket,
+	module HsDev.Server.Types
+	) where
+
+import Control.Concurrent.Async
+import Control.Lens (set, view)
+import Control.Monad
+import Control.Monad.Catch (bracket, bracket_)
+import Data.Aeson hiding (Result, Error)
+import qualified Data.Aeson as A
+import Data.Aeson.Encode.Pretty
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Maybe
+import Network.Socket hiding (connect)
+import qualified Network.Socket as Net hiding (send)
+import System.Directory
+import System.Exit
+import System.IO
+import qualified System.Log.Simple as Log
+
+import Text.Format ((~~), (~%))
+import Text.Format.Colored (coloredLine)
+
+import HsDev.Server.Base
+import HsDev.Server.Types
+import HsDev.Error
+import HsDev.Util
+import HsDev.Version
+
+#if mingw32_HOST_OS
+import Data.List
+import HsDev.Tools.Base (runTool_)
+import System.Environment
+import System.Win32.PowerShell (escape, quote, quoteDouble)
+#else
+import Control.Exception (SomeException, handle)
+import System.Posix.Process
+import System.Posix.IO
+#endif
+
+sendCommand :: ClientOpts -> Bool -> Command -> (Notification -> IO a) -> IO Result
+sendCommand copts noFile c onNotification = do
+	asyncAct <- async sendReceive
+	res <- waitCatch asyncAct
+	case res of
+		Left e -> return $ Error $ OtherError (show e)
+		Right r -> return r
+	where
+		sendReceive = do
+			curDir <- getCurrentDirectory
+			input <- if clientStdin copts
+				then Just <$> L.getContents
+				else return $ toUtf8 <$> Nothing -- arg "data" copts
+			let
+				parseData :: L.ByteString -> IO Value
+				parseData cts = case eitherDecode cts of
+					Left err -> putStrLn ("Invalid data: " ++ err) >> exitFailure
+					Right v -> return v
+			_ <- traverse parseData input -- FIXME: Not used!
+
+			s <- makeSocket (clientPort copts)
+			addr' <- inet_addr "127.0.0.1"
+			Net.connect s (sockAddr (clientPort copts) addr')
+			bracket (socketToHandle s ReadWriteMode) hClose $ \h -> do
+				L.hPutStrLn h $ encode $ Message Nothing $ Request c curDir noFile (clientTimeout copts) (clientSilent copts)
+				hFlush h
+				peekResponse h
+
+		peekResponse h = do
+			resp <- hGetLineBS h
+			parseResponse h resp
+
+		parseResponse h str = case eitherDecode str of
+			Left e -> return $ Error $ ResponseError ("can't parse: {}" ~~ e) (fromUtf8 str)
+			Right (Message _ r) -> do
+				Response r' <- unMmap r
+				case r' of
+					Left n -> onNotification n >> peekResponse h
+					Right res -> return res
+
+runServerCommand :: ServerCommand -> IO ()
+runServerCommand Version = putStrLn $cabalVersion
+runServerCommand (Start sopts) = do
+#if mingw32_HOST_OS
+	let
+		args = "run" : serverOptsArgs sopts
+	myExe <- getExecutablePath
+	curDir <- getCurrentDirectory
+	let
+		-- one escape for start-process and other for callable process
+		-- seems, that start-process just concats arguments into one string
+		-- start-process foo 'bar baz' ⇒ foo bar baz -- not expected
+		-- start-process foo '"bar baz"' ⇒ foo "bar baz" -- ok
+		biescape = escape quote . escape quoteDouble
+		script = "try {{ start-process {process} {args} -WindowStyle Hidden -WorkingDirectory {dir} }} catch {{ $_.Exception, $_.InvocationInfo.Line }}"
+			~~ ("process" ~% escape quote myExe)
+			~~ ("args" ~% intercalate ", " (map biescape args))
+			~~ ("dir" ~% escape quote curDir)
+	_ <- runTool_ "powershell" [
+		"-NoProfile",
+		"-Command",
+		script]
+	putStrLn $ "Server started at port {}" ~~ serverPort sopts
+#else
+	let
+		forkError :: SomeException -> IO ()
+		forkError e  = putStrLn $ "Failed to start server: {}" ~~ show e
+
+		proxy :: IO ()
+		proxy = do
+			_ <- createSession
+			_ <- forkProcess serverAction
+			exitImmediately ExitSuccess
+
+		serverAction :: IO ()
+		serverAction = do
+			mapM_ closeFd [stdInput, stdOutput, stdError]
+			nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
+			mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError]
+			closeFd nullFd
+			runServerCommand (Run sopts)
+
+	handle forkError $ do
+		_ <- forkProcess proxy
+		putStrLn $ "Server started at port {}" ~~ serverPort sopts
+#endif
+runServerCommand (Run sopts) = runServer sopts $ bracket_ (setupServer sopts) (shutdownServer sopts) $ return ()
+runServerCommand (Stop copts) = runServerCommand (Remote copts False Exit)
+runServerCommand (Connect copts) = do
+	curDir <- getCurrentDirectory
+	s <- makeSocket $ clientPort copts
+	addr' <- inet_addr "127.0.0.1"
+	Net.connect s $ sockAddr (clientPort copts) addr'
+	bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do
+		input' <- hGetLineBS stdin
+		case decodeMsg input' of
+			Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError $ OtherError "invalid command") em
+			Right m -> do
+				L.hPutStrLn h $ encodeMessage $ set msg (Message (Just $ show i) $ Request (view msg m) curDir True (clientTimeout copts) False) m
+				waitResp h
+	where
+		waitResp h = do
+			resp <- hGetLineBS h
+			parseResp h resp
+
+		parseResp h str = case decodeMessage str of
+			Left em -> putStrLn $ "Can't decode response: {}" ~~ view msg em
+			Right m -> do
+				Response r' <- unMmap $ view (msg . message) m
+				putStrLn $ "{id}: {response}"
+					~~ ("id" ~% fromMaybe "_" (view (msg . messageId) m))
+					~~ ("response" ~% fromUtf8 (encodeMsg $ set msg (Response r') m))
+				case unResponse (view (msg . message) m) of
+					Left _ -> waitResp h
+					_ -> return ()
+runServerCommand (Remote copts noFile c@(Listen _)) = sendCommand copts noFile c printLog >>= noResult where
+	printLog :: Notification -> IO ()
+	printLog (Notification v) = case fromJSON v of
+		A.Error _ -> putStrLn "incorrect notification"
+		A.Success m -> coloredLine . Log.text $ m
+	noResult :: Result -> IO ()
+	noResult _ = return ()
+runServerCommand (Remote copts noFile c) = sendCommand copts noFile c printValue >>= printResult where
+	printValue :: ToJSON a => a -> IO ()
+	printValue = L.putStrLn . encodeValue
+	printResult :: Result -> IO ()
+	printResult (Result r) = printValue r
+	printResult e = printValue e
+	encodeValue :: ToJSON a => a -> L.ByteString
+	encodeValue = if clientPretty copts then encodePretty else encode
src/HsDev/Server/Message.hs view
@@ -1,118 +1,118 @@-{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-}--module HsDev.Server.Message (-	Message(..), messageId, message,-	messagesById,-	Notification(..), Result(..), ResultPart(..),-	Response(..), isNotification, result, responseError,-	groupResponses,-	decodeMessage, encodeMessage,--	module HsDev.Server.Message.Lisp-	) where--import Control.Applicative-import Control.Lens (makeLenses)-import Control.Monad (join)-import Data.Aeson hiding (Error, Result)-import Data.Either (lefts, isRight)-import Data.List (unfoldr)-import Data.ByteString.Lazy.Char8 (ByteString)--import HsDev.Types-import HsDev.Util ((.::), (.::?), objectUnion)-import HsDev.Server.Message.Lisp---- | Message with id to link request and response-data Message a = Message {-	_messageId :: Maybe String,-	_message :: a }-		deriving (Eq, Ord, Show, Functor)--makeLenses ''Message--instance ToJSON a => ToJSON (Message a) where-	toJSON (Message i m) = object ["id" .= i] `objectUnion` toJSON m--instance FromJSON a => FromJSON (Message a) where-	parseJSON = withObject "message" $ \v ->-		Message <$> fmap join (v .::? "id") <*> parseJSON (Object v)--instance Foldable Message where-	foldMap f (Message _ m) = f m--instance Traversable Message where-	traverse f (Message i m) = Message i <$> f m---- | Get messages by id-messagesById :: Maybe String -> [Message a] -> [a]-messagesById i = map _message . filter ((== i) . _messageId)---- | Notification from server-newtype Notification = Notification Value deriving (Eq, Show)--instance ToJSON Notification where-	toJSON (Notification v) = object ["notify" .= v]--instance FromJSON Notification where-	parseJSON = withObject "notification" $ \v -> Notification <$> v .:: "notify"---- | Result from server-data Result =-	Result Value |-	-- ^ Result-	Error HsDevError-	-- ^ Error-		deriving (Show)--instance ToJSON Result where-	toJSON (Result r) = object ["result" .= r]-	toJSON (Error e) = toJSON e--instance FromJSON Result where-	parseJSON j = (withObject "result" (\v -> (Result <$> v .:: "result")) j) <|> (Error <$> parseJSON j)---- | Part of result list, returns via notification-newtype ResultPart = ResultPart Value--instance ToJSON ResultPart where-	toJSON (ResultPart r) = object ["result-part" .= r]--instance FromJSON ResultPart where-	parseJSON = withObject "result-part" $ \v -> ResultPart <$> v .:: "result-part"--newtype Response = Response { unResponse :: Either Notification Result } deriving (Show)--isNotification :: Response -> Bool-isNotification = either (const True) (const False) . unResponse--result :: ToJSON a => a -> Response-result = Response . Right . Result . toJSON--responseError :: HsDevError -> Response-responseError = Response . Right . Error--instance ToJSON Response where-	toJSON (Response (Left n)) = toJSON n-	toJSON (Response (Right r)) = toJSON r--instance FromJSON Response where-	parseJSON v = Response <$> ((Left <$> parseJSON v) <|> (Right <$> parseJSON v))--groupResponses :: [Response] -> [([Notification], Result)]-groupResponses = unfoldr break' where-	break' :: [Response] -> Maybe (([Notification], Result), [Response])-	break' [] = Nothing-	break' cs =  Just ((lefts (map unResponse ns), r), drop 1 cs') where-		(ns, cs') = break (isRight . unResponse) cs-		r = case cs' of-			(Response (Right r') : _) -> r'-			[] -> Error $ OtherError "groupResponses: no result"-			_ -> error "groupResponses: impossible happened"---- | Decode lisp or json request-decodeMessage :: FromJSON a => ByteString -> Either (Msg String) (Msg (Message a))-decodeMessage = decodeMsg--encodeMessage :: ToJSON a => Msg (Message a) -> ByteString-encodeMessage = encodeMsg+{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-}
+
+module HsDev.Server.Message (
+	Message(..), messageId, message,
+	messagesById,
+	Notification(..), Result(..), ResultPart(..),
+	Response(..), isNotification, result, responseError,
+	groupResponses,
+	decodeMessage, encodeMessage,
+
+	module HsDev.Server.Message.Lisp
+	) where
+
+import Control.Applicative
+import Control.Lens (makeLenses)
+import Control.Monad (join)
+import Data.Aeson hiding (Error, Result)
+import Data.Either (lefts, isRight)
+import Data.List (unfoldr)
+import Data.ByteString.Lazy.Char8 (ByteString)
+
+import HsDev.Types
+import HsDev.Util ((.::), (.::?), objectUnion)
+import HsDev.Server.Message.Lisp
+
+-- | Message with id to link request and response
+data Message a = Message {
+	_messageId :: Maybe String,
+	_message :: a }
+		deriving (Eq, Ord, Show, Functor)
+
+makeLenses ''Message
+
+instance ToJSON a => ToJSON (Message a) where
+	toJSON (Message i m) = object ["id" .= i] `objectUnion` toJSON m
+
+instance FromJSON a => FromJSON (Message a) where
+	parseJSON = withObject "message" $ \v ->
+		Message <$> fmap join (v .::? "id") <*> parseJSON (Object v)
+
+instance Foldable Message where
+	foldMap f (Message _ m) = f m
+
+instance Traversable Message where
+	traverse f (Message i m) = Message i <$> f m
+
+-- | Get messages by id
+messagesById :: Maybe String -> [Message a] -> [a]
+messagesById i = map _message . filter ((== i) . _messageId)
+
+-- | Notification from server
+newtype Notification = Notification Value deriving (Eq, Show)
+
+instance ToJSON Notification where
+	toJSON (Notification v) = object ["notify" .= v]
+
+instance FromJSON Notification where
+	parseJSON = withObject "notification" $ \v -> Notification <$> v .:: "notify"
+
+-- | Result from server
+data Result =
+	Result Value |
+	-- ^ Result
+	Error HsDevError
+	-- ^ Error
+		deriving (Show)
+
+instance ToJSON Result where
+	toJSON (Result r) = object ["result" .= r]
+	toJSON (Error e) = toJSON e
+
+instance FromJSON Result where
+	parseJSON j = (withObject "result" (\v -> (Result <$> v .:: "result")) j) <|> (Error <$> parseJSON j)
+
+-- | Part of result list, returns via notification
+newtype ResultPart = ResultPart Value
+
+instance ToJSON ResultPart where
+	toJSON (ResultPart r) = object ["result-part" .= r]
+
+instance FromJSON ResultPart where
+	parseJSON = withObject "result-part" $ \v -> ResultPart <$> v .:: "result-part"
+
+newtype Response = Response { unResponse :: Either Notification Result } deriving (Show)
+
+isNotification :: Response -> Bool
+isNotification = either (const True) (const False) . unResponse
+
+result :: ToJSON a => a -> Response
+result = Response . Right . Result . toJSON
+
+responseError :: HsDevError -> Response
+responseError = Response . Right . Error
+
+instance ToJSON Response where
+	toJSON (Response (Left n)) = toJSON n
+	toJSON (Response (Right r)) = toJSON r
+
+instance FromJSON Response where
+	parseJSON v = Response <$> ((Left <$> parseJSON v) <|> (Right <$> parseJSON v))
+
+groupResponses :: [Response] -> [([Notification], Result)]
+groupResponses = unfoldr break' where
+	break' :: [Response] -> Maybe (([Notification], Result), [Response])
+	break' [] = Nothing
+	break' cs =  Just ((lefts (map unResponse ns), r), drop 1 cs') where
+		(ns, cs') = break (isRight . unResponse) cs
+		r = case cs' of
+			(Response (Right r') : _) -> r'
+			[] -> Error $ OtherError "groupResponses: no result"
+			_ -> error "groupResponses: impossible happened"
+
+-- | Decode lisp or json request
+decodeMessage :: FromJSON a => ByteString -> Either (Msg String) (Msg (Message a))
+decodeMessage = decodeMsg
+
+encodeMessage :: ToJSON a => Msg (Message a) -> ByteString
+encodeMessage = encodeMsg
src/HsDev/Server/Message/Lisp.hs view
@@ -1,47 +1,47 @@-module HsDev.Server.Message.Lisp (-	Msg,-	isLisp, msg,-	jsonMsg, lispMsg,--	decodeMsg, encodeMsg-	) where--import Control.Applicative-import Control.Lens-import Control.Monad-import Data.Aeson-import Data.Maybe-import Data.ByteString.Lazy.Char8 (ByteString)--import Data.Lisp--type Msg a = (Bool, a)--isLisp :: Lens' (Msg a) Bool-isLisp = _1--msg :: Lens (Msg a) (Msg b) a b-msg = _2--jsonMsg :: a -> Msg a-jsonMsg = (,) False--lispMsg :: a -> Msg a-lispMsg = (,) True---- | Decode lisp or json-decodeMsg :: FromJSON a => ByteString -> Either (Msg String) (Msg a)-decodeMsg bstr = over _Left decodeType' decodeMsg' where-	decodeType'-		| isLisp' = lispMsg-		| otherwise = jsonMsg-	decodeMsg' = (lispMsg <$> decodeLisp bstr) <|> (jsonMsg <$> eitherDecode bstr)-	isLisp' = fromMaybe False $ mplus (try' eitherDecode False) (try' decodeLisp True)-	try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool-	try' f l = either (const Nothing) (const $ Just l) $ f bstr---- | Encode lisp or json-encodeMsg :: ToJSON a => Msg a -> ByteString-encodeMsg m-	| view isLisp m = encodeLisp $ view msg m-	| otherwise = encode $ view msg m+module HsDev.Server.Message.Lisp (
+	Msg,
+	isLisp, msg,
+	jsonMsg, lispMsg,
+
+	decodeMsg, encodeMsg
+	) where
+
+import Control.Applicative
+import Control.Lens
+import Control.Monad
+import Data.Aeson
+import Data.Maybe
+import Data.ByteString.Lazy.Char8 (ByteString)
+
+import Data.Lisp
+
+type Msg a = (Bool, a)
+
+isLisp :: Lens' (Msg a) Bool
+isLisp = _1
+
+msg :: Lens (Msg a) (Msg b) a b
+msg = _2
+
+jsonMsg :: a -> Msg a
+jsonMsg = (,) False
+
+lispMsg :: a -> Msg a
+lispMsg = (,) True
+
+-- | Decode lisp or json
+decodeMsg :: FromJSON a => ByteString -> Either (Msg String) (Msg a)
+decodeMsg bstr = over _Left decodeType' decodeMsg' where
+	decodeType'
+		| isLisp' = lispMsg
+		| otherwise = jsonMsg
+	decodeMsg' = (lispMsg <$> decodeLisp bstr) <|> (jsonMsg <$> eitherDecode bstr)
+	isLisp' = fromMaybe False $ mplus (try' eitherDecode False) (try' decodeLisp True)
+	try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool
+	try' f l = either (const Nothing) (const $ Just l) $ f bstr
+
+-- | Encode lisp or json
+encodeMsg :: ToJSON a => Msg a -> ByteString
+encodeMsg m
+	| view isLisp m = encodeLisp $ view msg m
+	| otherwise = encode $ view msg m
src/HsDev/Server/Types.hs view
@@ -1,845 +1,845 @@-{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Server.Types (-	ServerMonadBase,-	SessionLog(..), Session(..), SessionMonad(..), askSession, ServerM(..),-	CommandOptions(..), CommandMonad(..), askOptions, ClientM(..),-	withSession, serverListen, serverSetLogLevel, serverWait, serverWaitClients,-	serverSqlDatabase, openSqlConnection, closeSqlConnection, withSqlConnection, withSqlTransaction, serverSetFileContents,-	inSessionGhc, inSessionUpdater, postSessionUpdater, serverExit, commandRoot, commandNotify, commandLink, commandHold,-	ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..),--	Command(..),-	FileSource(..), TargetFilter(..), SearchQuery(..), SearchType(..),-	FromCmd(..),-	) where--import Control.Applicative-import Control.Concurrent.Async (Async)-import qualified Control.Concurrent.FiniteChan as F-import Control.Lens (view, set)-import Control.Monad.Base-import Control.Monad.Catch-import Control.Monad.Except-import Control.Monad.Morph-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.Trans.Control-import Data.Aeson hiding (Result(..), Error)-import qualified Data.Aeson.Types as A-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Default-import Data.Maybe (fromMaybe)-import Data.Foldable (asum)-import Data.Text (Text)-import Data.String (fromString)-import qualified Database.SQLite.Simple as SQL-import Options.Applicative-import System.Log.Simple as Log--import Control.Concurrent.Worker-import Data.LookupTable-import System.Directory.Paths-import Text.Format (Formattable(..))--import HsDev.Error (hsdevError)-import HsDev.Inspect.Types-import HsDev.Server.Message-import HsDev.Watcher.Types (Watcher)-import HsDev.Tools.Ghc.Worker (GhcWorker, GhcM)-import HsDev.Tools.Types (Note, OutputMessage)-import HsDev.Tools.AutoFix (Refact)-import HsDev.Types (HsDevError(..))-import HsDev.Util--#if mingw32_HOST_OS-import System.Win32.FileMapping.NamePool (Pool)-#endif--type ServerMonadBase m = (MonadIO m, MonadMask m, MonadBaseControl IO m, Alternative m, MonadPlus m)--data SessionLog = SessionLog {-	sessionLogger :: Log,-	sessionListenLog :: IO [Log.Message],-	sessionLogWait :: IO () }--data Session = Session {-	sessionSqlDatabase :: SQL.Connection,-	sessionSqlPath :: String,-	sessionLog :: SessionLog,-	sessionWatcher :: Watcher,-	sessionFileContents :: Path -> Maybe Text -> IO (),-#if mingw32_HOST_OS-	sessionMmapPool :: Maybe Pool,-#endif-	sessionGhc :: GhcWorker,-	sessionUpdater :: Worker (ServerM IO),-	sessionResolveEnvironment :: LookupTable (Maybe Path) (Environment, FixitiesTable),-	sessionExit :: IO (),-	sessionWait :: IO (),-	sessionClients :: F.Chan (IO ()),-	sessionDefines :: [(String, String)] }--class (ServerMonadBase m, MonadLog m) => SessionMonad m where-	getSession :: m Session-	localSession :: (Session -> Session) -> m a -> m a--askSession :: SessionMonad m => (Session -> a) -> m a-askSession f = liftM f getSession--newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a }-	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch, MonadMask)--instance (MonadIO m, MonadMask m) => MonadLog (ServerM m) where-	askLog = ServerM $ asks (sessionLogger . sessionLog)-	localLog fn = ServerM . local setLog' . runServerM where-		setLog' sess = sess { sessionLog = (sessionLog sess) { sessionLogger = fn (sessionLogger (sessionLog sess)) } }--instance ServerMonadBase m => SessionMonad (ServerM m) where-	getSession = ask-	localSession = local--instance MonadBase b m => MonadBase b (ServerM m) where-	liftBase = ServerM . liftBase--instance MonadBaseControl b m => MonadBaseControl b (ServerM m) where-	type StM (ServerM m) a = StM (ReaderT Session m) a-	liftBaseWith f = ServerM $ liftBaseWith (\f' -> f (f' . runServerM))-	restoreM = ServerM . restoreM--instance MFunctor ServerM where-	hoist fn = ServerM . hoist fn . runServerM--instance SessionMonad m => SessionMonad (ReaderT r m) where-	getSession = lift getSession-	localSession = mapReaderT . localSession--instance (SessionMonad m, Monoid w) => SessionMonad (WriterT w m) where-	getSession = lift getSession-	localSession = mapWriterT . localSession--instance SessionMonad m => SessionMonad (StateT s m) where-	getSession = lift getSession-	localSession = mapStateT . localSession--data CommandOptions = CommandOptions {-	commandOptionsRoot :: FilePath,-	commandOptionsNotify :: Notification -> IO (),-	commandOptionsLink :: IO (),-	commandOptionsHold :: IO () }--instance Default CommandOptions where-	def = CommandOptions "." (const $ return ()) (return ()) (return ())--class (SessionMonad m, MonadPlus m) => CommandMonad m where-	getOptions :: m CommandOptions--askOptions :: CommandMonad m => (CommandOptions -> a) -> m a-askOptions f = liftM f getOptions--newtype ClientM m a = ClientM { runClientM :: ServerM (ReaderT CommandOptions m) a }-	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask)--instance MonadTrans ClientM where-	lift = ClientM . lift . lift--instance (MonadIO m, MonadMask m) => MonadLog (ClientM m) where-	askLog = ClientM askLog-	localLog fn = ClientM . localLog fn . runClientM--instance ServerMonadBase m => SessionMonad (ClientM m) where-	getSession = ClientM getSession-	localSession fn = ClientM . localSession fn . runClientM--instance ServerMonadBase m => CommandMonad (ClientM m) where-	getOptions = ClientM $ lift ask--instance MonadBase b m => MonadBase b (ClientM m) where-	liftBase = ClientM . liftBase--instance MonadBaseControl b m => MonadBaseControl b (ClientM m) where-	type StM (ClientM m) a = StM (ServerM (ReaderT CommandOptions m)) a-	liftBaseWith f = ClientM $ liftBaseWith (\f' -> f (f' . runClientM))-	restoreM = ClientM . restoreM--instance MFunctor ClientM where-	hoist fn = ClientM . hoist (hoist fn) . runClientM--instance CommandMonad m => CommandMonad (ReaderT r m) where-	getOptions = lift getOptions--instance (CommandMonad m, Monoid w) => CommandMonad (WriterT w m) where-	getOptions = lift getOptions--instance CommandMonad m => CommandMonad (StateT s m) where-	getOptions = lift getOptions---- | Run action on session-withSession :: Session -> ServerM m a -> m a-withSession s act = runReaderT (runServerM act) s---- | Listen server's log-serverListen :: SessionMonad m => m [Log.Message]-serverListen = join . liftM liftIO $ askSession (sessionListenLog . sessionLog)---- | Set server's log config-serverSetLogLevel :: SessionMonad m => Level -> m Level-serverSetLogLevel lev = do-	l <- askSession (sessionLogger . sessionLog)-	cfg <- updateLogConfig l (set (componentCfg "") (Just lev))-	return $ fromMaybe def $ view (componentCfg "") cfg---- | Wait for server-serverWait :: SessionMonad m => m ()-serverWait = join . liftM liftIO $ askSession sessionWait---- | Wait while clients disconnects-serverWaitClients :: SessionMonad m => m ()-serverWaitClients = do-	clientChan <- askSession sessionClients-	liftIO (F.stopChan clientChan) >>= sequence_ . map liftIO---- | Get sql connection-serverSqlDatabase :: SessionMonad m => m SQL.Connection-serverSqlDatabase = askSession sessionSqlDatabase---- | Open new sql connection-openSqlConnection :: SessionMonad m => m SQL.Connection-openSqlConnection = do-	p <- askSession sessionSqlPath-	-- FIXME: There's `new` function in HsDev's SQLite module-	liftIO $ do-		conn <- SQL.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---- | Close sql connection-closeSqlConnection :: SessionMonad m => SQL.Connection -> m ()-closeSqlConnection = liftIO . SQL.close---- | Locally opens new connection, updating @Session@-withSqlConnection :: SessionMonad m => m a -> m a-withSqlConnection act = bracket openSqlConnection closeSqlConnection $ \conn ->-	localSession (\sess -> sess { sessionSqlDatabase = conn }) act---- | With sql transaction-withSqlTransaction :: SessionMonad m => ServerM IO a -> m a-withSqlTransaction fn = do-	conn <- serverSqlDatabase-	sess <- getSession-	liftIO $ SQL.withTransaction conn $ withSession sess fn---- | Set custom file contents-serverSetFileContents :: SessionMonad m => Path -> Maybe Text -> m ()-serverSetFileContents fpath mcts = do-	setCts <- askSession sessionFileContents-	liftIO $ setCts fpath mcts---- | In ghc session-inSessionGhc :: SessionMonad m => GhcM a -> m a-inSessionGhc act = do-	ghcw <- askSession sessionGhc-	inWorkerWith (hsdevError . GhcError . displayException) ghcw act---- | In updater-inSessionUpdater :: SessionMonad m => ServerM IO a -> m a-inSessionUpdater act = do-	uw <- askSession sessionUpdater-	inWorkerWith (hsdevError . OtherError . displayException) uw act---- | Post to updater and return-postSessionUpdater :: SessionMonad m => ServerM IO a -> m (Async a)-postSessionUpdater act = do-	uw <- askSession sessionUpdater-	liftIO $ sendTask uw act---- | Exit session-serverExit :: SessionMonad m => m ()-serverExit = join . liftM liftIO $ askSession sessionExit--commandRoot :: CommandMonad m => m FilePath-commandRoot = askOptions commandOptionsRoot--commandNotify :: CommandMonad m => Notification -> m ()-commandNotify n = join . liftM liftIO $ askOptions commandOptionsNotify <*> pure n--commandLink :: CommandMonad m => m ()-commandLink = join . liftM liftIO $ askOptions commandOptionsLink--commandHold :: CommandMonad m => m ()-commandHold = join . liftM liftIO $ askOptions commandOptionsHold---- | Server control command-data ServerCommand =-	Version |-	Start ServerOpts |-	Run ServerOpts |-	Stop ClientOpts |-	Connect ClientOpts |-	Remote ClientOpts Bool Command-		deriving (Show)--data ConnectionPort = NetworkPort Int | UnixPort String deriving (Eq, Read)--instance Default ConnectionPort where-	def = NetworkPort 4567--instance Show ConnectionPort where-	show (NetworkPort p) = show p-	show (UnixPort s) = "unix " ++ s--instance Formattable ConnectionPort---- | Server options-data ServerOpts = ServerOpts {-	serverPort :: ConnectionPort,-	serverTimeout :: Int,-	serverLog :: Maybe FilePath,-	serverLogLevel :: String,-	serverLogNoColor :: Bool,-	serverDbFile :: Maybe FilePath,-	serverSilent :: Bool }-		deriving (Show)--instance Default ServerOpts where-	def = ServerOpts def 0 Nothing "info" False Nothing False---- | Silent server with no connection, useful for ghci-silentOpts :: ServerOpts-silentOpts = def { serverSilent = True }---- | Client options-data ClientOpts = ClientOpts {-	clientPort :: ConnectionPort,-	clientPretty :: Bool,-	clientStdin :: Bool,-	clientTimeout :: Int,-	clientSilent :: Bool }-		deriving (Show)--instance Default ClientOpts where-	def = ClientOpts def False False 0 False--instance FromCmd ServerCommand where-	cmdP = serv <|> remote where-		serv = subparser $ mconcat [-			cmd "version" "hsdev version" (pure Version),-			cmd "start" "start remote server" (Start <$> cmdP),-			cmd "run" "run server" (Run <$> cmdP),-			cmd "stop" "stop remote server" (Stop <$> cmdP),-			cmd "connect" "connect to send commands directly" (Connect <$> cmdP)]-		remote = Remote <$> cmdP <*> noFileFlag <*> cmdP--instance FromCmd ServerOpts where-	cmdP = ServerOpts <$>-		(connectionArg <|> pure (serverPort def)) <*>-		(timeoutArg <|> pure (serverTimeout def)) <*>-		optional logArg <*>-		(logLevelArg <|> pure (serverLogLevel def)) <*>-		noColorFlag <*>-		optional dbFileArg <*>-		serverSilentFlag--instance FromCmd ClientOpts where-	cmdP = ClientOpts <$>-		(connectionArg <|> pure (clientPort def)) <*>-		prettyFlag <*>-		stdinFlag <*>-		(timeoutArg <|> pure (clientTimeout def)) <*>-		silentFlag--portArg :: Parser ConnectionPort-connectionArg :: Parser ConnectionPort-timeoutArg :: Parser Int-logArg :: Parser FilePath-logLevelArg :: Parser String-noColorFlag :: Parser Bool-noFileFlag :: Parser Bool-prettyFlag :: Parser Bool-serverSilentFlag :: Parser Bool-stdinFlag :: Parser Bool-silentFlag :: Parser Bool-dbFileArg :: Parser FilePath--portArg = NetworkPort <$> option auto (long "port" <> metavar "number" <> help "connection port")-#if mingw32_HOST_OS-connectionArg = portArg-#else-unixArg :: Parser ConnectionPort-unixArg = UnixPort <$> strOption (long "unix" <> metavar "name" <> help "unix connection port")-connectionArg = portArg <|> unixArg-#endif-timeoutArg = option auto (long "timeout" <> metavar "msec" <> help "query timeout")-logArg = strOption (long "log" <> short 'l' <> metavar "file" <> help "log file")-logLevelArg = strOption (long "log-level" <> metavar "level" <> help "log level: trace/debug/info/warning/error/fatal")-noColorFlag = switch (long "no-color" <> help "don't use colorized log output")-noFileFlag = switch (long "no-file" <> help "don't use mmap files")-prettyFlag = switch (long "pretty" <> help "pretty json output")-serverSilentFlag = switch (long "silent" <> help "no stdout/stderr")-stdinFlag = switch (long "stdin" <> help "pass data to stdin")-silentFlag = switch (long "silent" <> help "supress notifications")-dbFileArg = strOption (long "db" <> metavar "path" <> help "path to sql database")--serverOptsArgs :: ServerOpts -> [String]-serverOptsArgs sopts = concat [-	portArgs (serverPort sopts),-	["--timeout", show $ serverTimeout sopts],-	marg "--log" (serverLog sopts),-	["--log-level", serverLogLevel sopts],-	marg "--db" (serverDbFile sopts),-	["--silent" | serverSilent sopts]]-	where-		marg :: String -> Maybe String -> [String]-		marg n (Just v) = [n, v]-		marg _ _ = []-		portArgs :: ConnectionPort -> [String]-		portArgs (NetworkPort n) = ["--port", show n]-		portArgs (UnixPort s) = ["--unix", s]--data Request = Request {-	requestCommand :: Command,-	requestDirectory :: FilePath,-	requestNoFile :: Bool,-	requestTimeout :: Int,-	requestSilent :: Bool }-		deriving (Show)--instance ToJSON Request where-	toJSON (Request c dir f tm s) = object ["current-directory" .= dir, "no-file" .= f, "timeout" .= tm, "silent" .= s] `objectUnion` toJSON c--instance FromJSON Request where-	parseJSON = withObject "request" $ \v -> Request <$>-		parseJSON (Object v) <*>-		((v .:: "current-directory") <|> pure ".") <*>-		((v .:: "no-file") <|> pure False) <*>-		((v .:: "timeout") <|> pure 0) <*>-		((v .:: "silent") <|> pure False)---- | Command from client-data Command =-	Ping |-	Listen (Maybe String) |-	SetLogLevel String |-	Scan {-		scanProjects :: [Path],-		scanCabal :: Bool,-		scanSandboxes :: [Path],-		scanFiles :: [FileSource],-		scanPaths :: [Path],-		scanGhcOpts :: [String],-		scanDocs :: Bool,-		scanInferTypes :: Bool } |-	SetFileContents Path (Maybe Text) |-	RefineDocs {-		docsProjects :: [Path],-		docsFiles :: [Path] } |-	InferTypes {-		inferProjects :: [Path],-		inferFiles :: [Path] } |-	Remove {-		removeProjects :: [Path],-		removeCabal :: Bool,-		removeSandboxes :: [Path],-		removeFiles :: [Path] } |-	RemoveAll |-	InfoPackages |-	InfoProjects |-	InfoSandboxes |-	InfoSymbol SearchQuery [TargetFilter] Bool Bool |-	InfoModule SearchQuery [TargetFilter] Bool Bool |-	InfoProject (Either Text Path) |-	InfoSandbox Path |-	Lookup Text Path |-	Whois Text Path |-	Whoat Int Int Path |-	ResolveScopeModules SearchQuery Path |-	ResolveScope SearchQuery Path |-	FindUsages Int Int Path |-	Complete Text Bool Path |-	Hayoo {-		hayooQuery :: String,-		hayooPage :: Int,-		hayooPages :: Int } |-	CabalList { cabalListPackages :: [Text] } |-	UnresolvedSymbols {-		unresolvedFiles :: [Path] } |-	Lint {-		lintFiles :: [FileSource],-		lintHlintOpts :: [String]-	} |-	Check {-		checkFiles :: [FileSource],-		checkGhcOpts :: [String],-		checkClear :: Bool } |-	CheckLint {-		checkLintFiles :: [FileSource],-		checkLintGhcOpts :: [String],-		checkLintOpts :: [String],-		checkLinkClear :: Bool } |-	Types {-		typesFiles :: [FileSource],-		typesGhcOpts :: [String],-		typesClear :: Bool } |-	AutoFix [Note OutputMessage] |-	Refactor [Note Refact] [Note Refact] Bool |-	Rename Text Text Path |-	GhcEval { ghcEvalExpressions :: [String], ghcEvalSource :: Maybe FileSource } |-	GhcType { ghcTypeExpressions :: [String], ghcTypeSource :: Maybe FileSource } |-	Langs |-	Flags |-	Link { linkHold :: Bool } |-	StopGhc |-	Exit-		deriving (Show)--data FileSource = FileSource { fileSource :: Path, fileContents :: Maybe Text } deriving (Show)-data TargetFilter =-	TargetProject Text |-	TargetFile Path |-	TargetModule Text |-	TargetPackage Text |-	TargetInstalled |-	TargetSourced |-	TargetStandalone-		deriving (Eq, Show)-data SearchQuery = SearchQuery Text SearchType deriving (Show)-data SearchType = SearchExact | SearchPrefix | SearchInfix | SearchSuffix deriving (Show)--instance Paths Command where-	paths f (Scan projs c cs fs ps ghcs docs infer) = Scan <$>-		traverse (paths f) projs <*>-		pure c <*>-		traverse (paths f) cs <*>-		traverse (paths f) fs <*>-		traverse (paths f) ps <*>-		pure ghcs <*>-		pure docs <*>-		pure infer-	paths f (SetFileContents p cts) = SetFileContents <$> paths f p <*> pure cts-	paths f (RefineDocs projs fs) = RefineDocs <$> traverse (paths f) projs <*> traverse (paths f) fs-	paths f (InferTypes projs fs) = InferTypes <$> traverse (paths f) projs <*> traverse (paths f) fs-	paths f (Remove projs c cs fs) = Remove <$> traverse (paths f) projs <*> pure c <*> traverse (paths f) cs <*> traverse (paths f) fs-	paths _ RemoveAll = pure RemoveAll-	paths f (InfoSymbol q t h l) = InfoSymbol <$> pure q <*> traverse (paths f) t <*> pure h <*> pure l-	paths f (InfoModule q t h i) = InfoModule <$> pure q <*> traverse (paths f) t <*> pure h <*> pure i-	paths f (InfoProject (Right proj)) = InfoProject <$> (Right <$> paths f proj)-	paths f (InfoSandbox fpath) = InfoSandbox <$> paths f fpath-	paths f (Lookup n fpath) = Lookup <$> pure n <*> paths f fpath-	paths f (Whois n fpath) = Whois <$> pure n <*> paths f fpath-	paths f (Whoat l c fpath) = Whoat <$> pure l <*> pure c <*> paths f fpath-	paths f (ResolveScopeModules q fpath) = ResolveScopeModules q <$> paths f fpath-	paths f (ResolveScope q fpath) = ResolveScope q <$> paths f fpath-	paths f (FindUsages l c fpath) = FindUsages <$> pure l <*> pure c <*> paths f fpath-	paths f (Complete n g fpath) = Complete n g <$> paths f fpath-	paths f (UnresolvedSymbols fs) = UnresolvedSymbols <$> traverse (paths f) fs-	paths f (Lint fs lints) = Lint <$> traverse (paths f) fs <*> pure lints-	paths f (Check fs ghcs c) = Check <$> traverse (paths f) fs <*> pure ghcs <*> pure c-	paths f (CheckLint fs ghcs lints c) = CheckLint <$> traverse (paths f) fs <*> pure ghcs <*> pure lints <*> pure c-	paths f (Types fs ghcs c) = Types <$> traverse (paths f) fs <*> pure ghcs <*> pure c-	paths f (GhcEval e mf) = GhcEval e <$> traverse (paths f) mf-	paths f (GhcType e mf) = GhcType e <$> traverse (paths f) mf-	paths _ c = pure c--instance Paths FileSource where-	paths f (FileSource fpath mcts) = FileSource <$> paths f fpath <*> pure mcts--instance Paths TargetFilter where-	paths f (TargetFile fpath) = TargetFile <$> paths f fpath-	paths _ t = pure t--instance FromCmd Command where-	cmdP = subparser $ mconcat [-		cmd "ping" "ping server" (pure Ping),-		cmd "listen" "listen server log" (Listen <$> optional logLevelArg),-		cmd "set-log" "set log level" (SetLogLevel <$> strArgument idm),-		cmd "scan" "scan sources" $ Scan <$>-			many projectArg <*>-			cabalFlag <*>-			many sandboxArg <*>-			many cmdP <*>-			many (pathArg $ help "path") <*>-			ghcOpts <*>-			docsFlag <*>-			inferFlag,-		cmd "set-file-contents" "set edited file contents, which will be used instead of contents in file until it updated" $-			SetFileContents <$> fileArg <*> optional contentsArg,-		cmd "docs" "scan docs" $ RefineDocs <$> many projectArg <*> many fileArg,-		cmd "infer" "infer types" $ InferTypes <$> many projectArg <*> many fileArg,-		cmd "remove" "remove modules info" $ Remove <$>-			many projectArg <*>-			cabalFlag <*>-			many sandboxArg <*>-			many fileArg,-		cmd "remove-all" "remove all data" (pure RemoveAll),-		cmd "packages" "list packages" (pure InfoPackages),-		cmd "projects" "list projects" (pure InfoProjects),-		cmd "sandboxes" "list sandboxes" (pure InfoSandboxes),-		cmd "symbol" "get symbol info" (InfoSymbol <$> cmdP <*> many cmdP <*> headerFlag <*> localsFlag),-		cmd "module" "get module info" (InfoModule <$> cmdP <*> many cmdP <*> headerFlag <*> inspectionFlag),-		cmd "project" "get project info" (InfoProject <$> ((Left <$> projectArg) <|> (Right <$> pathArg idm))),-		cmd "sandbox" "get sandbox info" (InfoSandbox <$> pathArg (help "locate sandbox in parent of this path")),-		cmd "lookup" "lookup for symbol" (Lookup <$> textArgument idm <*> ctx),-		cmd "whois" "get info for symbol" (Whois <$> textArgument idm <*> ctx),-		cmd "whoat" "get info for symbol under cursor" (Whoat <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx),-		cmd "scope" "get declarations accessible from module or within a project" (-			subparser (cmd "modules" "get modules accessible from module or within a project" (ResolveScopeModules <$> cmdP <*> ctx)) <|>-			ResolveScope <$> cmdP <*> ctx),-		cmd "usages" "find usages of symbol within project/module" (FindUsages <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx),-		cmd "complete" "show completions for input" (Complete <$> textArgument idm <*> wideFlag <*> ctx),-		cmd "hayoo" "find declarations online via Hayoo" (Hayoo <$> strArgument idm <*> hayooPageArg <*> hayooPagesArg),-		cmd "cabal" "cabal commands" (subparser $ cmd "list" "list cabal packages" (CabalList <$> many (textArgument idm))),-		cmd "unresolveds" "list unresolved symbols in source file" (UnresolvedSymbols <$> many fileArg),-		cmd "lint" "lint source files or file contents" (Lint <$> many cmdP <*> lintOpts),-		cmd "check" "check source files or file contents" (Check <$> many cmdP <*> ghcOpts <*> clearFlag),-		cmd "check-lint" "check and lint source files or file contents" (CheckLint <$> many cmdP <*> ghcOpts <*> lintOpts <*> clearFlag),-		cmd "types" "get types for file expressions" (Types <$> many cmdP <*> ghcOpts <*> clearFlag),-		cmd "autofixes" "get autofixes by output messages" (AutoFix <$> option readJSON (long "data" <> metavar "message" <> help "messages to make fixes for")),-		cmd "refactor" "apply some refactors and get rest updated" (Refactor <$>-			option readJSON (long "data" <> metavar "message" <> help "messages to fix") <*>-			option readJSON (long "rest" <> metavar "correction" <> short 'r' <> help "update corrections") <*>-			pureFlag),-		cmd "rename" "get rename refactors" (Rename <$> textArgument idm <*> textArgument idm <*> ctx),-		cmd "ghc" "ghc commands" (-				subparser (cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm) <*> optional cmdP)) <|>-				subparser (cmd "type" "expression type" (GhcType <$> many (strArgument idm) <*> optional cmdP))),-		cmd "langs" "ghc language options" (pure Langs),-		cmd "flags" "ghc flags" (pure Flags),-		cmd "link" "link to server" (Link <$> holdFlag),-		cmd "stop-ghc" "stop ghc sessions" (pure StopGhc),-		cmd "exit" "exit" (pure Exit)]--instance FromCmd FileSource where-	cmdP = option readJSON (long "contents") <|> (FileSource <$> fileArg <*> pure Nothing)--instance FromCmd TargetFilter where-	cmdP = asum [-		TargetProject <$> projectArg,-		TargetFile <$> fileArg,-		TargetModule <$> moduleArg,-		TargetPackage <$> packageArg,-		flag' TargetInstalled (long "installed"),-		flag' TargetSourced (long "src"),-		flag' TargetStandalone (long "stand")]--instance FromCmd SearchQuery where-	cmdP = SearchQuery <$> (textArgument idm <|> pure "") <*> asum [-		flag' SearchExact (long "exact"),-		flag' SearchInfix (long "infix"),-		flag' SearchSuffix (long "suffix"),-		pure SearchPrefix <* switch (long "prefix")]--readJSON :: FromJSON a => ReadM a-readJSON = str >>= maybe (readerError "Can't parse JSON argument") return . decode . L.pack--textOption :: Mod OptionFields String -> Parser Text-textOption = fmap fromString . strOption--textArgument :: Mod ArgumentFields String -> Parser Text-textArgument = fmap fromString . strArgument--cabalFlag :: Parser Bool-clearFlag :: Parser Bool-contentsArg :: Parser Text-ctx :: Parser Path-docsFlag :: Parser Bool-fileArg :: Parser Path-ghcOpts :: Parser [String]-hayooPageArg :: Parser Int-hayooPagesArg :: Parser Int-headerFlag :: Parser Bool-holdFlag :: Parser Bool-inferFlag :: Parser Bool-inspectionFlag :: Parser Bool-lintOpts :: Parser [String]-localsFlag :: Parser Bool-moduleArg :: Parser Text-packageArg :: Parser Text-pathArg :: Mod OptionFields String -> Parser Path-projectArg :: Parser Path-pureFlag :: Parser Bool-sandboxArg :: Parser Path-wideFlag :: Parser Bool--cabalFlag = switch (long "cabal")-clearFlag = switch (long "clear" <> short 'c' <> help "clear run, drop previous state")-contentsArg = textOption (long "contents" <> help "text contents")-ctx = fileArg-docsFlag = switch (long "docs" <> help "scan source file docs")-fileArg = textOption (long "file" <> metavar "path" <> short 'f')-ghcOpts = many (strOption (long "ghc" <> metavar "option" <> short 'g' <> help "options to pass to GHC"))-hayooPageArg = option auto (long "page" <> metavar "n" <> short 'p' <> help "page number (0 by default)" <> value 0)-hayooPagesArg = option auto (long "pages" <> metavar "count" <> short 'n' <> help "pages count (1 by default)" <> value 1)-headerFlag = switch (long "header" <> short 'h' <> help "show only header of module")-holdFlag = switch (long "hold" <> short 'h' <> help "don't return any response")-inferFlag = switch (long "infer" <> help "infer types")-inspectionFlag = switch (long "inspection" <> short 'i' <> help "return inspection data")-lintOpts = many (strOption (long "lint" <> metavar "option" <> short 'l' <> help "options for hlint"))-localsFlag = switch (long "locals" <> short 'l' <> help "look in local declarations")-moduleArg = textOption (long "module" <> metavar "name" <> short 'm' <> help "module name")-packageArg = textOption (long "package" <> metavar "name" <> help "module package")-pathArg f = textOption (long "path" <> metavar "path" <> short 'p' <> f)-projectArg = textOption (long "project" <> long "proj" <> metavar "project")-pureFlag = switch (long "pure" <> help "don't modify actual file, just return result")-sandboxArg = textOption (long "sandbox" <> metavar "path" <> help "path to cabal sandbox")-wideFlag = switch (long "wide" <> short 'w' <> help "wide mode - complete as if there were no import lists")--instance ToJSON Command where-	toJSON Ping = cmdJson "ping" []-	toJSON (Listen lev) = cmdJson "listen" ["level" .= lev]-	toJSON (SetLogLevel lev) = cmdJson "set-log" ["level" .= lev]-	toJSON (Scan projs cabal sboxes fs ps ghcs docs' infer') = cmdJson "scan" [-		"projects" .= projs,-		"cabal" .= cabal,-		"sandboxes" .= sboxes,-		"files" .= fs,-		"paths" .= ps,-		"ghc-opts" .= ghcs,-		"docs" .= docs',-		"infer" .= infer']-	toJSON (SetFileContents f cts) = cmdJson "set-file-contents" ["file" .= f, "contents" .= cts]-	toJSON (RefineDocs projs fs) = cmdJson "docs" ["projects" .= projs, "files" .= fs]-	toJSON (InferTypes projs fs) = cmdJson "infer" ["projects" .= projs, "files" .= fs]-	toJSON (Remove projs cabal sboxes fs) = cmdJson "remove" ["projects" .= projs, "cabal" .= cabal, "sandboxes" .= sboxes, "files" .= fs]-	toJSON RemoveAll = cmdJson "remove-all" []-	toJSON InfoPackages = cmdJson "packages" []-	toJSON InfoProjects = cmdJson "projects" []-	toJSON InfoSandboxes = cmdJson "sandboxes" []-	toJSON (InfoSymbol q tf h l) = cmdJson "symbol" ["query" .= q, "filters" .= tf, "header" .= h, "locals" .= l]-	toJSON (InfoModule q tf h i) = cmdJson "module" ["query" .= q, "filters" .= tf, "header" .= h, "inspection" .= i]-	toJSON (InfoProject p) = cmdJson "project" $ either (\pname -> ["name" .= pname]) (\ppath -> ["path" .= ppath]) p-	toJSON (InfoSandbox p) = cmdJson "sandbox" ["path" .= p]-	toJSON (Lookup n f) = cmdJson "lookup" ["name" .= n, "file" .= f]-	toJSON (Whois n f) = cmdJson "whois" ["name" .= n, "file" .= f]-	toJSON (Whoat l c f) = cmdJson "whoat" ["line" .= l, "column" .= c, "file" .= f]-	toJSON (ResolveScopeModules q f) = cmdJson "scope modules" ["query" .= q, "file" .= f]-	toJSON (ResolveScope q f) = cmdJson "scope" ["query" .= q, "file" .= f]-	toJSON (FindUsages l c f) = cmdJson "usages" ["line" .= l, "column" .= c, "file" .= f]-	toJSON (Complete q w f) = cmdJson "complete" ["prefix" .= q, "wide" .= w, "file" .= f]-	toJSON (Hayoo q p ps) = cmdJson "hayoo" ["query" .= q, "page" .= p, "pages" .= ps]-	toJSON (CabalList ps) = cmdJson "cabal list" ["packages" .= ps]-	toJSON (UnresolvedSymbols fs) = cmdJson "unresolveds" ["files" .= fs]-	toJSON (Lint fs lints) = cmdJson "lint" ["files" .= fs, "lint-opts" .= lints]-	toJSON (Check fs ghcs c) = cmdJson "check" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c]-	toJSON (CheckLint fs ghcs lints c) = cmdJson "check-lint" ["files" .= fs, "ghc-opts" .= ghcs, "lint-opts" .= lints, "clear" .= c]-	toJSON (Types fs ghcs c) = cmdJson "types" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c]-	toJSON (AutoFix ns) = cmdJson "autofixes" ["messages" .= ns]-	toJSON (Refactor ns rests pure') = cmdJson "refactor" ["messages" .= ns, "rest" .= rests, "pure" .= pure']-	toJSON (Rename n n' f) = cmdJson "rename" ["name" .= n, "new-name" .= n', "file" .= f]-	toJSON (GhcEval exprs f) = cmdJson "ghc eval" ["exprs" .= exprs, "file" .= f]-	toJSON (GhcType exprs f) = cmdJson "ghc type" ["exprs" .= exprs, "file" .= f]-	toJSON Langs = cmdJson "langs" []-	toJSON Flags = cmdJson "flags" []-	toJSON (Link h) = cmdJson "link" ["hold" .= h]-	toJSON StopGhc = cmdJson "stop-ghc" []-	toJSON Exit = cmdJson "exit" []--instance FromJSON Command where-	parseJSON = withObject "command" $ \v -> asum [-		guardCmd "ping" v *> pure Ping,-		guardCmd "listen" v *> (Listen <$> v .::? "level"),-		guardCmd "set-log" v *> (SetLogLevel <$> v .:: "level"),-		guardCmd "scan" v *> (Scan <$>-			v .::?! "projects" <*>-			(v .:: "cabal" <|> pure False) <*>-			v .::?! "sandboxes" <*>-			v .::?! "files" <*>-			v .::?! "paths" <*>-			v .::?! "ghc-opts" <*>-			(v .:: "docs" <|> pure False) <*>-			(v .:: "infer" <|> pure False)),-		guardCmd "set-file-contents" v *> (SetFileContents <$> v .:: "file" <*> v .:: "contents"),-		guardCmd "docs" v *> (RefineDocs <$> v .::?! "projects" <*> v .::?! "files"),-		guardCmd "infer" v *> (InferTypes <$> v .::?! "projects" <*> v .::?! "files"),-		guardCmd "remove" v *> (Remove <$>-			v .::?! "projects" <*>-			(v .:: "cabal" <|> pure False) <*>-			v .::?! "sandboxes" <*>-			v .::?! "files"),-		guardCmd "remove-all" v *> pure RemoveAll,-		guardCmd "packages" v *> pure InfoPackages,-		guardCmd "projects" v *> pure InfoProjects,-		guardCmd "sandboxes" v *> pure InfoSandboxes,-		guardCmd "symbol" v *> (InfoSymbol <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> (v .:: "locals" <|> pure False)),-		guardCmd "module" v *> (InfoModule <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> v .:: "inspection"),-		guardCmd "project" v *> (InfoProject <$> asum [Left <$> v .:: "name", Right <$> v .:: "path"]),-		guardCmd "sandbox" v *> (InfoSandbox <$> v .:: "path"),-		guardCmd "lookup" v *> (Lookup <$> v .:: "name" <*> v .:: "file"),-		guardCmd "whois" v *> (Whois <$> v .:: "name" <*> v .:: "file"),-		guardCmd "whoat" v *> (Whoat <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"),-		guardCmd "scope modules" v *> (ResolveScopeModules <$> v .:: "query" <*> v .:: "file"),-		guardCmd "scope" v *> (ResolveScope <$> v .:: "query" <*> v .:: "file"),-		guardCmd "usages" v *> (FindUsages <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"),-		guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> (v .:: "wide" <|> pure False) <*> v .:: "file"),-		guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> (v .:: "page" <|> pure 0) <*> (v .:: "pages" <|> pure 1)),-		guardCmd "cabal list" v *> (CabalList <$> v .::?! "packages"),-		guardCmd "unresolveds" v *> (UnresolvedSymbols <$> v .::?! "files"),-		guardCmd "lint" v *> (Lint <$> v .::?! "files" <*> v .::?! "lint-opts"),-		guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)),-		guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> v .::?! "lint-opts" <*> (v .:: "clear" <|> pure False)),-		guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)),-		guardCmd "autofixes" v *> (AutoFix <$> v .:: "messages"),-		guardCmd "refactor" v *> (Refactor <$> v .:: "messages" <*> v .::?! "rest" <*> (v .:: "pure" <|> pure True)),-		guardCmd "rename" v *> (Rename <$> v .:: "name" <*> v .:: "new-name" <*> v .:: "file"),-		guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs" <*> v .::? "file"),-		guardCmd "ghc type" v *> (GhcType <$> v .::?! "exprs" <*> v .::? "file"),-		guardCmd "langs" v *> pure Langs,-		guardCmd "flags" v *> pure Flags,-		guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)),-		guardCmd "stop-ghc" v *> pure StopGhc,-		guardCmd "exit" v *> pure Exit]--instance ToJSON FileSource where-	toJSON (FileSource fpath mcts) = object ["file" .= fpath, "contents" .= mcts]--instance FromJSON FileSource where-	parseJSON = withObject "file-contents" $ \v -> FileSource <$> v .:: "file" <*> v .::? "contents"--instance ToJSON TargetFilter where-	toJSON (TargetProject pname) = object ["project" .= pname]-	toJSON (TargetFile fpath) = object ["file" .= fpath]-	toJSON (TargetModule mname) = object ["module" .= mname]-	toJSON (TargetPackage pkg) = object ["package" .= pkg]-	toJSON TargetInstalled = toJSON ("installed" :: String)-	toJSON TargetSourced = toJSON ("sourced" :: String)-	toJSON TargetStandalone = toJSON ("standalone" :: String)--instance FromJSON TargetFilter where-	parseJSON j = obj j <|> str' where-		obj = withObject "target-filter" $ \v -> asum [-			TargetProject <$> v .:: "project",-			TargetFile <$> v .:: "file",-			TargetModule <$> v .:: "module",-			TargetPackage <$> v .:: "package"]-		str' = do-			s <- parseJSON j :: A.Parser String-			case s of-				"installed" -> return TargetInstalled-				"sourced" -> return TargetSourced-				"standalone" -> return TargetStandalone-				_ -> empty--instance ToJSON SearchQuery where-	toJSON (SearchQuery q st) = object ["input" .= q, "type" .= st]--instance FromJSON SearchQuery where-	parseJSON = withObject "search-query" $ \v -> SearchQuery <$> (v .:: "input" <|> pure "") <*> (v .:: "type" <|> pure SearchPrefix)--instance ToJSON SearchType where-	toJSON SearchExact = toJSON ("exact" :: String)-	toJSON SearchPrefix = toJSON ("prefix" :: String)-	toJSON SearchInfix = toJSON ("infix" :: String)-	toJSON SearchSuffix = toJSON ("suffix" :: String)--instance FromJSON SearchType where-	parseJSON v = do-		str' <- parseJSON v :: A.Parser String-		case str' of-			"exact" -> return SearchExact-			"prefix" -> return SearchPrefix-			"infix" -> return SearchInfix-			"suffix" -> return SearchInfix-			_ -> empty+{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Server.Types (
+	ServerMonadBase,
+	SessionLog(..), Session(..), SessionMonad(..), askSession, ServerM(..),
+	CommandOptions(..), CommandMonad(..), askOptions, ClientM(..),
+	withSession, serverListen, serverSetLogLevel, serverWait, serverWaitClients,
+	serverSqlDatabase, openSqlConnection, closeSqlConnection, withSqlConnection, withSqlTransaction, serverSetFileContents,
+	inSessionGhc, inSessionUpdater, postSessionUpdater, serverExit, commandRoot, commandNotify, commandLink, commandHold,
+	ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..),
+
+	Command(..),
+	FileSource(..), TargetFilter(..), SearchQuery(..), SearchType(..),
+	FromCmd(..),
+	) where
+
+import Control.Applicative
+import Control.Concurrent.Async (Async)
+import qualified Control.Concurrent.FiniteChan as F
+import Control.Lens (view, set)
+import Control.Monad.Base
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.Morph
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Trans.Control
+import Data.Aeson hiding (Result(..), Error)
+import qualified Data.Aeson.Types as A
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Default
+import Data.Maybe (fromMaybe)
+import Data.Foldable (asum)
+import Data.Text (Text)
+import Data.String (fromString)
+import qualified Database.SQLite.Simple as SQL
+import Options.Applicative
+import System.Log.Simple as Log
+
+import Control.Concurrent.Worker
+import Data.LookupTable
+import System.Directory.Paths
+import Text.Format (Formattable(..))
+
+import HsDev.Error (hsdevError)
+import HsDev.Inspect.Types
+import HsDev.Server.Message
+import HsDev.Watcher.Types (Watcher)
+import HsDev.Tools.Ghc.Worker (GhcWorker, GhcM)
+import HsDev.Tools.Types (Note, OutputMessage)
+import HsDev.Tools.AutoFix (Refact)
+import HsDev.Types (HsDevError(..))
+import HsDev.Util
+
+#if mingw32_HOST_OS
+import System.Win32.FileMapping.NamePool (Pool)
+#endif
+
+type ServerMonadBase m = (MonadIO m, MonadMask m, MonadBaseControl IO m, Alternative m, MonadPlus m)
+
+data SessionLog = SessionLog {
+	sessionLogger :: Log,
+	sessionListenLog :: IO [Log.Message],
+	sessionLogWait :: IO () }
+
+data Session = Session {
+	sessionSqlDatabase :: SQL.Connection,
+	sessionSqlPath :: String,
+	sessionLog :: SessionLog,
+	sessionWatcher :: Watcher,
+	sessionFileContents :: Path -> Maybe Text -> IO (),
+#if mingw32_HOST_OS
+	sessionMmapPool :: Maybe Pool,
+#endif
+	sessionGhc :: GhcWorker,
+	sessionUpdater :: Worker (ServerM IO),
+	sessionResolveEnvironment :: LookupTable (Maybe Path) (Environment, FixitiesTable),
+	sessionExit :: IO (),
+	sessionWait :: IO (),
+	sessionClients :: F.Chan (IO ()),
+	sessionDefines :: [(String, String)] }
+
+class (ServerMonadBase m, MonadLog m) => SessionMonad m where
+	getSession :: m Session
+	localSession :: (Session -> Session) -> m a -> m a
+
+askSession :: SessionMonad m => (Session -> a) -> m a
+askSession f = liftM f getSession
+
+newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a }
+	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch, MonadMask)
+
+instance (MonadIO m, MonadMask m) => MonadLog (ServerM m) where
+	askLog = ServerM $ asks (sessionLogger . sessionLog)
+	localLog fn = ServerM . local setLog' . runServerM where
+		setLog' sess = sess { sessionLog = (sessionLog sess) { sessionLogger = fn (sessionLogger (sessionLog sess)) } }
+
+instance ServerMonadBase m => SessionMonad (ServerM m) where
+	getSession = ask
+	localSession = local
+
+instance MonadBase b m => MonadBase b (ServerM m) where
+	liftBase = ServerM . liftBase
+
+instance MonadBaseControl b m => MonadBaseControl b (ServerM m) where
+	type StM (ServerM m) a = StM (ReaderT Session m) a
+	liftBaseWith f = ServerM $ liftBaseWith (\f' -> f (f' . runServerM))
+	restoreM = ServerM . restoreM
+
+instance MFunctor ServerM where
+	hoist fn = ServerM . hoist fn . runServerM
+
+instance SessionMonad m => SessionMonad (ReaderT r m) where
+	getSession = lift getSession
+	localSession = mapReaderT . localSession
+
+instance (SessionMonad m, Monoid w) => SessionMonad (WriterT w m) where
+	getSession = lift getSession
+	localSession = mapWriterT . localSession
+
+instance SessionMonad m => SessionMonad (StateT s m) where
+	getSession = lift getSession
+	localSession = mapStateT . localSession
+
+data CommandOptions = CommandOptions {
+	commandOptionsRoot :: FilePath,
+	commandOptionsNotify :: Notification -> IO (),
+	commandOptionsLink :: IO (),
+	commandOptionsHold :: IO () }
+
+instance Default CommandOptions where
+	def = CommandOptions "." (const $ return ()) (return ()) (return ())
+
+class (SessionMonad m, MonadPlus m) => CommandMonad m where
+	getOptions :: m CommandOptions
+
+askOptions :: CommandMonad m => (CommandOptions -> a) -> m a
+askOptions f = liftM f getOptions
+
+newtype ClientM m a = ClientM { runClientM :: ServerM (ReaderT CommandOptions m) a }
+	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask)
+
+instance MonadTrans ClientM where
+	lift = ClientM . lift . lift
+
+instance (MonadIO m, MonadMask m) => MonadLog (ClientM m) where
+	askLog = ClientM askLog
+	localLog fn = ClientM . localLog fn . runClientM
+
+instance ServerMonadBase m => SessionMonad (ClientM m) where
+	getSession = ClientM getSession
+	localSession fn = ClientM . localSession fn . runClientM
+
+instance ServerMonadBase m => CommandMonad (ClientM m) where
+	getOptions = ClientM $ lift ask
+
+instance MonadBase b m => MonadBase b (ClientM m) where
+	liftBase = ClientM . liftBase
+
+instance MonadBaseControl b m => MonadBaseControl b (ClientM m) where
+	type StM (ClientM m) a = StM (ServerM (ReaderT CommandOptions m)) a
+	liftBaseWith f = ClientM $ liftBaseWith (\f' -> f (f' . runClientM))
+	restoreM = ClientM . restoreM
+
+instance MFunctor ClientM where
+	hoist fn = ClientM . hoist (hoist fn) . runClientM
+
+instance CommandMonad m => CommandMonad (ReaderT r m) where
+	getOptions = lift getOptions
+
+instance (CommandMonad m, Monoid w) => CommandMonad (WriterT w m) where
+	getOptions = lift getOptions
+
+instance CommandMonad m => CommandMonad (StateT s m) where
+	getOptions = lift getOptions
+
+-- | Run action on session
+withSession :: Session -> ServerM m a -> m a
+withSession s act = runReaderT (runServerM act) s
+
+-- | Listen server's log
+serverListen :: SessionMonad m => m [Log.Message]
+serverListen = join . liftM liftIO $ askSession (sessionListenLog . sessionLog)
+
+-- | Set server's log config
+serverSetLogLevel :: SessionMonad m => Level -> m Level
+serverSetLogLevel lev = do
+	l <- askSession (sessionLogger . sessionLog)
+	cfg <- updateLogConfig l (set (componentCfg "") (Just lev))
+	return $ fromMaybe def $ view (componentCfg "") cfg
+
+-- | Wait for server
+serverWait :: SessionMonad m => m ()
+serverWait = join . liftM liftIO $ askSession sessionWait
+
+-- | Wait while clients disconnects
+serverWaitClients :: SessionMonad m => m ()
+serverWaitClients = do
+	clientChan <- askSession sessionClients
+	liftIO (F.stopChan clientChan) >>= sequence_ . map liftIO
+
+-- | Get sql connection
+serverSqlDatabase :: SessionMonad m => m SQL.Connection
+serverSqlDatabase = askSession sessionSqlDatabase
+
+-- | Open new sql connection
+openSqlConnection :: SessionMonad m => m SQL.Connection
+openSqlConnection = do
+	p <- askSession sessionSqlPath
+	-- FIXME: There's `new` function in HsDev's SQLite module
+	liftIO $ do
+		conn <- SQL.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
+
+-- | Close sql connection
+closeSqlConnection :: SessionMonad m => SQL.Connection -> m ()
+closeSqlConnection = liftIO . SQL.close
+
+-- | Locally opens new connection, updating @Session@
+withSqlConnection :: SessionMonad m => m a -> m a
+withSqlConnection act = bracket openSqlConnection closeSqlConnection $ \conn ->
+	localSession (\sess -> sess { sessionSqlDatabase = conn }) act
+
+-- | With sql transaction
+withSqlTransaction :: SessionMonad m => ServerM IO a -> m a
+withSqlTransaction fn = do
+	conn <- serverSqlDatabase
+	sess <- getSession
+	liftIO $ SQL.withTransaction conn $ withSession sess fn
+
+-- | Set custom file contents
+serverSetFileContents :: SessionMonad m => Path -> Maybe Text -> m ()
+serverSetFileContents fpath mcts = do
+	setCts <- askSession sessionFileContents
+	liftIO $ setCts fpath mcts
+
+-- | In ghc session
+inSessionGhc :: SessionMonad m => GhcM a -> m a
+inSessionGhc act = do
+	ghcw <- askSession sessionGhc
+	inWorkerWith (hsdevError . GhcError . displayException) ghcw act
+
+-- | In updater
+inSessionUpdater :: SessionMonad m => ServerM IO a -> m a
+inSessionUpdater act = do
+	uw <- askSession sessionUpdater
+	inWorkerWith (hsdevError . OtherError . displayException) uw act
+
+-- | Post to updater and return
+postSessionUpdater :: SessionMonad m => ServerM IO a -> m (Async a)
+postSessionUpdater act = do
+	uw <- askSession sessionUpdater
+	liftIO $ sendTask uw act
+
+-- | Exit session
+serverExit :: SessionMonad m => m ()
+serverExit = join . liftM liftIO $ askSession sessionExit
+
+commandRoot :: CommandMonad m => m FilePath
+commandRoot = askOptions commandOptionsRoot
+
+commandNotify :: CommandMonad m => Notification -> m ()
+commandNotify n = join . liftM liftIO $ askOptions commandOptionsNotify <*> pure n
+
+commandLink :: CommandMonad m => m ()
+commandLink = join . liftM liftIO $ askOptions commandOptionsLink
+
+commandHold :: CommandMonad m => m ()
+commandHold = join . liftM liftIO $ askOptions commandOptionsHold
+
+-- | Server control command
+data ServerCommand =
+	Version |
+	Start ServerOpts |
+	Run ServerOpts |
+	Stop ClientOpts |
+	Connect ClientOpts |
+	Remote ClientOpts Bool Command
+		deriving (Show)
+
+data ConnectionPort = NetworkPort Int | UnixPort String deriving (Eq, Read)
+
+instance Default ConnectionPort where
+	def = NetworkPort 4567
+
+instance Show ConnectionPort where
+	show (NetworkPort p) = show p
+	show (UnixPort s) = "unix " ++ s
+
+instance Formattable ConnectionPort
+
+-- | Server options
+data ServerOpts = ServerOpts {
+	serverPort :: ConnectionPort,
+	serverTimeout :: Int,
+	serverLog :: Maybe FilePath,
+	serverLogLevel :: String,
+	serverLogNoColor :: Bool,
+	serverDbFile :: Maybe FilePath,
+	serverSilent :: Bool }
+		deriving (Show)
+
+instance Default ServerOpts where
+	def = ServerOpts def 0 Nothing "info" False Nothing False
+
+-- | Silent server with no connection, useful for ghci
+silentOpts :: ServerOpts
+silentOpts = def { serverSilent = True }
+
+-- | Client options
+data ClientOpts = ClientOpts {
+	clientPort :: ConnectionPort,
+	clientPretty :: Bool,
+	clientStdin :: Bool,
+	clientTimeout :: Int,
+	clientSilent :: Bool }
+		deriving (Show)
+
+instance Default ClientOpts where
+	def = ClientOpts def False False 0 False
+
+instance FromCmd ServerCommand where
+	cmdP = serv <|> remote where
+		serv = subparser $ mconcat [
+			cmd "version" "hsdev version" (pure Version),
+			cmd "start" "start remote server" (Start <$> cmdP),
+			cmd "run" "run server" (Run <$> cmdP),
+			cmd "stop" "stop remote server" (Stop <$> cmdP),
+			cmd "connect" "connect to send commands directly" (Connect <$> cmdP)]
+		remote = Remote <$> cmdP <*> noFileFlag <*> cmdP
+
+instance FromCmd ServerOpts where
+	cmdP = ServerOpts <$>
+		(connectionArg <|> pure (serverPort def)) <*>
+		(timeoutArg <|> pure (serverTimeout def)) <*>
+		optional logArg <*>
+		(logLevelArg <|> pure (serverLogLevel def)) <*>
+		noColorFlag <*>
+		optional dbFileArg <*>
+		serverSilentFlag
+
+instance FromCmd ClientOpts where
+	cmdP = ClientOpts <$>
+		(connectionArg <|> pure (clientPort def)) <*>
+		prettyFlag <*>
+		stdinFlag <*>
+		(timeoutArg <|> pure (clientTimeout def)) <*>
+		silentFlag
+
+portArg :: Parser ConnectionPort
+connectionArg :: Parser ConnectionPort
+timeoutArg :: Parser Int
+logArg :: Parser FilePath
+logLevelArg :: Parser String
+noColorFlag :: Parser Bool
+noFileFlag :: Parser Bool
+prettyFlag :: Parser Bool
+serverSilentFlag :: Parser Bool
+stdinFlag :: Parser Bool
+silentFlag :: Parser Bool
+dbFileArg :: Parser FilePath
+
+portArg = NetworkPort <$> option auto (long "port" <> metavar "number" <> help "connection port")
+#if mingw32_HOST_OS
+connectionArg = portArg
+#else
+unixArg :: Parser ConnectionPort
+unixArg = UnixPort <$> strOption (long "unix" <> metavar "name" <> help "unix connection port")
+connectionArg = portArg <|> unixArg
+#endif
+timeoutArg = option auto (long "timeout" <> metavar "msec" <> help "query timeout")
+logArg = strOption (long "log" <> short 'l' <> metavar "file" <> help "log file")
+logLevelArg = strOption (long "log-level" <> metavar "level" <> help "log level: trace/debug/info/warning/error/fatal")
+noColorFlag = switch (long "no-color" <> help "don't use colorized log output")
+noFileFlag = switch (long "no-file" <> help "don't use mmap files")
+prettyFlag = switch (long "pretty" <> help "pretty json output")
+serverSilentFlag = switch (long "silent" <> help "no stdout/stderr")
+stdinFlag = switch (long "stdin" <> help "pass data to stdin")
+silentFlag = switch (long "silent" <> help "supress notifications")
+dbFileArg = strOption (long "db" <> metavar "path" <> help "path to sql database")
+
+serverOptsArgs :: ServerOpts -> [String]
+serverOptsArgs sopts = concat [
+	portArgs (serverPort sopts),
+	["--timeout", show $ serverTimeout sopts],
+	marg "--log" (serverLog sopts),
+	["--log-level", serverLogLevel sopts],
+	marg "--db" (serverDbFile sopts),
+	["--silent" | serverSilent sopts]]
+	where
+		marg :: String -> Maybe String -> [String]
+		marg n (Just v) = [n, v]
+		marg _ _ = []
+		portArgs :: ConnectionPort -> [String]
+		portArgs (NetworkPort n) = ["--port", show n]
+		portArgs (UnixPort s) = ["--unix", s]
+
+data Request = Request {
+	requestCommand :: Command,
+	requestDirectory :: FilePath,
+	requestNoFile :: Bool,
+	requestTimeout :: Int,
+	requestSilent :: Bool }
+		deriving (Show)
+
+instance ToJSON Request where
+	toJSON (Request c dir f tm s) = object ["current-directory" .= dir, "no-file" .= f, "timeout" .= tm, "silent" .= s] `objectUnion` toJSON c
+
+instance FromJSON Request where
+	parseJSON = withObject "request" $ \v -> Request <$>
+		parseJSON (Object v) <*>
+		((v .:: "current-directory") <|> pure ".") <*>
+		((v .:: "no-file") <|> pure False) <*>
+		((v .:: "timeout") <|> pure 0) <*>
+		((v .:: "silent") <|> pure False)
+
+-- | Command from client
+data Command =
+	Ping |
+	Listen (Maybe String) |
+	SetLogLevel String |
+	Scan {
+		scanProjects :: [Path],
+		scanCabal :: Bool,
+		scanSandboxes :: [Path],
+		scanFiles :: [FileSource],
+		scanPaths :: [Path],
+		scanGhcOpts :: [String],
+		scanDocs :: Bool,
+		scanInferTypes :: Bool } |
+	SetFileContents Path (Maybe Text) |
+	RefineDocs {
+		docsProjects :: [Path],
+		docsFiles :: [Path] } |
+	InferTypes {
+		inferProjects :: [Path],
+		inferFiles :: [Path] } |
+	Remove {
+		removeProjects :: [Path],
+		removeCabal :: Bool,
+		removeSandboxes :: [Path],
+		removeFiles :: [Path] } |
+	RemoveAll |
+	InfoPackages |
+	InfoProjects |
+	InfoSandboxes |
+	InfoSymbol SearchQuery [TargetFilter] Bool Bool |
+	InfoModule SearchQuery [TargetFilter] Bool Bool |
+	InfoProject (Either Text Path) |
+	InfoSandbox Path |
+	Lookup Text Path |
+	Whois Text Path |
+	Whoat Int Int Path |
+	ResolveScopeModules SearchQuery Path |
+	ResolveScope SearchQuery Path |
+	FindUsages Int Int Path |
+	Complete Text Bool Path |
+	Hayoo {
+		hayooQuery :: String,
+		hayooPage :: Int,
+		hayooPages :: Int } |
+	CabalList { cabalListPackages :: [Text] } |
+	UnresolvedSymbols {
+		unresolvedFiles :: [Path] } |
+	Lint {
+		lintFiles :: [FileSource],
+		lintHlintOpts :: [String]
+	} |
+	Check {
+		checkFiles :: [FileSource],
+		checkGhcOpts :: [String],
+		checkClear :: Bool } |
+	CheckLint {
+		checkLintFiles :: [FileSource],
+		checkLintGhcOpts :: [String],
+		checkLintOpts :: [String],
+		checkLinkClear :: Bool } |
+	Types {
+		typesFiles :: [FileSource],
+		typesGhcOpts :: [String],
+		typesClear :: Bool } |
+	AutoFix [Note OutputMessage] |
+	Refactor [Note Refact] [Note Refact] Bool |
+	Rename Text Text Path |
+	GhcEval { ghcEvalExpressions :: [String], ghcEvalSource :: Maybe FileSource } |
+	GhcType { ghcTypeExpressions :: [String], ghcTypeSource :: Maybe FileSource } |
+	Langs |
+	Flags |
+	Link { linkHold :: Bool } |
+	StopGhc |
+	Exit
+		deriving (Show)
+
+data FileSource = FileSource { fileSource :: Path, fileContents :: Maybe Text } deriving (Show)
+data TargetFilter =
+	TargetProject Text |
+	TargetFile Path |
+	TargetModule Text |
+	TargetPackage Text |
+	TargetInstalled |
+	TargetSourced |
+	TargetStandalone
+		deriving (Eq, Show)
+data SearchQuery = SearchQuery Text SearchType deriving (Show)
+data SearchType = SearchExact | SearchPrefix | SearchInfix | SearchSuffix deriving (Show)
+
+instance Paths Command where
+	paths f (Scan projs c cs fs ps ghcs docs infer) = Scan <$>
+		traverse (paths f) projs <*>
+		pure c <*>
+		traverse (paths f) cs <*>
+		traverse (paths f) fs <*>
+		traverse (paths f) ps <*>
+		pure ghcs <*>
+		pure docs <*>
+		pure infer
+	paths f (SetFileContents p cts) = SetFileContents <$> paths f p <*> pure cts
+	paths f (RefineDocs projs fs) = RefineDocs <$> traverse (paths f) projs <*> traverse (paths f) fs
+	paths f (InferTypes projs fs) = InferTypes <$> traverse (paths f) projs <*> traverse (paths f) fs
+	paths f (Remove projs c cs fs) = Remove <$> traverse (paths f) projs <*> pure c <*> traverse (paths f) cs <*> traverse (paths f) fs
+	paths _ RemoveAll = pure RemoveAll
+	paths f (InfoSymbol q t h l) = InfoSymbol <$> pure q <*> traverse (paths f) t <*> pure h <*> pure l
+	paths f (InfoModule q t h i) = InfoModule <$> pure q <*> traverse (paths f) t <*> pure h <*> pure i
+	paths f (InfoProject (Right proj)) = InfoProject <$> (Right <$> paths f proj)
+	paths f (InfoSandbox fpath) = InfoSandbox <$> paths f fpath
+	paths f (Lookup n fpath) = Lookup <$> pure n <*> paths f fpath
+	paths f (Whois n fpath) = Whois <$> pure n <*> paths f fpath
+	paths f (Whoat l c fpath) = Whoat <$> pure l <*> pure c <*> paths f fpath
+	paths f (ResolveScopeModules q fpath) = ResolveScopeModules q <$> paths f fpath
+	paths f (ResolveScope q fpath) = ResolveScope q <$> paths f fpath
+	paths f (FindUsages l c fpath) = FindUsages <$> pure l <*> pure c <*> paths f fpath
+	paths f (Complete n g fpath) = Complete n g <$> paths f fpath
+	paths f (UnresolvedSymbols fs) = UnresolvedSymbols <$> traverse (paths f) fs
+	paths f (Lint fs lints) = Lint <$> traverse (paths f) fs <*> pure lints
+	paths f (Check fs ghcs c) = Check <$> traverse (paths f) fs <*> pure ghcs <*> pure c
+	paths f (CheckLint fs ghcs lints c) = CheckLint <$> traverse (paths f) fs <*> pure ghcs <*> pure lints <*> pure c
+	paths f (Types fs ghcs c) = Types <$> traverse (paths f) fs <*> pure ghcs <*> pure c
+	paths f (GhcEval e mf) = GhcEval e <$> traverse (paths f) mf
+	paths f (GhcType e mf) = GhcType e <$> traverse (paths f) mf
+	paths _ c = pure c
+
+instance Paths FileSource where
+	paths f (FileSource fpath mcts) = FileSource <$> paths f fpath <*> pure mcts
+
+instance Paths TargetFilter where
+	paths f (TargetFile fpath) = TargetFile <$> paths f fpath
+	paths _ t = pure t
+
+instance FromCmd Command where
+	cmdP = subparser $ mconcat [
+		cmd "ping" "ping server" (pure Ping),
+		cmd "listen" "listen server log" (Listen <$> optional logLevelArg),
+		cmd "set-log" "set log level" (SetLogLevel <$> strArgument idm),
+		cmd "scan" "scan sources" $ Scan <$>
+			many projectArg <*>
+			cabalFlag <*>
+			many sandboxArg <*>
+			many cmdP <*>
+			many (pathArg $ help "path") <*>
+			ghcOpts <*>
+			docsFlag <*>
+			inferFlag,
+		cmd "set-file-contents" "set edited file contents, which will be used instead of contents in file until it updated" $
+			SetFileContents <$> fileArg <*> optional contentsArg,
+		cmd "docs" "scan docs" $ RefineDocs <$> many projectArg <*> many fileArg,
+		cmd "infer" "infer types" $ InferTypes <$> many projectArg <*> many fileArg,
+		cmd "remove" "remove modules info" $ Remove <$>
+			many projectArg <*>
+			cabalFlag <*>
+			many sandboxArg <*>
+			many fileArg,
+		cmd "remove-all" "remove all data" (pure RemoveAll),
+		cmd "packages" "list packages" (pure InfoPackages),
+		cmd "projects" "list projects" (pure InfoProjects),
+		cmd "sandboxes" "list sandboxes" (pure InfoSandboxes),
+		cmd "symbol" "get symbol info" (InfoSymbol <$> cmdP <*> many cmdP <*> headerFlag <*> localsFlag),
+		cmd "module" "get module info" (InfoModule <$> cmdP <*> many cmdP <*> headerFlag <*> inspectionFlag),
+		cmd "project" "get project info" (InfoProject <$> ((Left <$> projectArg) <|> (Right <$> pathArg idm))),
+		cmd "sandbox" "get sandbox info" (InfoSandbox <$> pathArg (help "locate sandbox in parent of this path")),
+		cmd "lookup" "lookup for symbol" (Lookup <$> textArgument idm <*> ctx),
+		cmd "whois" "get info for symbol" (Whois <$> textArgument idm <*> ctx),
+		cmd "whoat" "get info for symbol under cursor" (Whoat <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx),
+		cmd "scope" "get declarations accessible from module or within a project" (
+			subparser (cmd "modules" "get modules accessible from module or within a project" (ResolveScopeModules <$> cmdP <*> ctx)) <|>
+			ResolveScope <$> cmdP <*> ctx),
+		cmd "usages" "find usages of symbol within project/module" (FindUsages <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx),
+		cmd "complete" "show completions for input" (Complete <$> textArgument idm <*> wideFlag <*> ctx),
+		cmd "hayoo" "find declarations online via Hayoo" (Hayoo <$> strArgument idm <*> hayooPageArg <*> hayooPagesArg),
+		cmd "cabal" "cabal commands" (subparser $ cmd "list" "list cabal packages" (CabalList <$> many (textArgument idm))),
+		cmd "unresolveds" "list unresolved symbols in source file" (UnresolvedSymbols <$> many fileArg),
+		cmd "lint" "lint source files or file contents" (Lint <$> many cmdP <*> lintOpts),
+		cmd "check" "check source files or file contents" (Check <$> many cmdP <*> ghcOpts <*> clearFlag),
+		cmd "check-lint" "check and lint source files or file contents" (CheckLint <$> many cmdP <*> ghcOpts <*> lintOpts <*> clearFlag),
+		cmd "types" "get types for file expressions" (Types <$> many cmdP <*> ghcOpts <*> clearFlag),
+		cmd "autofixes" "get autofixes by output messages" (AutoFix <$> option readJSON (long "data" <> metavar "message" <> help "messages to make fixes for")),
+		cmd "refactor" "apply some refactors and get rest updated" (Refactor <$>
+			option readJSON (long "data" <> metavar "message" <> help "messages to fix") <*>
+			option readJSON (long "rest" <> metavar "correction" <> short 'r' <> help "update corrections") <*>
+			pureFlag),
+		cmd "rename" "get rename refactors" (Rename <$> textArgument idm <*> textArgument idm <*> ctx),
+		cmd "ghc" "ghc commands" (
+				subparser (cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm) <*> optional cmdP)) <|>
+				subparser (cmd "type" "expression type" (GhcType <$> many (strArgument idm) <*> optional cmdP))),
+		cmd "langs" "ghc language options" (pure Langs),
+		cmd "flags" "ghc flags" (pure Flags),
+		cmd "link" "link to server" (Link <$> holdFlag),
+		cmd "stop-ghc" "stop ghc sessions" (pure StopGhc),
+		cmd "exit" "exit" (pure Exit)]
+
+instance FromCmd FileSource where
+	cmdP = option readJSON (long "contents") <|> (FileSource <$> fileArg <*> pure Nothing)
+
+instance FromCmd TargetFilter where
+	cmdP = asum [
+		TargetProject <$> projectArg,
+		TargetFile <$> fileArg,
+		TargetModule <$> moduleArg,
+		TargetPackage <$> packageArg,
+		flag' TargetInstalled (long "installed"),
+		flag' TargetSourced (long "src"),
+		flag' TargetStandalone (long "stand")]
+
+instance FromCmd SearchQuery where
+	cmdP = SearchQuery <$> (textArgument idm <|> pure "") <*> asum [
+		flag' SearchExact (long "exact"),
+		flag' SearchInfix (long "infix"),
+		flag' SearchSuffix (long "suffix"),
+		pure SearchPrefix <* switch (long "prefix")]
+
+readJSON :: FromJSON a => ReadM a
+readJSON = str >>= maybe (readerError "Can't parse JSON argument") return . decode . L.pack
+
+textOption :: Mod OptionFields String -> Parser Text
+textOption = fmap fromString . strOption
+
+textArgument :: Mod ArgumentFields String -> Parser Text
+textArgument = fmap fromString . strArgument
+
+cabalFlag :: Parser Bool
+clearFlag :: Parser Bool
+contentsArg :: Parser Text
+ctx :: Parser Path
+docsFlag :: Parser Bool
+fileArg :: Parser Path
+ghcOpts :: Parser [String]
+hayooPageArg :: Parser Int
+hayooPagesArg :: Parser Int
+headerFlag :: Parser Bool
+holdFlag :: Parser Bool
+inferFlag :: Parser Bool
+inspectionFlag :: Parser Bool
+lintOpts :: Parser [String]
+localsFlag :: Parser Bool
+moduleArg :: Parser Text
+packageArg :: Parser Text
+pathArg :: Mod OptionFields String -> Parser Path
+projectArg :: Parser Path
+pureFlag :: Parser Bool
+sandboxArg :: Parser Path
+wideFlag :: Parser Bool
+
+cabalFlag = switch (long "cabal")
+clearFlag = switch (long "clear" <> short 'c' <> help "clear run, drop previous state")
+contentsArg = textOption (long "contents" <> help "text contents")
+ctx = fileArg
+docsFlag = switch (long "docs" <> help "scan source file docs")
+fileArg = textOption (long "file" <> metavar "path" <> short 'f')
+ghcOpts = many (strOption (long "ghc" <> metavar "option" <> short 'g' <> help "options to pass to GHC"))
+hayooPageArg = option auto (long "page" <> metavar "n" <> short 'p' <> help "page number (0 by default)" <> value 0)
+hayooPagesArg = option auto (long "pages" <> metavar "count" <> short 'n' <> help "pages count (1 by default)" <> value 1)
+headerFlag = switch (long "header" <> short 'h' <> help "show only header of module")
+holdFlag = switch (long "hold" <> short 'h' <> help "don't return any response")
+inferFlag = switch (long "infer" <> help "infer types")
+inspectionFlag = switch (long "inspection" <> short 'i' <> help "return inspection data")
+lintOpts = many (strOption (long "lint" <> metavar "option" <> short 'l' <> help "options for hlint"))
+localsFlag = switch (long "locals" <> short 'l' <> help "look in local declarations")
+moduleArg = textOption (long "module" <> metavar "name" <> short 'm' <> help "module name")
+packageArg = textOption (long "package" <> metavar "name" <> help "module package")
+pathArg f = textOption (long "path" <> metavar "path" <> short 'p' <> f)
+projectArg = textOption (long "project" <> long "proj" <> metavar "project")
+pureFlag = switch (long "pure" <> help "don't modify actual file, just return result")
+sandboxArg = textOption (long "sandbox" <> metavar "path" <> help "path to cabal sandbox")
+wideFlag = switch (long "wide" <> short 'w' <> help "wide mode - complete as if there were no import lists")
+
+instance ToJSON Command where
+	toJSON Ping = cmdJson "ping" []
+	toJSON (Listen lev) = cmdJson "listen" ["level" .= lev]
+	toJSON (SetLogLevel lev) = cmdJson "set-log" ["level" .= lev]
+	toJSON (Scan projs cabal sboxes fs ps ghcs docs' infer') = cmdJson "scan" [
+		"projects" .= projs,
+		"cabal" .= cabal,
+		"sandboxes" .= sboxes,
+		"files" .= fs,
+		"paths" .= ps,
+		"ghc-opts" .= ghcs,
+		"docs" .= docs',
+		"infer" .= infer']
+	toJSON (SetFileContents f cts) = cmdJson "set-file-contents" ["file" .= f, "contents" .= cts]
+	toJSON (RefineDocs projs fs) = cmdJson "docs" ["projects" .= projs, "files" .= fs]
+	toJSON (InferTypes projs fs) = cmdJson "infer" ["projects" .= projs, "files" .= fs]
+	toJSON (Remove projs cabal sboxes fs) = cmdJson "remove" ["projects" .= projs, "cabal" .= cabal, "sandboxes" .= sboxes, "files" .= fs]
+	toJSON RemoveAll = cmdJson "remove-all" []
+	toJSON InfoPackages = cmdJson "packages" []
+	toJSON InfoProjects = cmdJson "projects" []
+	toJSON InfoSandboxes = cmdJson "sandboxes" []
+	toJSON (InfoSymbol q tf h l) = cmdJson "symbol" ["query" .= q, "filters" .= tf, "header" .= h, "locals" .= l]
+	toJSON (InfoModule q tf h i) = cmdJson "module" ["query" .= q, "filters" .= tf, "header" .= h, "inspection" .= i]
+	toJSON (InfoProject p) = cmdJson "project" $ either (\pname -> ["name" .= pname]) (\ppath -> ["path" .= ppath]) p
+	toJSON (InfoSandbox p) = cmdJson "sandbox" ["path" .= p]
+	toJSON (Lookup n f) = cmdJson "lookup" ["name" .= n, "file" .= f]
+	toJSON (Whois n f) = cmdJson "whois" ["name" .= n, "file" .= f]
+	toJSON (Whoat l c f) = cmdJson "whoat" ["line" .= l, "column" .= c, "file" .= f]
+	toJSON (ResolveScopeModules q f) = cmdJson "scope modules" ["query" .= q, "file" .= f]
+	toJSON (ResolveScope q f) = cmdJson "scope" ["query" .= q, "file" .= f]
+	toJSON (FindUsages l c f) = cmdJson "usages" ["line" .= l, "column" .= c, "file" .= f]
+	toJSON (Complete q w f) = cmdJson "complete" ["prefix" .= q, "wide" .= w, "file" .= f]
+	toJSON (Hayoo q p ps) = cmdJson "hayoo" ["query" .= q, "page" .= p, "pages" .= ps]
+	toJSON (CabalList ps) = cmdJson "cabal list" ["packages" .= ps]
+	toJSON (UnresolvedSymbols fs) = cmdJson "unresolveds" ["files" .= fs]
+	toJSON (Lint fs lints) = cmdJson "lint" ["files" .= fs, "lint-opts" .= lints]
+	toJSON (Check fs ghcs c) = cmdJson "check" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c]
+	toJSON (CheckLint fs ghcs lints c) = cmdJson "check-lint" ["files" .= fs, "ghc-opts" .= ghcs, "lint-opts" .= lints, "clear" .= c]
+	toJSON (Types fs ghcs c) = cmdJson "types" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c]
+	toJSON (AutoFix ns) = cmdJson "autofixes" ["messages" .= ns]
+	toJSON (Refactor ns rests pure') = cmdJson "refactor" ["messages" .= ns, "rest" .= rests, "pure" .= pure']
+	toJSON (Rename n n' f) = cmdJson "rename" ["name" .= n, "new-name" .= n', "file" .= f]
+	toJSON (GhcEval exprs f) = cmdJson "ghc eval" ["exprs" .= exprs, "file" .= f]
+	toJSON (GhcType exprs f) = cmdJson "ghc type" ["exprs" .= exprs, "file" .= f]
+	toJSON Langs = cmdJson "langs" []
+	toJSON Flags = cmdJson "flags" []
+	toJSON (Link h) = cmdJson "link" ["hold" .= h]
+	toJSON StopGhc = cmdJson "stop-ghc" []
+	toJSON Exit = cmdJson "exit" []
+
+instance FromJSON Command where
+	parseJSON = withObject "command" $ \v -> asum [
+		guardCmd "ping" v *> pure Ping,
+		guardCmd "listen" v *> (Listen <$> v .::? "level"),
+		guardCmd "set-log" v *> (SetLogLevel <$> v .:: "level"),
+		guardCmd "scan" v *> (Scan <$>
+			v .::?! "projects" <*>
+			(v .:: "cabal" <|> pure False) <*>
+			v .::?! "sandboxes" <*>
+			v .::?! "files" <*>
+			v .::?! "paths" <*>
+			v .::?! "ghc-opts" <*>
+			(v .:: "docs" <|> pure False) <*>
+			(v .:: "infer" <|> pure False)),
+		guardCmd "set-file-contents" v *> (SetFileContents <$> v .:: "file" <*> v .:: "contents"),
+		guardCmd "docs" v *> (RefineDocs <$> v .::?! "projects" <*> v .::?! "files"),
+		guardCmd "infer" v *> (InferTypes <$> v .::?! "projects" <*> v .::?! "files"),
+		guardCmd "remove" v *> (Remove <$>
+			v .::?! "projects" <*>
+			(v .:: "cabal" <|> pure False) <*>
+			v .::?! "sandboxes" <*>
+			v .::?! "files"),
+		guardCmd "remove-all" v *> pure RemoveAll,
+		guardCmd "packages" v *> pure InfoPackages,
+		guardCmd "projects" v *> pure InfoProjects,
+		guardCmd "sandboxes" v *> pure InfoSandboxes,
+		guardCmd "symbol" v *> (InfoSymbol <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> (v .:: "locals" <|> pure False)),
+		guardCmd "module" v *> (InfoModule <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> v .:: "inspection"),
+		guardCmd "project" v *> (InfoProject <$> asum [Left <$> v .:: "name", Right <$> v .:: "path"]),
+		guardCmd "sandbox" v *> (InfoSandbox <$> v .:: "path"),
+		guardCmd "lookup" v *> (Lookup <$> v .:: "name" <*> v .:: "file"),
+		guardCmd "whois" v *> (Whois <$> v .:: "name" <*> v .:: "file"),
+		guardCmd "whoat" v *> (Whoat <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"),
+		guardCmd "scope modules" v *> (ResolveScopeModules <$> v .:: "query" <*> v .:: "file"),
+		guardCmd "scope" v *> (ResolveScope <$> v .:: "query" <*> v .:: "file"),
+		guardCmd "usages" v *> (FindUsages <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"),
+		guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> (v .:: "wide" <|> pure False) <*> v .:: "file"),
+		guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> (v .:: "page" <|> pure 0) <*> (v .:: "pages" <|> pure 1)),
+		guardCmd "cabal list" v *> (CabalList <$> v .::?! "packages"),
+		guardCmd "unresolveds" v *> (UnresolvedSymbols <$> v .::?! "files"),
+		guardCmd "lint" v *> (Lint <$> v .::?! "files" <*> v .::?! "lint-opts"),
+		guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)),
+		guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> v .::?! "lint-opts" <*> (v .:: "clear" <|> pure False)),
+		guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)),
+		guardCmd "autofixes" v *> (AutoFix <$> v .:: "messages"),
+		guardCmd "refactor" v *> (Refactor <$> v .:: "messages" <*> v .::?! "rest" <*> (v .:: "pure" <|> pure True)),
+		guardCmd "rename" v *> (Rename <$> v .:: "name" <*> v .:: "new-name" <*> v .:: "file"),
+		guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs" <*> v .::? "file"),
+		guardCmd "ghc type" v *> (GhcType <$> v .::?! "exprs" <*> v .::? "file"),
+		guardCmd "langs" v *> pure Langs,
+		guardCmd "flags" v *> pure Flags,
+		guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)),
+		guardCmd "stop-ghc" v *> pure StopGhc,
+		guardCmd "exit" v *> pure Exit]
+
+instance ToJSON FileSource where
+	toJSON (FileSource fpath mcts) = object ["file" .= fpath, "contents" .= mcts]
+
+instance FromJSON FileSource where
+	parseJSON = withObject "file-contents" $ \v -> FileSource <$> v .:: "file" <*> v .::? "contents"
+
+instance ToJSON TargetFilter where
+	toJSON (TargetProject pname) = object ["project" .= pname]
+	toJSON (TargetFile fpath) = object ["file" .= fpath]
+	toJSON (TargetModule mname) = object ["module" .= mname]
+	toJSON (TargetPackage pkg) = object ["package" .= pkg]
+	toJSON TargetInstalled = toJSON ("installed" :: String)
+	toJSON TargetSourced = toJSON ("sourced" :: String)
+	toJSON TargetStandalone = toJSON ("standalone" :: String)
+
+instance FromJSON TargetFilter where
+	parseJSON j = obj j <|> str' where
+		obj = withObject "target-filter" $ \v -> asum [
+			TargetProject <$> v .:: "project",
+			TargetFile <$> v .:: "file",
+			TargetModule <$> v .:: "module",
+			TargetPackage <$> v .:: "package"]
+		str' = do
+			s <- parseJSON j :: A.Parser String
+			case s of
+				"installed" -> return TargetInstalled
+				"sourced" -> return TargetSourced
+				"standalone" -> return TargetStandalone
+				_ -> empty
+
+instance ToJSON SearchQuery where
+	toJSON (SearchQuery q st) = object ["input" .= q, "type" .= st]
+
+instance FromJSON SearchQuery where
+	parseJSON = withObject "search-query" $ \v -> SearchQuery <$> (v .:: "input" <|> pure "") <*> (v .:: "type" <|> pure SearchPrefix)
+
+instance ToJSON SearchType where
+	toJSON SearchExact = toJSON ("exact" :: String)
+	toJSON SearchPrefix = toJSON ("prefix" :: String)
+	toJSON SearchInfix = toJSON ("infix" :: String)
+	toJSON SearchSuffix = toJSON ("suffix" :: String)
+
+instance FromJSON SearchType where
+	parseJSON v = do
+		str' <- parseJSON v :: A.Parser String
+		case str' of
+			"exact" -> return SearchExact
+			"prefix" -> return SearchPrefix
+			"infix" -> return SearchInfix
+			"suffix" -> return SearchInfix
+			_ -> empty
src/HsDev/Stack.hs view
@@ -1,136 +1,136 @@-{-# LANGUAGE TemplateHaskell, RankNTypes #-}--module HsDev.Stack (-	stack, yaml,-	path, pathOf,-	build, buildDeps,-	StackEnv(..), stackRoot, stackProject, stackConfig, stackGhc, stackSnapshot, stackLocal,-	getStackEnv, projectEnv,-	stackPackageDbStack,--	stackCompiler, stackArch,--	MaybeT(..)-	) where--import Control.Arrow-import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.))-import Control.Monad-import Control.Monad.Trans.Maybe-import Control.Monad.IO.Class-import Data.Char-import Data.Maybe-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Distribution.Compiler-import Distribution.System-import qualified Distribution.Text as T (display)-import System.Directory-import System.Environment-import System.FilePath-import qualified System.Log.Simple as Log-import Text.Format (formats, (~%))--import qualified GHC-import qualified Packages as GHC--import HsDev.Error-import HsDev.PackageDb-import HsDev.Tools.Ghc.Worker (GhcM, tmpSession)-import qualified HsDev.Tools.Ghc.Compat as Compat-import HsDev.Util as Util-import HsDev.Tools.Base (runTool_)-import qualified System.Directory.Paths as P---- | Get compiler version-stackCompiler :: GhcM String-stackCompiler = do-	tmpSession globalDb ["-no-user-package-db"]-	df <- GHC.getSessionDynFlags-	let-		res =-			map (GHC.packageNameString &&& GHC.packageVersion) .-			fromMaybe [] .-			Compat.pkgDatabase $ df-		compiler = T.display buildCompilerFlavor-		CompilerId _ version' = buildCompilerId-		ver = maybe (T.display version') T.display $ lookup compiler res-	return $ compiler ++ "-" ++ ver---- | Get arch for stack-stackArch :: String-stackArch = T.display buildArch---- | Invoke stack command, we are trying to get actual stack near current hsdev executable-stack :: [String] -> GhcM String-stack cmd' = hsdevLiftIO $ do-	curExe <- liftIO getExecutablePath-	stackExe <- Util.withCurrentDirectory (takeDirectory curExe) $-		liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return-	comp <- stackCompiler-	let-		args' = ["--compiler", comp, "--arch", stackArch] ++ cmd'-	Log.sendLog Log.Trace $ formats "invoking stack: {exe} {args}" [-		"exe" ~% stackExe,-		"args" ~% unwords args']-	liftIO $ runTool_ stackExe args'---- | Make yaml opts-yaml :: Maybe FilePath -> [String]-yaml Nothing = []-yaml (Just y) = ["--stack-yaml", y]--type PathsConf = Map String FilePath---- | Stack path-path :: Maybe FilePath -> GhcM PathsConf-path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where-	breakPath :: String -> (String, FilePath)-	breakPath = second (dropWhile isSpace . drop 1) . break (== ':')---- | Get path for-pathOf :: String -> Lens' PathsConf (Maybe FilePath)-pathOf = at---- | Build stack project-build :: [String] -> Maybe FilePath -> GhcM ()-build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg)---- | Build only dependencies-buildDeps :: Maybe FilePath -> GhcM ()-buildDeps = build ["--only-dependencies"]--data StackEnv = StackEnv {-	_stackRoot :: FilePath,-	_stackProject :: FilePath,-	_stackConfig :: FilePath,-	_stackGhc :: FilePath,-	_stackSnapshot :: FilePath,-	_stackLocal :: FilePath }--makeLenses ''StackEnv--getStackEnv :: PathsConf -> Maybe StackEnv-getStackEnv p = StackEnv <$>-	(p ^. pathOf "stack-root") <*>-	(p ^. pathOf "project-root") <*>-	(p ^. pathOf "config-location") <*>-	(p ^. pathOf "ghc-paths") <*>-	(p ^. pathOf "snapshot-pkg-db") <*>-	(p ^. pathOf "local-pkg-db")---- | Projects paths-projectEnv :: FilePath -> GhcM StackEnv-projectEnv p = hsdevLiftIO $ Util.withCurrentDirectory p $ do-	paths' <- path Nothing-	maybe (hsdevError $ ToolError "stack" ("can't get paths for " ++ p)) return $ getStackEnv paths'---- | Get package-db stack for stack environment-stackPackageDbStack :: Lens' StackEnv PackageDbStack-stackPackageDbStack = lens g s where-	g :: StackEnv -> PackageDbStack-	g env' = PackageDbStack $ map (PackageDb . P.fromFilePath) [_stackLocal env', _stackSnapshot env']-	s :: StackEnv -> PackageDbStack -> StackEnv-	s env' pdbs = env' {-		_stackSnapshot = fromMaybe (_stackSnapshot env') $ pdbs ^? packageDbStack . ix 1 . packageDb . P.path,-		_stackLocal = fromMaybe (_stackLocal env') $ pdbs ^? packageDbStack . ix 0 . packageDb . P.path }+{-# LANGUAGE TemplateHaskell, RankNTypes #-}
+
+module HsDev.Stack (
+	stack, yaml,
+	path, pathOf,
+	build, buildDeps,
+	StackEnv(..), stackRoot, stackProject, stackConfig, stackGhc, stackSnapshot, stackLocal,
+	getStackEnv, projectEnv,
+	stackPackageDbStack,
+
+	stackCompiler, stackArch,
+
+	MaybeT(..)
+	) where
+
+import Control.Arrow
+import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.))
+import Control.Monad
+import Control.Monad.Trans.Maybe
+import Control.Monad.IO.Class
+import Data.Char
+import Data.Maybe
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Distribution.Compiler
+import Distribution.System
+import qualified Distribution.Text as T (display)
+import System.Directory
+import System.Environment
+import System.FilePath
+import qualified System.Log.Simple as Log
+import Text.Format (formats, (~%))
+
+import qualified GHC
+import qualified Packages as GHC
+
+import HsDev.Error
+import HsDev.PackageDb
+import HsDev.Tools.Ghc.Worker (GhcM, tmpSession)
+import qualified HsDev.Tools.Ghc.Compat as Compat
+import HsDev.Util as Util
+import HsDev.Tools.Base (runTool_)
+import qualified System.Directory.Paths as P
+
+-- | Get compiler version
+stackCompiler :: GhcM String
+stackCompiler = do
+	tmpSession globalDb ["-no-user-package-db"]
+	df <- GHC.getSessionDynFlags
+	let
+		res =
+			map (GHC.packageNameString &&& GHC.packageVersion) .
+			fromMaybe [] .
+			Compat.pkgDatabase $ df
+		compiler = T.display buildCompilerFlavor
+		CompilerId _ version' = buildCompilerId
+		ver = maybe (T.display version') T.display $ lookup compiler res
+	return $ compiler ++ "-" ++ ver
+
+-- | Get arch for stack
+stackArch :: String
+stackArch = T.display buildArch
+
+-- | Invoke stack command, we are trying to get actual stack near current hsdev executable
+stack :: [String] -> GhcM String
+stack cmd' = hsdevLiftIO $ do
+	curExe <- liftIO getExecutablePath
+	stackExe <- Util.withCurrentDirectory (takeDirectory curExe) $
+		liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return
+	comp <- stackCompiler
+	let
+		args' = ["--compiler", comp, "--arch", stackArch] ++ cmd'
+	Log.sendLog Log.Trace $ formats "invoking stack: {exe} {args}" [
+		"exe" ~% stackExe,
+		"args" ~% unwords args']
+	liftIO $ runTool_ stackExe args'
+
+-- | Make yaml opts
+yaml :: Maybe FilePath -> [String]
+yaml Nothing = []
+yaml (Just y) = ["--stack-yaml", y]
+
+type PathsConf = Map String FilePath
+
+-- | Stack path
+path :: Maybe FilePath -> GhcM PathsConf
+path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where
+	breakPath :: String -> (String, FilePath)
+	breakPath = second (dropWhile isSpace . drop 1) . break (== ':')
+
+-- | Get path for
+pathOf :: String -> Lens' PathsConf (Maybe FilePath)
+pathOf = at
+
+-- | Build stack project
+build :: [String] -> Maybe FilePath -> GhcM ()
+build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg)
+
+-- | Build only dependencies
+buildDeps :: Maybe FilePath -> GhcM ()
+buildDeps = build ["--only-dependencies"]
+
+data StackEnv = StackEnv {
+	_stackRoot :: FilePath,
+	_stackProject :: FilePath,
+	_stackConfig :: FilePath,
+	_stackGhc :: FilePath,
+	_stackSnapshot :: FilePath,
+	_stackLocal :: FilePath }
+
+makeLenses ''StackEnv
+
+getStackEnv :: PathsConf -> Maybe StackEnv
+getStackEnv p = StackEnv <$>
+	(p ^. pathOf "stack-root") <*>
+	(p ^. pathOf "project-root") <*>
+	(p ^. pathOf "config-location") <*>
+	(p ^. pathOf "ghc-paths") <*>
+	(p ^. pathOf "snapshot-pkg-db") <*>
+	(p ^. pathOf "local-pkg-db")
+
+-- | Projects paths
+projectEnv :: FilePath -> GhcM StackEnv
+projectEnv p = hsdevLiftIO $ Util.withCurrentDirectory p $ do
+	paths' <- path Nothing
+	maybe (hsdevError $ ToolError "stack" ("can't get paths for " ++ p)) return $ getStackEnv paths'
+
+-- | Get package-db stack for stack environment
+stackPackageDbStack :: Lens' StackEnv PackageDbStack
+stackPackageDbStack = lens g s where
+	g :: StackEnv -> PackageDbStack
+	g env' = PackageDbStack $ map (PackageDb . P.fromFilePath) [_stackLocal env', _stackSnapshot env']
+	s :: StackEnv -> PackageDbStack -> StackEnv
+	s env' pdbs = env' {
+		_stackSnapshot = fromMaybe (_stackSnapshot env') $ pdbs ^? packageDbStack . ix 1 . packageDb . P.path,
+		_stackLocal = fromMaybe (_stackLocal env') $ pdbs ^? packageDbStack . ix 0 . packageDb . P.path }
src/HsDev/Symbols.hs view
@@ -1,137 +1,137 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Symbols (-	-- * Utility-	locateProject, searchProject,-	locateSourceDir,-	standaloneInfo,-	moduleOpts, projectTargetOpts,--	-- * Tags-	setTag, hasTag, removeTag, dropTags,-	inspectTag, inspectUntag,--	-- * Reexportss-	module HsDev.Symbols.Types,-	module HsDev.Symbols.Class,-	module HsDev.Symbols.Documented,-	module HsDev.Symbols.HaskellNames-	) where--import Control.Applicative-import Control.Lens-import Control.Monad.Trans.Maybe-import Control.Monad.Except-import Control.Monad.State-import Data.List-import Data.Maybe (fromMaybe, listToMaybe, catMaybes)-import qualified Data.Map.Strict as M-import qualified Data.Set as S-import System.Directory-import System.FilePath--import HsDev.Symbols.Types-import HsDev.Symbols.Class-import HsDev.Symbols.Documented (Documented(..))-import HsDev.Symbols.HaskellNames-import HsDev.Util (searchPath, uniqueBy, directoryContents)-import System.Directory.Paths---- | Find project file is related to-locateProject :: FilePath -> IO (Maybe Project)-locateProject file = do-	file' <- canonicalizePath file-	isDir <- doesDirectoryExist file'-	if isDir then locateHere file' else locateParent (takeDirectory file')-	where-		locateHere p = do-			cts <- filter (not . null . takeBaseName) <$> directoryContents p-			return $ fmap (project . (p </>)) $ find ((== ".cabal") . takeExtension) cts-		locateParent dir = do-			cts <- filter (not . null . takeBaseName) <$> directoryContents dir-			case find ((== ".cabal") . takeExtension) cts of-				Nothing -> if isDrive dir then return Nothing else locateParent (takeDirectory dir)-				Just cabalf -> return $ Just $ project (dir </> cabalf)---- | Search project up-searchProject :: FilePath -> IO (Maybe Project)-searchProject file = runMaybeT $ searchPath file (MaybeT . locateProject) <|> mzero---- | Locate source dir of file-locateSourceDir :: FilePath -> IO (Maybe (Extensions Path))-locateSourceDir f = runMaybeT $ do-	file <- liftIO $ canonicalizePath f-	p <- MaybeT $ locateProject file-	proj <- lift $ loadProject p-	MaybeT $ return $ findSourceDir proj (fromFilePath file)---- | Make `Info` for standalone `Module`-standaloneInfo :: [PackageConfig] -> Module -> Info-standaloneInfo pkgs m = mempty { _infoDepends = pkgDeps ^.. each . package . packageName } where-	pkgDeps = catMaybes [M.lookup mdep pkgMap >>= listToMaybe | mdep <- "Prelude" : imps]-	pkgMap = M.unionsWith mergePkgs [M.singleton m' [p] | p <- pkgs, m' <- view packageModules p]-	mergePkgs ls rs = if null es then hs else es where-		(es, hs) = partition (view packageExposed) $ uniqueBy (view package) (ls ++ rs)-	imps = delete (view (moduleId . moduleName) m) (m ^.. moduleImports . each . importName)---- | Options for GHC of module and project-moduleOpts :: [PackageConfig] -> Module -> [String]-moduleOpts pkgs m = case view (moduleId . moduleLocation) m of-	FileModule file proj -> concat [-		hidePackages,-		targetOpts absInfo]-		where-			infos' = maybe [standaloneInfo pkgs m] (`fileTargets` file) proj-			info' = over infoDepends (filter validDep) (mconcat $ selfInfo : infos')-			absInfo = maybe id (absolutise . view projectPath) proj info'-			selfInfo-				| proj ^? _Just . projectName `elem` map Just (infos' ^.. each . infoDepends . each) = fromMaybe mempty $-					proj ^? _Just . projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo-				| otherwise = mempty-			-- filter out unavailable packages such as unix under windows-			validDep d = d `elem` pkgs'-			pkgs' = pkgs ^.. each . package . packageName-			hidePackages-				| null (info' ^. infoDepends) = []-				| otherwise = ["-hide-all-packages"]-	_ -> []---- | Options for GHC of project-projectTargetOpts :: [PackageConfig] -> Project -> Info -> [String]-projectTargetOpts pkgs proj info = concat [hidePackages, targetOpts absInfo] where-	info' = over infoDepends (filter validDep) (selfInfo `mappend` info)-	absInfo = absolutise (view projectPath proj) info'-	selfInfo-		| proj ^. projectName `elem` (info ^.. infoDepends . each) = fromMaybe mempty $-			proj ^? projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo-		| otherwise = mempty-	validDep d = d `elem` pkgs'-	pkgs' = pkgs ^.. each . package . packageName-	hidePackages-		| null (info' ^. infoDepends) = []-		| otherwise = ["-hide-all-packages"]---- | Set tag to `Inspected`-setTag :: Ord t => t -> Inspected i t a -> Inspected i t a-setTag tag' = over inspectionTags (S.insert tag')---- | Check whether `Inspected` has tag-hasTag :: Ord t => t -> Inspected i t a -> Bool-hasTag tag' = has (inspectionTags . ix tag')---- | Drop tag from `Inspected`-removeTag :: Ord t => t -> Inspected i t a -> Inspected i t a-removeTag tag' = over inspectionTags (S.delete tag')---- | Drop all tags-dropTags :: Inspected i t a -> Inspected i t a-dropTags = set inspectionTags S.empty---- | Set inspection tag-inspectTag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a-inspectTag tag' act = act <* modify (over _2 (S.insert tag'))---- | Unser inspection tag-inspectUntag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a-inspectUntag tag' act = act <* modify (over _2 (S.delete tag'))+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Symbols (
+	-- * Utility
+	locateProject, searchProject,
+	locateSourceDir,
+	standaloneInfo,
+	moduleOpts, projectTargetOpts,
+
+	-- * Tags
+	setTag, hasTag, removeTag, dropTags,
+	inspectTag, inspectUntag,
+
+	-- * Reexportss
+	module HsDev.Symbols.Types,
+	module HsDev.Symbols.Class,
+	module HsDev.Symbols.Documented,
+	module HsDev.Symbols.HaskellNames
+	) where
+
+import Control.Applicative
+import Control.Lens
+import Control.Monad.Trans.Maybe
+import Control.Monad.Except
+import Control.Monad.State
+import Data.List
+import Data.Maybe (fromMaybe, listToMaybe, catMaybes)
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import System.Directory
+import System.FilePath
+
+import HsDev.Symbols.Types
+import HsDev.Symbols.Class
+import HsDev.Symbols.Documented (Documented(..))
+import HsDev.Symbols.HaskellNames
+import HsDev.Util (searchPath, uniqueBy, directoryContents)
+import System.Directory.Paths
+
+-- | Find project file is related to
+locateProject :: FilePath -> IO (Maybe Project)
+locateProject file = do
+	file' <- canonicalizePath file
+	isDir <- doesDirectoryExist file'
+	if isDir then locateHere file' else locateParent (takeDirectory file')
+	where
+		locateHere p = do
+			cts <- filter (not . null . takeBaseName) <$> directoryContents p
+			return $ fmap (project . (p </>)) $ find ((== ".cabal") . takeExtension) cts
+		locateParent dir = do
+			cts <- filter (not . null . takeBaseName) <$> directoryContents dir
+			case find ((== ".cabal") . takeExtension) cts of
+				Nothing -> if isDrive dir then return Nothing else locateParent (takeDirectory dir)
+				Just cabalf -> return $ Just $ project (dir </> cabalf)
+
+-- | Search project up
+searchProject :: FilePath -> IO (Maybe Project)
+searchProject file = runMaybeT $ searchPath file (MaybeT . locateProject) <|> mzero
+
+-- | Locate source dir of file
+locateSourceDir :: FilePath -> IO (Maybe (Extensions Path))
+locateSourceDir f = runMaybeT $ do
+	file <- liftIO $ canonicalizePath f
+	p <- MaybeT $ locateProject file
+	proj <- lift $ loadProject p
+	MaybeT $ return $ findSourceDir proj (fromFilePath file)
+
+-- | Make `Info` for standalone `Module`
+standaloneInfo :: [PackageConfig] -> Module -> Info
+standaloneInfo pkgs m = mempty { _infoDepends = pkgDeps ^.. each . package . packageName } where
+	pkgDeps = catMaybes [M.lookup mdep pkgMap >>= listToMaybe | mdep <- "Prelude" : imps]
+	pkgMap = M.unionsWith mergePkgs [M.singleton m' [p] | p <- pkgs, m' <- view packageModules p]
+	mergePkgs ls rs = if null es then hs else es where
+		(es, hs) = partition (view packageExposed) $ uniqueBy (view package) (ls ++ rs)
+	imps = delete (view (moduleId . moduleName) m) (m ^.. moduleImports . each . importName)
+
+-- | Options for GHC of module and project
+moduleOpts :: [PackageConfig] -> Module -> [String]
+moduleOpts pkgs m = case view (moduleId . moduleLocation) m of
+	FileModule file proj -> concat [
+		hidePackages,
+		targetOpts absInfo]
+		where
+			infos' = maybe [standaloneInfo pkgs m] (`fileTargets` file) proj
+			info' = over infoDepends (filter validDep) (mconcat $ selfInfo : infos')
+			absInfo = maybe id (absolutise . view projectPath) proj info'
+			selfInfo
+				| proj ^? _Just . projectName `elem` map Just (infos' ^.. each . infoDepends . each) = fromMaybe mempty $
+					proj ^? _Just . projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo
+				| otherwise = mempty
+			-- filter out unavailable packages such as unix under windows
+			validDep d = d `elem` pkgs'
+			pkgs' = pkgs ^.. each . package . packageName
+			hidePackages
+				| null (info' ^. infoDepends) = []
+				| otherwise = ["-hide-all-packages"]
+	_ -> []
+
+-- | Options for GHC of project
+projectTargetOpts :: [PackageConfig] -> Project -> Info -> [String]
+projectTargetOpts pkgs proj info = concat [hidePackages, targetOpts absInfo] where
+	info' = over infoDepends (filter validDep) (selfInfo `mappend` info)
+	absInfo = absolutise (view projectPath proj) info'
+	selfInfo
+		| proj ^. projectName `elem` (info ^.. infoDepends . each) = fromMaybe mempty $
+			proj ^? projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo
+		| otherwise = mempty
+	validDep d = d `elem` pkgs'
+	pkgs' = pkgs ^.. each . package . packageName
+	hidePackages
+		| null (info' ^. infoDepends) = []
+		| otherwise = ["-hide-all-packages"]
+
+-- | Set tag to `Inspected`
+setTag :: Ord t => t -> Inspected i t a -> Inspected i t a
+setTag tag' = over inspectionTags (S.insert tag')
+
+-- | Check whether `Inspected` has tag
+hasTag :: Ord t => t -> Inspected i t a -> Bool
+hasTag tag' = has (inspectionTags . ix tag')
+
+-- | Drop tag from `Inspected`
+removeTag :: Ord t => t -> Inspected i t a -> Inspected i t a
+removeTag tag' = over inspectionTags (S.delete tag')
+
+-- | Drop all tags
+dropTags :: Inspected i t a -> Inspected i t a
+dropTags = set inspectionTags S.empty
+
+-- | Set inspection tag
+inspectTag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a
+inspectTag tag' act = act <* modify (over _2 (S.insert tag'))
+
+-- | Unser inspection tag
+inspectUntag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a
+inspectUntag tag' act = act <* modify (over _2 (S.delete tag'))
src/HsDev/Symbols/Class.hs view
@@ -1,30 +1,30 @@-module HsDev.Symbols.Class (-	Sourced(..),-	sourcedModuleName,--	module HsDev.Symbols.Location-	) where--import Control.Lens (Lens', Traversal')-import Data.Text (Text)--import HsDev.Symbols.Location--class Sourced a where-	sourcedName :: Lens' a Text-	sourcedDocs :: Traversal' a Text-	sourcedModule :: Lens' a ModuleId-	sourcedLocation :: Traversal' a Position-	sourcedDocs _ = pure-	sourcedLocation _ = pure--instance Sourced ModuleId where-	sourcedName = moduleName-	sourcedModule = id--instance Sourced SymbolId where-	sourcedName = symbolName-	sourcedModule = symbolModule--sourcedModuleName :: Sourced a => Lens' a Text-sourcedModuleName = sourcedModule . sourcedName+module HsDev.Symbols.Class (
+	Sourced(..),
+	sourcedModuleName,
+
+	module HsDev.Symbols.Location
+	) where
+
+import Control.Lens (Lens', Traversal')
+import Data.Text (Text)
+
+import HsDev.Symbols.Location
+
+class Sourced a where
+	sourcedName :: Lens' a Text
+	sourcedDocs :: Traversal' a Text
+	sourcedModule :: Lens' a ModuleId
+	sourcedLocation :: Traversal' a Position
+	sourcedDocs _ = pure
+	sourcedLocation _ = pure
+
+instance Sourced ModuleId where
+	sourcedName = moduleName
+	sourcedModule = id
+
+instance Sourced SymbolId where
+	sourcedName = symbolName
+	sourcedModule = symbolModule
+
+sourcedModuleName :: Sourced a => Lens' a Text
+sourcedModuleName = sourcedModule . sourcedName
src/HsDev/Symbols/Documented.hs view
@@ -1,62 +1,62 @@-{-# LANGUAGE DefaultSignatures, OverloadedStrings #-}--module HsDev.Symbols.Documented (-	Documented(..),-	defaultDetailed-	) where--import Control.Lens (view, (^..), (^?))-import Data.Maybe (maybeToList)-import Data.Text (Text, pack)-import qualified Data.Text as T--import Text.Format-import HsDev.Symbols.Class-import HsDev.Project.Types---- | Documented symbol-class Documented a where-	brief :: a -> Text-	detailed :: a -> Text-	default detailed :: Sourced a => a -> Text-	detailed = T.unlines . defaultDetailed---- | Default detailed docs-defaultDetailed :: (Sourced a, Documented a) => a -> [Text]-defaultDetailed s = concat [header, docs, loc] where-	header = [brief s, ""]-	docs = s ^.. sourcedDocs-	loc = maybe [] (\l -> ["Defined at " `T.append` pack (show l)]) (s ^? sourcedLocation)--instance Documented ModulePackage where-	brief = pack . show-	detailed = brief--instance Documented ModuleLocation where-	brief (FileModule f _) = f-	brief (InstalledModule _ pkg n _) = format "{} from {}" ~~ n ~~ brief pkg-	brief (OtherLocation src) = src-	brief NoLocation = "<no-location>"-	detailed (FileModule f mproj) = case mproj of-		Nothing -> f-		Just proj -> format "{} in project {}" ~~ f ~~ brief proj-	detailed (InstalledModule pdb pkg n _) = format "{} from {} ({})" ~~ n ~~ brief pkg ~~ show pdb-	detailed l = brief l--instance Documented Project where-	brief p = format "{} ({})" ~~ view projectName p ~~ view projectPath p-	detailed p = T.unlines (brief p : desc) where-		desc = concat [-			do-				d <- mdescr-				_ <- maybeToList $ view projectLibrary d-				return "\tlibrary",-			do-				d <- mdescr-				exe <- view projectExecutables d-				return $ format "\texecutable: {}" ~~ view executableName exe,-			do-				d <- mdescr-				test <- view projectTests d-				return $ format "\ttest: {}" ~~ view testName test]-		mdescr = maybeToList $ view projectDescription p+{-# LANGUAGE DefaultSignatures, OverloadedStrings #-}
+
+module HsDev.Symbols.Documented (
+	Documented(..),
+	defaultDetailed
+	) where
+
+import Control.Lens (view, (^..), (^?))
+import Data.Maybe (maybeToList)
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+
+import Text.Format
+import HsDev.Symbols.Class
+import HsDev.Project.Types
+
+-- | Documented symbol
+class Documented a where
+	brief :: a -> Text
+	detailed :: a -> Text
+	default detailed :: Sourced a => a -> Text
+	detailed = T.unlines . defaultDetailed
+
+-- | Default detailed docs
+defaultDetailed :: (Sourced a, Documented a) => a -> [Text]
+defaultDetailed s = concat [header, docs, loc] where
+	header = [brief s, ""]
+	docs = s ^.. sourcedDocs
+	loc = maybe [] (\l -> ["Defined at " `T.append` pack (show l)]) (s ^? sourcedLocation)
+
+instance Documented ModulePackage where
+	brief = pack . show
+	detailed = brief
+
+instance Documented ModuleLocation where
+	brief (FileModule f _) = f
+	brief (InstalledModule _ pkg n _) = format "{} from {}" ~~ n ~~ brief pkg
+	brief (OtherLocation src) = src
+	brief NoLocation = "<no-location>"
+	detailed (FileModule f mproj) = case mproj of
+		Nothing -> f
+		Just proj -> format "{} in project {}" ~~ f ~~ brief proj
+	detailed (InstalledModule pdb pkg n _) = format "{} from {} ({})" ~~ n ~~ brief pkg ~~ show pdb
+	detailed l = brief l
+
+instance Documented Project where
+	brief p = format "{} ({})" ~~ view projectName p ~~ view projectPath p
+	detailed p = T.unlines (brief p : desc) where
+		desc = concat [
+			do
+				d <- mdescr
+				_ <- maybeToList $ view projectLibrary d
+				return "\tlibrary",
+			do
+				d <- mdescr
+				exe <- view projectExecutables d
+				return $ format "\texecutable: {}" ~~ view executableName exe,
+			do
+				d <- mdescr
+				test <- view projectTests d
+				return $ format "\ttest: {}" ~~ view testName test]
+		mdescr = maybeToList $ view projectDescription p
src/HsDev/Symbols/HaskellNames.hs view
@@ -1,61 +1,61 @@-{-# LANGUAGE FlexibleInstances #-}--module HsDev.Symbols.HaskellNames (-	ToEnvironment(..),-	fromSymbol, toSymbol-	) where--import Control.Lens (view)-import Data.String-import qualified Data.Map.Strict as M-import qualified Data.Text as T (unpack)-import qualified Language.Haskell.Exts as H-import qualified Language.Haskell.Names as N--import HsDev.Symbols.Types--class ToEnvironment a where-	environment :: a -> N.Environment--instance ToEnvironment Module where-	environment m = M.singleton (H.ModuleName () (T.unpack $ view sourcedName m)) (map toSymbol $ view moduleExports m)--instance ToEnvironment [Module] where-	environment = M.unions . map environment--fromSymbol :: N.Symbol -> Symbol-fromSymbol s = Symbol sid Nothing Nothing info where-	sid = SymbolId (fromName_ $ N.symbolName s) mid-	mid = case N.symbolModule s of-		H.ModuleName _ m -> ModuleId (fromString m) NoLocation-	info = case s of-		N.Value _ _ -> Function mempty-		N.Method _ _ p -> Method mempty (fromName_ p)-		N.Selector _ _ p cs -> Selector mempty (fromName_ p) (map fromName_ cs)-		N.Constructor _ _ p -> Constructor mempty (fromName_ p)-		N.Type _ _ -> Type mempty mempty-		N.NewType _ _ -> NewType mempty mempty-		N.Data _ _ -> Data mempty mempty-		N.Class _ _ -> Class mempty mempty-		N.TypeFam _ _ a -> TypeFam mempty mempty (fmap fromName_ a)-		N.DataFam _ _ a -> DataFam mempty mempty (fmap fromName_ a)-		N.PatternConstructor _ _ p -> PatConstructor mempty (fmap fromName_ p)-		N.PatternSelector _ _ p c -> PatSelector mempty (fmap fromName_ p) (fromName_ c)--toSymbol :: Symbol -> N.Symbol-toSymbol s = case view symbolInfo s of-	Function _ -> N.Value m n-	Method _ p -> N.Method m n (toName_ p)-	Selector _ p cs -> N.Selector m n (toName_ p) (map toName_ cs)-	Constructor _ p -> N.Constructor m n (toName_ p)-	Type _ _ -> N.Type m n-	NewType _ _ -> N.NewType m n-	Data _ _ -> N.Data m n-	Class _ _ -> N.Class m n-	TypeFam _ _ a -> N.TypeFam m n (fmap toName_ a)-	DataFam _ _ a -> N.DataFam m n (fmap toName_ a)-	PatConstructor _ p -> N.PatternConstructor m n (fmap toName_ p)-	PatSelector _ p c -> N.PatternSelector m n (fmap toName_ p) (toName_ c)-	where-		m = toModuleName_ $ view sourcedModuleName s-		n = toName_ $ view sourcedName s+{-# LANGUAGE FlexibleInstances #-}
+
+module HsDev.Symbols.HaskellNames (
+	ToEnvironment(..),
+	fromSymbol, toSymbol
+	) where
+
+import Control.Lens (view)
+import Data.String
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T (unpack)
+import qualified Language.Haskell.Exts as H
+import qualified Language.Haskell.Names as N
+
+import HsDev.Symbols.Types
+
+class ToEnvironment a where
+	environment :: a -> N.Environment
+
+instance ToEnvironment Module where
+	environment m = M.singleton (H.ModuleName () (T.unpack $ view sourcedName m)) (map toSymbol $ view moduleExports m)
+
+instance ToEnvironment [Module] where
+	environment = M.unions . map environment
+
+fromSymbol :: N.Symbol -> Symbol
+fromSymbol s = Symbol sid Nothing Nothing info where
+	sid = SymbolId (fromName_ $ N.symbolName s) mid
+	mid = case N.symbolModule s of
+		H.ModuleName _ m -> ModuleId (fromString m) NoLocation
+	info = case s of
+		N.Value _ _ -> Function mempty
+		N.Method _ _ p -> Method mempty (fromName_ p)
+		N.Selector _ _ p cs -> Selector mempty (fromName_ p) (map fromName_ cs)
+		N.Constructor _ _ p -> Constructor mempty (fromName_ p)
+		N.Type _ _ -> Type mempty mempty
+		N.NewType _ _ -> NewType mempty mempty
+		N.Data _ _ -> Data mempty mempty
+		N.Class _ _ -> Class mempty mempty
+		N.TypeFam _ _ a -> TypeFam mempty mempty (fmap fromName_ a)
+		N.DataFam _ _ a -> DataFam mempty mempty (fmap fromName_ a)
+		N.PatternConstructor _ _ p -> PatConstructor mempty (fmap fromName_ p)
+		N.PatternSelector _ _ p c -> PatSelector mempty (fmap fromName_ p) (fromName_ c)
+
+toSymbol :: Symbol -> N.Symbol
+toSymbol s = case view symbolInfo s of
+	Function _ -> N.Value m n
+	Method _ p -> N.Method m n (toName_ p)
+	Selector _ p cs -> N.Selector m n (toName_ p) (map toName_ cs)
+	Constructor _ p -> N.Constructor m n (toName_ p)
+	Type _ _ -> N.Type m n
+	NewType _ _ -> N.NewType m n
+	Data _ _ -> N.Data m n
+	Class _ _ -> N.Class m n
+	TypeFam _ _ a -> N.TypeFam m n (fmap toName_ a)
+	DataFam _ _ a -> N.DataFam m n (fmap toName_ a)
+	PatConstructor _ p -> N.PatternConstructor m n (fmap toName_ p)
+	PatSelector _ p c -> N.PatternSelector m n (fmap toName_ p) (toName_ c)
+	where
+		m = toModuleName_ $ view sourcedModuleName s
+		n = toName_ $ view sourcedName s
src/HsDev/Symbols/Location.hs view
@@ -1,367 +1,367 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}--module HsDev.Symbols.Location (-	ModulePackage(..), mkPackage, PackageConfig(..),-	ModuleLocation(..), locationId, noLocation,-	ModuleId(..), moduleName, moduleLocation,-	SymbolId(..), symbolName, symbolModule,-	Position(..), Region(..), region, regionAt, regionLines, regionStr,-	Location(..),--	packageName, packageVersion,-	package, packageModules, packageExposed,-	moduleFile, moduleProject, moduleInstallDirs, modulePackage, installedModuleName, installedModuleExposed, otherLocationName,-	positionLine, positionColumn,-	regionFrom, regionTo,-	locationModule, locationPosition,--	sourceModuleRoot,-	importPath,-	sourceRoot, sourceRoot_,-	RecalcTabs(..),--	module HsDev.PackageDb.Types-	) where--import Control.Applicative-import Control.DeepSeq (NFData(..))-import Control.Lens (makeLenses, view, preview, over)-import Data.Aeson-import Data.Char (isSpace, isDigit)-import Data.List (findIndex)-import Data.Maybe-import Data.Text (Text, pack, unpack)-import Data.Text.Lens (unpacked)-import qualified Data.Text as T-import System.FilePath-import Text.Read (readMaybe)-import Text.Format--import System.Directory.Paths-import HsDev.Display-import HsDev.PackageDb.Types-import HsDev.Project.Types-import HsDev.Util ((.::), (.::?), (.::?!), objectUnion, noNulls)---- | Just package name and version without its location-data ModulePackage = ModulePackage {-	_packageName :: Text,-	_packageVersion :: Text }-		deriving (Eq, Ord)--makeLenses ''ModulePackage--mkPackage :: Text -> ModulePackage-mkPackage n = ModulePackage n ""--instance NFData ModulePackage where-	rnf (ModulePackage n v) = rnf n `seq` rnf v--instance Show ModulePackage where-	show (ModulePackage n "") = unpack n-	show (ModulePackage n v) = unpack n ++ "-" ++ unpack v--instance Read ModulePackage where-	readsPrec _ str = case pkg of-		"" -> []-		_ -> [(ModulePackage (pack n) (pack v), str')]-		where-			(pkg, str') = break isSpace str-			(rv, rn) = span versionChar $ reverse pkg-			v = reverse rv-			n = reverse $ dropWhile (== '-') rn--			versionChar ch = isDigit ch || ch == '.'--instance ToJSON ModulePackage where-	toJSON (ModulePackage n v) = object [-		"name" .= n,-		"version" .= v]--instance FromJSON ModulePackage where-	parseJSON = withObject "module package" $ \v ->-		ModulePackage <$> (v .:: "name") <*> (v .:: "version")--data PackageConfig = PackageConfig {-	_package :: ModulePackage,-	_packageModules :: [Text],-	_packageExposed :: Bool }-		deriving (Eq, Ord, Read, Show)--makeLenses ''PackageConfig--instance NFData PackageConfig where-	rnf (PackageConfig p ms e) = rnf p `seq` rnf ms `seq` rnf e--instance ToJSON PackageConfig where-	toJSON (PackageConfig p ms e) = toJSON p `objectUnion` object ["modules" .= ms, "exposed" .= e]--instance FromJSON PackageConfig where-	parseJSON = withObject "package-config" $ \v -> PackageConfig <$>-		parseJSON (Object v) <*>-		(v .::?! "modules") <*>-		(v .:: "exposed" <|> pure False)---- | Location of module-data ModuleLocation =-	FileModule { _moduleFile :: Path, _moduleProject :: Maybe Project } |-	InstalledModule { _moduleInstallDirs :: [Path], _modulePackage :: ModulePackage, _installedModuleName :: Text, _installedModuleExposed :: Bool } |-	OtherLocation { _otherLocationName :: Text } |-	NoLocation--instance Eq ModuleLocation where-	FileModule lfile _ == FileModule rfile _ = lfile == rfile-	InstalledModule ldirs _ lname _ == InstalledModule rdirs _ rname _ = ldirs == rdirs && lname == rname-	OtherLocation l == OtherLocation r = l == r-	NoLocation == NoLocation = True-	_ == _ = False--instance Ord ModuleLocation where-	compare l r = compare (locType l, locNames l) (locType r, locNames r) where-		locType :: ModuleLocation -> Int-		locType (FileModule _ _) = 0-		locType (InstalledModule _ _ _ _) = 1-		locType (OtherLocation _) = 2-		locType NoLocation = 3-		locNames (FileModule f _) = [f]-		locNames (InstalledModule dirs _ nm _) = nm : dirs-		locNames (OtherLocation n) = [n]-		locNames NoLocation = []--makeLenses ''ModuleLocation--locationId :: ModuleLocation -> Text-locationId (FileModule fpath _) = fpath-locationId (InstalledModule dirs mpack nm _) = T.intercalate ":" (take 1 dirs ++ [pack (show mpack), nm])-locationId (OtherLocation src) = src-locationId NoLocation = "<no-location>"--instance NFData ModuleLocation where-	rnf (FileModule f p) = rnf f `seq` rnf p-	rnf (InstalledModule d p n e) = rnf d `seq` rnf p `seq` rnf n `seq` rnf e-	rnf (OtherLocation s) = rnf s-	rnf NoLocation = ()--instance Show ModuleLocation where-	show = unpack . locationId--instance Display ModuleLocation where-	display (FileModule f _) = display f-	display (InstalledModule _ _ n _) = view unpacked n-	display (OtherLocation s) = view unpacked s-	display NoLocation = "<no-location>"-	displayType _ = "module"--instance Formattable ModuleLocation where-	formattable = formattable . display--instance ToJSON ModuleLocation where-	toJSON (FileModule f p) = object $ noNulls ["file" .= f, "project" .= fmap (view projectCabal) p]-	toJSON (InstalledModule c p n e) = object $ noNulls ["dirs" .= c, "package" .= show p, "name" .= n, "exposed" .= e]-	toJSON (OtherLocation s) = object ["source" .= s]-	toJSON NoLocation = object []--instance FromJSON ModuleLocation where-	parseJSON = withObject "module location" $ \v ->-		(FileModule <$> v .:: "file" <*> (fmap project <$> (v .::? "project"))) <|>-		(InstalledModule <$> v .::?! "dirs" <*> (readPackage =<< (v .:: "package")) <*> v .:: "name" <*> v .:: "exposed") <|>-		(OtherLocation <$> v .:: "source") <|>-		(pure NoLocation)-		where-			readPackage s = maybe (fail $ "can't parse package: " ++ s) return . readMaybe $ s--instance Paths ModuleLocation where-	paths f (FileModule fpath p) = FileModule <$> paths f fpath <*> traverse (paths f) p-	paths f (InstalledModule c p n e) = InstalledModule <$> traverse (paths f) c <*> pure p <*> pure n <*> pure e-	paths _ (OtherLocation s) = pure $ OtherLocation s-	paths _ NoLocation = pure NoLocation--noLocation :: ModuleLocation-noLocation = NoLocation--data ModuleId = ModuleId {-	_moduleName :: Text,-	_moduleLocation :: ModuleLocation }-		deriving (Eq, Ord)--makeLenses ''ModuleId--instance NFData ModuleId where-	rnf (ModuleId n l) = rnf n `seq` rnf l--instance Show ModuleId where-	show (ModuleId n l) = show l ++ ":" ++ unpack n--instance ToJSON ModuleId where-	toJSON m = object $ noNulls [-		"name" .= _moduleName m,-		"location" .= _moduleLocation m]--instance FromJSON ModuleId where-	parseJSON = withObject "module-id" $ \v -> ModuleId <$>-		(fromMaybe "" <$> (v .::? "name")) <*>-		(fromMaybe NoLocation <$> (v .::? "location"))---- | Symbol-data SymbolId = SymbolId {-	_symbolName :: Text,-	_symbolModule :: ModuleId }-		deriving (Eq, Ord)--makeLenses ''SymbolId--instance NFData SymbolId where-	rnf (SymbolId n m) = rnf n `seq` rnf m--instance Show SymbolId where-	show (SymbolId n m) = show m ++ ":" ++ unpack n--instance ToJSON SymbolId where-	toJSON s = object $ noNulls [-		"name" .= _symbolName s,-		"module" .= _symbolModule s]--instance FromJSON SymbolId where-	parseJSON = withObject "symbol-id" $ \v -> SymbolId <$>-		(fromMaybe "" <$> (v .::? "name")) <*>-		(fromMaybe (ModuleId "" NoLocation) <$> (v .::? "module"))--data Position = Position {-	_positionLine :: Int,-	_positionColumn :: Int }-		deriving (Eq, Ord, Read)--makeLenses ''Position--instance NFData Position where-	rnf (Position l c) = rnf l `seq` rnf c--instance Show Position where- 	show (Position l c) = show l ++ ":" ++ show c--instance ToJSON Position where-	toJSON (Position l c) = object [-		"line" .= l,-		"column" .= c]--instance FromJSON Position where-	parseJSON = withObject "position" $ \v -> Position <$>-		v .:: "line" <*>-		v .:: "column"--data Region = Region {-	_regionFrom :: Position,-	_regionTo :: Position }-		deriving (Eq, Ord, Read)--makeLenses ''Region--region :: Position -> Position -> Region-region f t = Region (min f t) (max f t)--regionAt :: Position -> Region-regionAt f = region f f--regionLines :: Region -> Int-regionLines (Region f t) = succ (view positionLine t - view positionLine f)---- | Get string at region-regionStr :: Region -> Text -> Text-regionStr r@(Region f t) s = T.intercalate "\n" $ T.drop (pred $ view positionColumn f) fline : tl where-	s' = take (regionLines r) $ drop (pred (view positionLine f)) $ T.lines s-	(fline:tl) = init s' ++ [T.take (pred $ view positionColumn t) (last s')]--instance NFData Region where-	rnf (Region f t) = rnf f `seq` rnf t--instance Show Region where-	show (Region f t) = show f ++ "-" ++ show t--instance ToJSON Region where-	toJSON (Region f t) = object [-		"from" .= f,-		"to" .= t]--instance FromJSON Region where-	parseJSON = withObject "region" $ \v -> Region <$>-		v .:: "from" <*>-		v .:: "to"---- | Location of symbol-data Location = Location {-	_locationModule :: ModuleLocation,-	_locationPosition :: Maybe Position }-		deriving (Eq, Ord)--makeLenses ''Location--instance NFData Location where-	rnf (Location m p) = rnf m `seq` rnf p--instance Show Location where-	show (Location m p) = show m ++ ":" ++ show p--instance ToJSON Location where-	toJSON (Location ml p) = object [-		"module" .= ml,-		"pos" .= p]--instance FromJSON Location where-	parseJSON = withObject "location" $ \v -> Location <$>-		v .:: "module" <*>-		v .::? "pos"---- | Get source module root directory, i.e. for "...\src\Foo\Bar.hs" with module 'Foo.Bar' will return "...\src"-sourceModuleRoot :: Text -> Path -> Path-sourceModuleRoot mname = over paths $-	normalise . joinPath .-	reverse . drop (length $ T.split (== '.') mname) . reverse .-	splitDirectories---- | Path to module source--- >importPath "Quux.Blah" = "Quux/Blah.hs"-importPath :: Text -> Path-importPath = fromFilePath . (`addExtension` "hs") . joinPath . map unpack . T.split (== '.')---- | Root of sources, package dir or root directory of standalone modules-sourceRoot :: ModuleId -> Maybe Path-sourceRoot m = do-	fpath <- preview (moduleLocation . moduleFile) m-	mproj <- preview (moduleLocation . moduleProject) m-	return $ maybe-		(sourceModuleRoot (view moduleName m) fpath)-		(view projectPath)-		mproj--sourceRoot_ :: ModuleId -> Path-sourceRoot_ = fromMaybe (error "sourceRoot_: not a source location") . sourceRoot---- | Recalc positions to interpret '\t' as one symbol instead of N-class RecalcTabs a where-	-- | Interpret '\t' as one symbol instead of N-	recalcTabs :: Text -> Int -> a -> a-	-- | Inverse of `recalcTabs`: interpret '\t' as N symbols instead of 1-	calcTabs :: Text -> Int -> a -> a--instance RecalcTabs Position where-	recalcTabs cts n (Position l c) = Position l c' where-		line = listToMaybe $ drop (pred l) $ T.lines cts-		c' = case line of-			Nothing -> c-			Just line' -> let sizes = map charSize (unpack line') in-				succ . fromMaybe (length sizes) .-				findIndex (>= pred c) .-				scanl (+) 0 $ sizes-		charSize :: Char -> Int-		charSize '\t' = n-		charSize _ = 1-	calcTabs cts n (Position l c) = Position l c' where-		line = listToMaybe $ drop (pred l) $ T.lines cts-		c' = maybe c (succ . sum . map charSize . take (pred c) . unpack) line-		charSize :: Char -> Int-		charSize '\t' = n-		charSize _ = 1--instance RecalcTabs Region where-	recalcTabs cts n (Region f t) = Region (recalcTabs cts n f) (recalcTabs cts n t)-	calcTabs cts n (Region f t) = Region (calcTabs cts n f) (calcTabs cts n t)+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+
+module HsDev.Symbols.Location (
+	ModulePackage(..), mkPackage, PackageConfig(..),
+	ModuleLocation(..), locationId, noLocation,
+	ModuleId(..), moduleName, moduleLocation,
+	SymbolId(..), symbolName, symbolModule,
+	Position(..), Region(..), region, regionAt, regionLines, regionStr,
+	Location(..),
+
+	packageName, packageVersion,
+	package, packageModules, packageExposed,
+	moduleFile, moduleProject, moduleInstallDirs, modulePackage, installedModuleName, installedModuleExposed, otherLocationName,
+	positionLine, positionColumn,
+	regionFrom, regionTo,
+	locationModule, locationPosition,
+
+	sourceModuleRoot,
+	importPath,
+	sourceRoot, sourceRoot_,
+	RecalcTabs(..),
+
+	module HsDev.PackageDb.Types
+	) where
+
+import Control.Applicative
+import Control.DeepSeq (NFData(..))
+import Control.Lens (makeLenses, view, preview, over)
+import Data.Aeson
+import Data.Char (isSpace, isDigit)
+import Data.List (findIndex)
+import Data.Maybe
+import Data.Text (Text, pack, unpack)
+import Data.Text.Lens (unpacked)
+import qualified Data.Text as T
+import System.FilePath
+import Text.Read (readMaybe)
+import Text.Format
+
+import System.Directory.Paths
+import HsDev.Display
+import HsDev.PackageDb.Types
+import HsDev.Project.Types
+import HsDev.Util ((.::), (.::?), (.::?!), objectUnion, noNulls)
+
+-- | Just package name and version without its location
+data ModulePackage = ModulePackage {
+	_packageName :: Text,
+	_packageVersion :: Text }
+		deriving (Eq, Ord)
+
+makeLenses ''ModulePackage
+
+mkPackage :: Text -> ModulePackage
+mkPackage n = ModulePackage n ""
+
+instance NFData ModulePackage where
+	rnf (ModulePackage n v) = rnf n `seq` rnf v
+
+instance Show ModulePackage where
+	show (ModulePackage n "") = unpack n
+	show (ModulePackage n v) = unpack n ++ "-" ++ unpack v
+
+instance Read ModulePackage where
+	readsPrec _ str = case pkg of
+		"" -> []
+		_ -> [(ModulePackage (pack n) (pack v), str')]
+		where
+			(pkg, str') = break isSpace str
+			(rv, rn) = span versionChar $ reverse pkg
+			v = reverse rv
+			n = reverse $ dropWhile (== '-') rn
+
+			versionChar ch = isDigit ch || ch == '.'
+
+instance ToJSON ModulePackage where
+	toJSON (ModulePackage n v) = object [
+		"name" .= n,
+		"version" .= v]
+
+instance FromJSON ModulePackage where
+	parseJSON = withObject "module package" $ \v ->
+		ModulePackage <$> (v .:: "name") <*> (v .:: "version")
+
+data PackageConfig = PackageConfig {
+	_package :: ModulePackage,
+	_packageModules :: [Text],
+	_packageExposed :: Bool }
+		deriving (Eq, Ord, Read, Show)
+
+makeLenses ''PackageConfig
+
+instance NFData PackageConfig where
+	rnf (PackageConfig p ms e) = rnf p `seq` rnf ms `seq` rnf e
+
+instance ToJSON PackageConfig where
+	toJSON (PackageConfig p ms e) = toJSON p `objectUnion` object ["modules" .= ms, "exposed" .= e]
+
+instance FromJSON PackageConfig where
+	parseJSON = withObject "package-config" $ \v -> PackageConfig <$>
+		parseJSON (Object v) <*>
+		(v .::?! "modules") <*>
+		(v .:: "exposed" <|> pure False)
+
+-- | Location of module
+data ModuleLocation =
+	FileModule { _moduleFile :: Path, _moduleProject :: Maybe Project } |
+	InstalledModule { _moduleInstallDirs :: [Path], _modulePackage :: ModulePackage, _installedModuleName :: Text, _installedModuleExposed :: Bool } |
+	OtherLocation { _otherLocationName :: Text } |
+	NoLocation
+
+instance Eq ModuleLocation where
+	FileModule lfile _ == FileModule rfile _ = lfile == rfile
+	InstalledModule ldirs _ lname _ == InstalledModule rdirs _ rname _ = ldirs == rdirs && lname == rname
+	OtherLocation l == OtherLocation r = l == r
+	NoLocation == NoLocation = True
+	_ == _ = False
+
+instance Ord ModuleLocation where
+	compare l r = compare (locType l, locNames l) (locType r, locNames r) where
+		locType :: ModuleLocation -> Int
+		locType (FileModule _ _) = 0
+		locType (InstalledModule _ _ _ _) = 1
+		locType (OtherLocation _) = 2
+		locType NoLocation = 3
+		locNames (FileModule f _) = [f]
+		locNames (InstalledModule dirs _ nm _) = nm : dirs
+		locNames (OtherLocation n) = [n]
+		locNames NoLocation = []
+
+makeLenses ''ModuleLocation
+
+locationId :: ModuleLocation -> Text
+locationId (FileModule fpath _) = fpath
+locationId (InstalledModule dirs mpack nm _) = T.intercalate ":" (take 1 dirs ++ [pack (show mpack), nm])
+locationId (OtherLocation src) = src
+locationId NoLocation = "<no-location>"
+
+instance NFData ModuleLocation where
+	rnf (FileModule f p) = rnf f `seq` rnf p
+	rnf (InstalledModule d p n e) = rnf d `seq` rnf p `seq` rnf n `seq` rnf e
+	rnf (OtherLocation s) = rnf s
+	rnf NoLocation = ()
+
+instance Show ModuleLocation where
+	show = unpack . locationId
+
+instance Display ModuleLocation where
+	display (FileModule f _) = display f
+	display (InstalledModule _ _ n _) = view unpacked n
+	display (OtherLocation s) = view unpacked s
+	display NoLocation = "<no-location>"
+	displayType _ = "module"
+
+instance Formattable ModuleLocation where
+	formattable = formattable . display
+
+instance ToJSON ModuleLocation where
+	toJSON (FileModule f p) = object $ noNulls ["file" .= f, "project" .= fmap (view projectCabal) p]
+	toJSON (InstalledModule c p n e) = object $ noNulls ["dirs" .= c, "package" .= show p, "name" .= n, "exposed" .= e]
+	toJSON (OtherLocation s) = object ["source" .= s]
+	toJSON NoLocation = object []
+
+instance FromJSON ModuleLocation where
+	parseJSON = withObject "module location" $ \v ->
+		(FileModule <$> v .:: "file" <*> (fmap project <$> (v .::? "project"))) <|>
+		(InstalledModule <$> v .::?! "dirs" <*> (readPackage =<< (v .:: "package")) <*> v .:: "name" <*> v .:: "exposed") <|>
+		(OtherLocation <$> v .:: "source") <|>
+		(pure NoLocation)
+		where
+			readPackage s = maybe (fail $ "can't parse package: " ++ s) return . readMaybe $ s
+
+instance Paths ModuleLocation where
+	paths f (FileModule fpath p) = FileModule <$> paths f fpath <*> traverse (paths f) p
+	paths f (InstalledModule c p n e) = InstalledModule <$> traverse (paths f) c <*> pure p <*> pure n <*> pure e
+	paths _ (OtherLocation s) = pure $ OtherLocation s
+	paths _ NoLocation = pure NoLocation
+
+noLocation :: ModuleLocation
+noLocation = NoLocation
+
+data ModuleId = ModuleId {
+	_moduleName :: Text,
+	_moduleLocation :: ModuleLocation }
+		deriving (Eq, Ord)
+
+makeLenses ''ModuleId
+
+instance NFData ModuleId where
+	rnf (ModuleId n l) = rnf n `seq` rnf l
+
+instance Show ModuleId where
+	show (ModuleId n l) = show l ++ ":" ++ unpack n
+
+instance ToJSON ModuleId where
+	toJSON m = object $ noNulls [
+		"name" .= _moduleName m,
+		"location" .= _moduleLocation m]
+
+instance FromJSON ModuleId where
+	parseJSON = withObject "module-id" $ \v -> ModuleId <$>
+		(fromMaybe "" <$> (v .::? "name")) <*>
+		(fromMaybe NoLocation <$> (v .::? "location"))
+
+-- | Symbol
+data SymbolId = SymbolId {
+	_symbolName :: Text,
+	_symbolModule :: ModuleId }
+		deriving (Eq, Ord)
+
+makeLenses ''SymbolId
+
+instance NFData SymbolId where
+	rnf (SymbolId n m) = rnf n `seq` rnf m
+
+instance Show SymbolId where
+	show (SymbolId n m) = show m ++ ":" ++ unpack n
+
+instance ToJSON SymbolId where
+	toJSON s = object $ noNulls [
+		"name" .= _symbolName s,
+		"module" .= _symbolModule s]
+
+instance FromJSON SymbolId where
+	parseJSON = withObject "symbol-id" $ \v -> SymbolId <$>
+		(fromMaybe "" <$> (v .::? "name")) <*>
+		(fromMaybe (ModuleId "" NoLocation) <$> (v .::? "module"))
+
+data Position = Position {
+	_positionLine :: Int,
+	_positionColumn :: Int }
+		deriving (Eq, Ord, Read)
+
+makeLenses ''Position
+
+instance NFData Position where
+	rnf (Position l c) = rnf l `seq` rnf c
+
+instance Show Position where
+ 	show (Position l c) = show l ++ ":" ++ show c
+
+instance ToJSON Position where
+	toJSON (Position l c) = object [
+		"line" .= l,
+		"column" .= c]
+
+instance FromJSON Position where
+	parseJSON = withObject "position" $ \v -> Position <$>
+		v .:: "line" <*>
+		v .:: "column"
+
+data Region = Region {
+	_regionFrom :: Position,
+	_regionTo :: Position }
+		deriving (Eq, Ord, Read)
+
+makeLenses ''Region
+
+region :: Position -> Position -> Region
+region f t = Region (min f t) (max f t)
+
+regionAt :: Position -> Region
+regionAt f = region f f
+
+regionLines :: Region -> Int
+regionLines (Region f t) = succ (view positionLine t - view positionLine f)
+
+-- | Get string at region
+regionStr :: Region -> Text -> Text
+regionStr r@(Region f t) s = T.intercalate "\n" $ T.drop (pred $ view positionColumn f) fline : tl where
+	s' = take (regionLines r) $ drop (pred (view positionLine f)) $ T.lines s
+	(fline:tl) = init s' ++ [T.take (pred $ view positionColumn t) (last s')]
+
+instance NFData Region where
+	rnf (Region f t) = rnf f `seq` rnf t
+
+instance Show Region where
+	show (Region f t) = show f ++ "-" ++ show t
+
+instance ToJSON Region where
+	toJSON (Region f t) = object [
+		"from" .= f,
+		"to" .= t]
+
+instance FromJSON Region where
+	parseJSON = withObject "region" $ \v -> Region <$>
+		v .:: "from" <*>
+		v .:: "to"
+
+-- | Location of symbol
+data Location = Location {
+	_locationModule :: ModuleLocation,
+	_locationPosition :: Maybe Position }
+		deriving (Eq, Ord)
+
+makeLenses ''Location
+
+instance NFData Location where
+	rnf (Location m p) = rnf m `seq` rnf p
+
+instance Show Location where
+	show (Location m p) = show m ++ ":" ++ show p
+
+instance ToJSON Location where
+	toJSON (Location ml p) = object [
+		"module" .= ml,
+		"pos" .= p]
+
+instance FromJSON Location where
+	parseJSON = withObject "location" $ \v -> Location <$>
+		v .:: "module" <*>
+		v .::? "pos"
+
+-- | Get source module root directory, i.e. for "...\src\Foo\Bar.hs" with module 'Foo.Bar' will return "...\src"
+sourceModuleRoot :: Text -> Path -> Path
+sourceModuleRoot mname = over paths $
+	normalise . joinPath .
+	reverse . drop (length $ T.split (== '.') mname) . reverse .
+	splitDirectories
+
+-- | Path to module source
+-- >importPath "Quux.Blah" = "Quux/Blah.hs"
+importPath :: Text -> Path
+importPath = fromFilePath . (`addExtension` "hs") . joinPath . map unpack . T.split (== '.')
+
+-- | Root of sources, package dir or root directory of standalone modules
+sourceRoot :: ModuleId -> Maybe Path
+sourceRoot m = do
+	fpath <- preview (moduleLocation . moduleFile) m
+	mproj <- preview (moduleLocation . moduleProject) m
+	return $ maybe
+		(sourceModuleRoot (view moduleName m) fpath)
+		(view projectPath)
+		mproj
+
+sourceRoot_ :: ModuleId -> Path
+sourceRoot_ = fromMaybe (error "sourceRoot_: not a source location") . sourceRoot
+
+-- | Recalc positions to interpret '\t' as one symbol instead of N
+class RecalcTabs a where
+	-- | Interpret '\t' as one symbol instead of N
+	recalcTabs :: Text -> Int -> a -> a
+	-- | Inverse of `recalcTabs`: interpret '\t' as N symbols instead of 1
+	calcTabs :: Text -> Int -> a -> a
+
+instance RecalcTabs Position where
+	recalcTabs cts n (Position l c) = Position l c' where
+		line = listToMaybe $ drop (pred l) $ T.lines cts
+		c' = case line of
+			Nothing -> c
+			Just line' -> let sizes = map charSize (unpack line') in
+				succ . fromMaybe (length sizes) .
+				findIndex (>= pred c) .
+				scanl (+) 0 $ sizes
+		charSize :: Char -> Int
+		charSize '\t' = n
+		charSize _ = 1
+	calcTabs cts n (Position l c) = Position l c' where
+		line = listToMaybe $ drop (pred l) $ T.lines cts
+		c' = maybe c (succ . sum . map charSize . take (pred c) . unpack) line
+		charSize :: Char -> Int
+		charSize '\t' = n
+		charSize _ = 1
+
+instance RecalcTabs Region where
+	recalcTabs cts n (Region f t) = Region (recalcTabs cts n f) (recalcTabs cts n t)
+	calcTabs cts n (Region f t) = Region (calcTabs cts n f) (calcTabs cts n t)
src/HsDev/Symbols/Name.hs view
@@ -1,90 +1,90 @@-{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns, OverloadedStrings #-}--module HsDev.Symbols.Name (-	Name, qualName, unqualName, nameModule, nameIdent, pattern Name, fromName_, toName_, toModuleName_, fromModuleName_, fromName, toName,-	name_, moduleName_-	) where--import Control.Arrow-import Control.Lens-import Data.Char (isAlpha, isAlphaNum)-import Data.Text (Text)-import Data.String (fromString)-import qualified Data.Text as T-import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..))-import qualified Language.Haskell.Exts as Exts (Name(..))---- | Qualified name-type Name = QName ()--qualName :: String -> String -> Name-qualName m = Qual () (ModuleName () m) . toName_ . fromString--unqualName :: String -> Name-unqualName = UnQual () . toName_ . fromString--nameModule :: Name -> Maybe Text-nameModule (Qual _ (ModuleName _ m) _) = Just $ fromString m-nameModule _ = Nothing--nameIdent :: Name -> Text-nameIdent (Qual _ _ n) = fromName_ n-nameIdent (UnQual _ n) = fromName_ n-nameIdent s = fromName s--pattern Name :: Maybe Text -> Text -> Name-pattern Name m n <- ((nameModule &&& nameIdent) -> (m, n)) where-	Name Nothing n = UnQual () (Exts.Ident () (T.unpack n))-	Name (Just m) n = Qual () (ModuleName () (T.unpack m)) (Exts.Ident () (T.unpack n))--fromName_ :: Exts.Name () -> Text-fromName_ (Exts.Ident _ s') = fromString s'-fromName_ (Exts.Symbol _ s') = fromString s'--toName_ :: Text -> Exts.Name ()-toName_ txt-	| T.null txt = Exts.Ident () ""-	| isAlpha (T.head txt) && (T.all validChar $ T.tail txt) = Exts.Ident () . T.unpack $ txt-	| otherwise = Exts.Symbol () . T.unpack $ txt-	where-		validChar ch = isAlphaNum ch || ch == '_'--toModuleName_ :: Text -> ModuleName ()-toModuleName_ = ModuleName () . T.unpack--fromModuleName_ :: ModuleName () -> Text-fromModuleName_ (ModuleName () m) = T.pack m--toName :: Text -> Name-toName "()" = Special () (UnitCon ())-toName "[]" = Special () (ListCon ())-toName "->" = Special () (FunCon ())-toName "(:)" = Special () (Cons ())-toName "(# #)" = Special () (UnboxedSingleCon ())-toName tup-	| T.all (== ',') noBraces = Special () (TupleCon () Boxed (succ $ T.length noBraces))-	where-		noBraces = T.dropAround (`elem` ['(', ')']) tup-toName n = case T.split (== '.') n of-	[n'] -> UnQual () (Exts.Ident () $ T.unpack n')-	ns -> Qual () (ModuleName () (T.unpack $ T.intercalate "." $ init ns)) (toName_ $ last ns)--fromName :: Name -> Text-fromName (Qual _ (ModuleName _ m) n) = T.concat [fromString m, ".", fromName_ n]-fromName (UnQual _ n) = fromName_ n-fromName (Special _ c) = case c of-	UnitCon _ -> "()"-	ListCon _ -> "[]"-	FunCon _ -> "->"-	TupleCon _ _ i -> fromString $ "(" ++ replicate (pred i) ',' ++ ")"-	Cons _ -> "(:)"-	UnboxedSingleCon _ -> "(# #)"-#if MIN_VERSION_haskell_src_exts(1,20,0)-	ExprHole _ -> "_"-#endif--name_ :: Iso' (Exts.Name ()) Text-name_ = iso fromName_ toName_--moduleName_ :: Iso' (ModuleName ()) Text-moduleName_ = iso fromModuleName_ toModuleName_+{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns, OverloadedStrings #-}
+
+module HsDev.Symbols.Name (
+	Name, qualName, unqualName, nameModule, nameIdent, pattern Name, fromName_, toName_, toModuleName_, fromModuleName_, fromName, toName,
+	name_, moduleName_
+	) where
+
+import Control.Arrow
+import Control.Lens
+import Data.Char (isAlpha, isAlphaNum)
+import Data.Text (Text)
+import Data.String (fromString)
+import qualified Data.Text as T
+import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..))
+import qualified Language.Haskell.Exts as Exts (Name(..))
+
+-- | Qualified name
+type Name = QName ()
+
+qualName :: String -> String -> Name
+qualName m = Qual () (ModuleName () m) . toName_ . fromString
+
+unqualName :: String -> Name
+unqualName = UnQual () . toName_ . fromString
+
+nameModule :: Name -> Maybe Text
+nameModule (Qual _ (ModuleName _ m) _) = Just $ fromString m
+nameModule _ = Nothing
+
+nameIdent :: Name -> Text
+nameIdent (Qual _ _ n) = fromName_ n
+nameIdent (UnQual _ n) = fromName_ n
+nameIdent s = fromName s
+
+pattern Name :: Maybe Text -> Text -> Name
+pattern Name m n <- ((nameModule &&& nameIdent) -> (m, n)) where
+	Name Nothing n = UnQual () (Exts.Ident () (T.unpack n))
+	Name (Just m) n = Qual () (ModuleName () (T.unpack m)) (Exts.Ident () (T.unpack n))
+
+fromName_ :: Exts.Name () -> Text
+fromName_ (Exts.Ident _ s') = fromString s'
+fromName_ (Exts.Symbol _ s') = fromString s'
+
+toName_ :: Text -> Exts.Name ()
+toName_ txt
+	| T.null txt = Exts.Ident () ""
+	| isAlpha (T.head txt) && (T.all validChar $ T.tail txt) = Exts.Ident () . T.unpack $ txt
+	| otherwise = Exts.Symbol () . T.unpack $ txt
+	where
+		validChar ch = isAlphaNum ch || ch == '_'
+
+toModuleName_ :: Text -> ModuleName ()
+toModuleName_ = ModuleName () . T.unpack
+
+fromModuleName_ :: ModuleName () -> Text
+fromModuleName_ (ModuleName () m) = T.pack m
+
+toName :: Text -> Name
+toName "()" = Special () (UnitCon ())
+toName "[]" = Special () (ListCon ())
+toName "->" = Special () (FunCon ())
+toName "(:)" = Special () (Cons ())
+toName "(# #)" = Special () (UnboxedSingleCon ())
+toName tup
+	| T.all (== ',') noBraces = Special () (TupleCon () Boxed (succ $ T.length noBraces))
+	where
+		noBraces = T.dropAround (`elem` ['(', ')']) tup
+toName n = case T.split (== '.') n of
+	[n'] -> UnQual () (Exts.Ident () $ T.unpack n')
+	ns -> Qual () (ModuleName () (T.unpack $ T.intercalate "." $ init ns)) (toName_ $ last ns)
+
+fromName :: Name -> Text
+fromName (Qual _ (ModuleName _ m) n) = T.concat [fromString m, ".", fromName_ n]
+fromName (UnQual _ n) = fromName_ n
+fromName (Special _ c) = case c of
+	UnitCon _ -> "()"
+	ListCon _ -> "[]"
+	FunCon _ -> "->"
+	TupleCon _ _ i -> fromString $ "(" ++ replicate (pred i) ',' ++ ")"
+	Cons _ -> "(:)"
+	UnboxedSingleCon _ -> "(# #)"
+#if MIN_VERSION_haskell_src_exts(1,20,0)
+	ExprHole _ -> "_"
+#endif
+
+name_ :: Iso' (Exts.Name ()) Text
+name_ = iso fromName_ toName_
+
+moduleName_ :: Iso' (ModuleName ()) Text
+moduleName_ = iso fromModuleName_ toModuleName_
src/HsDev/Symbols/Parsed.hs view
@@ -1,197 +1,197 @@-{-# LANGUAGE RankNTypes #-}--module HsDev.Symbols.Parsed (-	Ann, Parsed,-	qnames, names, binders, locals, globals, references, unresolveds,-	usages, named, imports, declarations, moduleNames,--	annL, symbolL, file, pos, defPos, resolvedName,-	isBinder, isLocal, isGlobal, isReference, isUnresolved, resolveError,-	refsTo, refsToName,-	nameInfoL, positionL, regionL, fileL,-	symbolNameL,--	prettyPrint-	) where--import Control.Lens-import Data.Data-import Data.Data.Lens-import Data.Maybe (isJust)-import Data.Text (Text)-import Language.Haskell.Exts hiding (Name(..))-import qualified Language.Haskell.Exts as E (Name(..))-import Language.Haskell.Names--import HsDev.Symbols.Name-import HsDev.Symbols.Location (Position(..), positionLine, positionColumn, Region(..), region)---- | Annotation of parsed and resolved nodes-type Ann = Scoped SrcSpanInfo---- | Parsed and resolved module-type Parsed = Module Ann---- | Get all qualified names-qnames :: Data (ast Ann) => Traversal' (ast Ann) (QName Ann)-qnames = biplate---- | Get all names-names :: Data (ast Ann) => Traversal' (ast Ann) (E.Name Ann)-names = biplate---- | Get all binders-binders :: Annotated ast => Traversal' (ast Ann) (ast Ann)-binders = filtered isBinder---- | Get all names locally defined-locals :: Annotated ast => Traversal' (ast Ann) (ast Ann)-locals = filtered isLocal---- | Get all names, references global symbol-globals :: Annotated ast => Traversal' (ast Ann) (ast Ann)-globals = filtered isGlobal---- | Get all resolved references-references :: Annotated ast => Traversal' (ast Ann) (ast Ann)-references = filtered isReference---- | Get all names with not in scope error-unresolveds :: Annotated ast => Traversal' (ast Ann) (ast Ann)-unresolveds = filtered isUnresolved---- | Get all usages of symbol-usages :: Annotated ast => Name -> Traversal' (ast Ann) (ast Ann)-usages = filtered . refsTo---- | Get usages of symbols with unqualified name-named :: Annotated ast => Text -> Traversal' (ast Ann) (ast Ann)-named = filtered . refsToName---- | Get imports-imports :: Data (ast Ann) => Traversal' (ast Ann) (ImportDecl Ann)-imports = biplate---- | Get declarations-declarations :: Data (ast Ann) => Traversal' (ast Ann) (Decl Ann)-declarations = biplate---- | Get module names-moduleNames :: Data (ast Ann) => Traversal' (ast Ann) (ModuleName Ann)-moduleNames = biplate---- | Get annotation-annL :: Annotated ast => Lens' (ast a) a-annL = lens ann (\v a' -> amap (const a') v)---- | Get haskell-names symbols-symbolL :: Data a => Traversal' a Symbol-symbolL = biplate---- | Get source file-file :: Annotated ast => Lens' (ast Ann) FilePath-file = annL . fileL---- | Get source location-pos :: (Annotated ast, SrcInfo isrc, Data isrc) => Lens' (ast isrc) Position-pos = annL . positionL---- | Definition position, if binder - returns current position-defPos :: Annotated ast => Traversal' (ast Ann) Position-defPos = annL . defLoc' where-	defLoc' :: Traversal' Ann Position-	defLoc' f (Scoped (LocalValue s) i) = Scoped <$> (LocalValue <$> positionL f s) <*> pure i-	defLoc' f (Scoped (TypeVar s) i) = Scoped <$> (TypeVar <$> positionL f s) <*> pure i-	defLoc' f (Scoped ValueBinder i) = Scoped ValueBinder <$> positionL f i-	defLoc' f (Scoped TypeBinder i) = Scoped TypeBinder <$> positionL f i-	defLoc' _ s = pure s---- | Resolved global name-resolvedName :: Annotated ast => Traversal' (ast Ann) Name-resolvedName = annL . nameInfoL . symbolL . symbolNameL---- | Does ast node binds something-isBinder :: Annotated ast => ast Ann -> Bool-isBinder e = (e ^. annL . nameInfoL) `elem` [TypeBinder, ValueBinder]---- | Does ast node locally defined-isLocal :: Annotated ast => ast Ann -> Bool-isLocal e = case e ^. annL . nameInfoL of-	LocalValue _ -> True-	TypeVar _ -> True-	_ -> False---- | Does ast node reference something-isGlobal :: Annotated ast => ast Ann -> Bool-isGlobal e = case e ^. annL . nameInfoL of-	GlobalSymbol _ _ -> True-	_ -> False---- | Does ast node reference something-isReference :: Annotated ast => ast Ann -> Bool-isReference e = isLocal e || isGlobal e---- | Is ast node not resolved-isUnresolved :: Annotated ast => ast Ann -> Bool-isUnresolved = isJust . resolveError---- | Resolve error-resolveError :: Annotated ast => ast Ann -> Maybe String-resolveError e = case e ^. annL . nameInfoL of-	ScopeError err -> Just $ ppError err-	_ -> Nothing---- | Node references to specified symbol-refsTo :: Annotated ast => Name -> ast Ann -> Bool-refsTo n a = Just n == a ^? resolvedName---- | Node references to specified unqualified name-refsToName :: Annotated ast => Text -> ast Ann -> Bool-refsToName n a = Just n == fmap nameIdent (a ^? resolvedName)--nameInfoL :: Lens' (Scoped a) (NameInfo a)-nameInfoL = lens g' s' where-	g' (Scoped i _) = i-	s' (Scoped _ s) i' = Scoped i' s--positionL :: (SrcInfo isrc, Data isrc) => Lens' isrc Position-positionL = lens g' s' where-	g' i = Position l c where-		SrcLoc _ l c = getPointLoc i-	s' i (Position l c) = over biplate upd i where-		Position sl sc = g' i -- Old location-		-- main line: set new line and move column-		-- other lines: just move line, because altering first line's column doesn't affect other lines-		upd :: SrcLoc -> SrcLoc-		upd (SrcLoc f' l' c')-			| l' == sl = SrcLoc f' l (c' - sc + c)-			| otherwise = SrcLoc f' (l' - sl + l) c'--regionL :: Annotated ast => Lens' (ast Ann) Region-regionL = lens g' s' where-	g' i = case ann i of-		Scoped _ sinfo -> toPos (srcSpanStart span') `region` toPos (srcSpanEnd span') where-			span' = srcInfoSpan sinfo-			toPos = uncurry Position-	s' i (Region s e) = amap (fmap upd) i where-		upd :: SrcSpanInfo -> SrcSpanInfo-		upd sinfo = sinfo {-			srcInfoSpan = (srcInfoSpan sinfo) {-				srcSpanStartLine = s ^. positionLine,-				srcSpanStartColumn = s ^. positionColumn,-				srcSpanEndLine = e ^. positionLine,-				srcSpanEndColumn = e ^. positionColumn },-			srcInfoPoints = [] }--fileL :: (SrcInfo isrc, Data isrc) => Lens' isrc FilePath-fileL = lens g' s' where-	g' = fileName-	s' i f = set biplate f i---- | Get 'Symbol' as 'Name'-symbolNameL :: Lens' Symbol Name-symbolNameL = lens g' s' where-	g' sym' = Qual () (symbolModule sym') (symbolName sym')-	s' sym' (Qual _ m n) = sym' { symbolModule = m, symbolName = n }-	s' sym' (UnQual _ n) = sym' { symbolName = n }-	s' sym' _ = sym'+{-# LANGUAGE RankNTypes #-}
+
+module HsDev.Symbols.Parsed (
+	Ann, Parsed,
+	qnames, names, binders, locals, globals, references, unresolveds,
+	usages, named, imports, declarations, moduleNames,
+
+	annL, symbolL, file, pos, defPos, resolvedName,
+	isBinder, isLocal, isGlobal, isReference, isUnresolved, resolveError,
+	refsTo, refsToName,
+	nameInfoL, positionL, regionL, fileL,
+	symbolNameL,
+
+	prettyPrint
+	) where
+
+import Control.Lens
+import Data.Data
+import Data.Data.Lens
+import Data.Maybe (isJust)
+import Data.Text (Text)
+import Language.Haskell.Exts hiding (Name(..))
+import qualified Language.Haskell.Exts as E (Name(..))
+import Language.Haskell.Names
+
+import HsDev.Symbols.Name
+import HsDev.Symbols.Location (Position(..), positionLine, positionColumn, Region(..), region)
+
+-- | Annotation of parsed and resolved nodes
+type Ann = Scoped SrcSpanInfo
+
+-- | Parsed and resolved module
+type Parsed = Module Ann
+
+-- | Get all qualified names
+qnames :: Data (ast Ann) => Traversal' (ast Ann) (QName Ann)
+qnames = biplate
+
+-- | Get all names
+names :: Data (ast Ann) => Traversal' (ast Ann) (E.Name Ann)
+names = biplate
+
+-- | Get all binders
+binders :: Annotated ast => Traversal' (ast Ann) (ast Ann)
+binders = filtered isBinder
+
+-- | Get all names locally defined
+locals :: Annotated ast => Traversal' (ast Ann) (ast Ann)
+locals = filtered isLocal
+
+-- | Get all names, references global symbol
+globals :: Annotated ast => Traversal' (ast Ann) (ast Ann)
+globals = filtered isGlobal
+
+-- | Get all resolved references
+references :: Annotated ast => Traversal' (ast Ann) (ast Ann)
+references = filtered isReference
+
+-- | Get all names with not in scope error
+unresolveds :: Annotated ast => Traversal' (ast Ann) (ast Ann)
+unresolveds = filtered isUnresolved
+
+-- | Get all usages of symbol
+usages :: Annotated ast => Name -> Traversal' (ast Ann) (ast Ann)
+usages = filtered . refsTo
+
+-- | Get usages of symbols with unqualified name
+named :: Annotated ast => Text -> Traversal' (ast Ann) (ast Ann)
+named = filtered . refsToName
+
+-- | Get imports
+imports :: Data (ast Ann) => Traversal' (ast Ann) (ImportDecl Ann)
+imports = biplate
+
+-- | Get declarations
+declarations :: Data (ast Ann) => Traversal' (ast Ann) (Decl Ann)
+declarations = biplate
+
+-- | Get module names
+moduleNames :: Data (ast Ann) => Traversal' (ast Ann) (ModuleName Ann)
+moduleNames = biplate
+
+-- | Get annotation
+annL :: Annotated ast => Lens' (ast a) a
+annL = lens ann (\v a' -> amap (const a') v)
+
+-- | Get haskell-names symbols
+symbolL :: Data a => Traversal' a Symbol
+symbolL = biplate
+
+-- | Get source file
+file :: Annotated ast => Lens' (ast Ann) FilePath
+file = annL . fileL
+
+-- | Get source location
+pos :: (Annotated ast, SrcInfo isrc, Data isrc) => Lens' (ast isrc) Position
+pos = annL . positionL
+
+-- | Definition position, if binder - returns current position
+defPos :: Annotated ast => Traversal' (ast Ann) Position
+defPos = annL . defLoc' where
+	defLoc' :: Traversal' Ann Position
+	defLoc' f (Scoped (LocalValue s) i) = Scoped <$> (LocalValue <$> positionL f s) <*> pure i
+	defLoc' f (Scoped (TypeVar s) i) = Scoped <$> (TypeVar <$> positionL f s) <*> pure i
+	defLoc' f (Scoped ValueBinder i) = Scoped ValueBinder <$> positionL f i
+	defLoc' f (Scoped TypeBinder i) = Scoped TypeBinder <$> positionL f i
+	defLoc' _ s = pure s
+
+-- | Resolved global name
+resolvedName :: Annotated ast => Traversal' (ast Ann) Name
+resolvedName = annL . nameInfoL . symbolL . symbolNameL
+
+-- | Does ast node binds something
+isBinder :: Annotated ast => ast Ann -> Bool
+isBinder e = (e ^. annL . nameInfoL) `elem` [TypeBinder, ValueBinder]
+
+-- | Does ast node locally defined
+isLocal :: Annotated ast => ast Ann -> Bool
+isLocal e = case e ^. annL . nameInfoL of
+	LocalValue _ -> True
+	TypeVar _ -> True
+	_ -> False
+
+-- | Does ast node reference something
+isGlobal :: Annotated ast => ast Ann -> Bool
+isGlobal e = case e ^. annL . nameInfoL of
+	GlobalSymbol _ _ -> True
+	_ -> False
+
+-- | Does ast node reference something
+isReference :: Annotated ast => ast Ann -> Bool
+isReference e = isLocal e || isGlobal e
+
+-- | Is ast node not resolved
+isUnresolved :: Annotated ast => ast Ann -> Bool
+isUnresolved = isJust . resolveError
+
+-- | Resolve error
+resolveError :: Annotated ast => ast Ann -> Maybe String
+resolveError e = case e ^. annL . nameInfoL of
+	ScopeError err -> Just $ ppError err
+	_ -> Nothing
+
+-- | Node references to specified symbol
+refsTo :: Annotated ast => Name -> ast Ann -> Bool
+refsTo n a = Just n == a ^? resolvedName
+
+-- | Node references to specified unqualified name
+refsToName :: Annotated ast => Text -> ast Ann -> Bool
+refsToName n a = Just n == fmap nameIdent (a ^? resolvedName)
+
+nameInfoL :: Lens' (Scoped a) (NameInfo a)
+nameInfoL = lens g' s' where
+	g' (Scoped i _) = i
+	s' (Scoped _ s) i' = Scoped i' s
+
+positionL :: (SrcInfo isrc, Data isrc) => Lens' isrc Position
+positionL = lens g' s' where
+	g' i = Position l c where
+		SrcLoc _ l c = getPointLoc i
+	s' i (Position l c) = over biplate upd i where
+		Position sl sc = g' i -- Old location
+		-- main line: set new line and move column
+		-- other lines: just move line, because altering first line's column doesn't affect other lines
+		upd :: SrcLoc -> SrcLoc
+		upd (SrcLoc f' l' c')
+			| l' == sl = SrcLoc f' l (c' - sc + c)
+			| otherwise = SrcLoc f' (l' - sl + l) c'
+
+regionL :: Annotated ast => Lens' (ast Ann) Region
+regionL = lens g' s' where
+	g' i = case ann i of
+		Scoped _ sinfo -> toPos (srcSpanStart span') `region` toPos (srcSpanEnd span') where
+			span' = srcInfoSpan sinfo
+			toPos = uncurry Position
+	s' i (Region s e) = amap (fmap upd) i where
+		upd :: SrcSpanInfo -> SrcSpanInfo
+		upd sinfo = sinfo {
+			srcInfoSpan = (srcInfoSpan sinfo) {
+				srcSpanStartLine = s ^. positionLine,
+				srcSpanStartColumn = s ^. positionColumn,
+				srcSpanEndLine = e ^. positionLine,
+				srcSpanEndColumn = e ^. positionColumn },
+			srcInfoPoints = [] }
+
+fileL :: (SrcInfo isrc, Data isrc) => Lens' isrc FilePath
+fileL = lens g' s' where
+	g' = fileName
+	s' i f = set biplate f i
+
+-- | Get 'Symbol' as 'Name'
+symbolNameL :: Lens' Symbol Name
+symbolNameL = lens g' s' where
+	g' sym' = Qual () (symbolModule sym') (symbolName sym')
+	s' sym' (Qual _ m n) = sym' { symbolModule = m, symbolName = n }
+	s' sym' (UnQual _ n) = sym' { symbolName = n }
+	s' sym' _ = sym'
src/HsDev/Symbols/Resolve.hs view
@@ -1,27 +1,27 @@-{-# LANGUAGE RankNTypes #-}--module HsDev.Symbols.Resolve (-	RefineTable, refineTable, refineSymbol, refineSymbols,-	symbolUniqId-	) where--import Control.Lens-import qualified Data.Map.Strict as M-import Data.Maybe (fromMaybe)-import Data.Text (Text)--import HsDev.Symbols--type RefineTable = M.Map (Text, Text, SymbolInfo) Symbol--refineTable :: [Symbol] -> RefineTable-refineTable syms = M.fromList [(symbolUniqId s, s) | s <- syms]--refineSymbol :: RefineTable -> Symbol -> Symbol-refineSymbol tbl s = fromMaybe s $ M.lookup (symbolUniqId s) tbl--refineSymbols :: RefineTable -> Module -> Module-refineSymbols tbl = over moduleSymbols (refineSymbol tbl)--symbolUniqId :: Symbol -> (Text, Text, SymbolInfo)-symbolUniqId s = (view (symbolId . symbolName) s, view (symbolId . symbolModule . moduleName) s, nullifyInfo $ view symbolInfo s)+{-# LANGUAGE RankNTypes #-}
+
+module HsDev.Symbols.Resolve (
+	RefineTable, refineTable, refineSymbol, refineSymbols,
+	symbolUniqId
+	) where
+
+import Control.Lens
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+
+import HsDev.Symbols
+
+type RefineTable = M.Map (Text, Text, SymbolInfo) Symbol
+
+refineTable :: [Symbol] -> RefineTable
+refineTable syms = M.fromList [(symbolUniqId s, s) | s <- syms]
+
+refineSymbol :: RefineTable -> Symbol -> Symbol
+refineSymbol tbl s = fromMaybe s $ M.lookup (symbolUniqId s) tbl
+
+refineSymbols :: RefineTable -> Module -> Module
+refineSymbols tbl = over moduleSymbols (refineSymbol tbl)
+
+symbolUniqId :: Symbol -> (Text, Text, SymbolInfo)
+symbolUniqId s = (view (symbolId . symbolName) s, view (symbolId . symbolModule . moduleName) s, nullifyInfo $ view symbolInfo s)
src/HsDev/Symbols/Types.hs view
@@ -1,643 +1,643 @@-{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Symbols.Types (-	Import(..), importPosition, importName, importQualified, importAs,-	Module(..), moduleSymbols, exportedSymbols, scopeSymbols, fixitiesMap, moduleFixities, moduleId, moduleDocs, moduleImports, moduleExports, moduleScope, moduleSource,-	Symbol(..), symbolId, symbolDocs, symbolPosition, symbolInfo,-	SymbolInfo(..), functionType, parentClass, parentType, selectorConstructors, typeArgs, typeContext, familyAssociate, symbolInfoType, symbolType, patternType, patternConstructor,-	Scoped(..), scopeQualifier, scoped,-	SymbolUsage(..), symbolUsed, symbolUsedQualifier, symbolUsedIn, symbolUsedRegion,-	ImportedSymbol(..), importedSymbol, importedFrom,-	infoOf, nullifyInfo,-	Inspection(..), inspectionAt, inspectionOpts, fresh, Inspected(..), inspection, inspectedKey, inspectionTags, inspectionResult, inspected,-	InspectM(..), runInspect, continueInspect, inspect, inspect_, withInspection,-	inspectedTup, noTags, tag, ModuleTag(..), InspectedModule, notInspected,--	module HsDev.PackageDb.Types,-	module HsDev.Project,-	module HsDev.Symbols.Name,-	module HsDev.Symbols.Class,-	module HsDev.Symbols.Location,-	module HsDev.Symbols.Documented-	) where--import Control.Arrow-import Control.Applicative-import Control.Lens hiding ((.=))-import Control.Monad-import Control.Monad.Morph-import Control.Monad.Catch-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State-import Control.DeepSeq (NFData(..))-import Data.Aeson-import Data.Aeson.Types (Pair, Parser)-import Data.List (intercalate)-import Data.Maybe (catMaybes)-import Data.Maybe.JustIf-import Data.Monoid (Any(..))-import Data.Function-import Data.Ord-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Text (Text)-import qualified Data.Text as T-import Data.Set (Set)-import qualified Data.Set as S-import Data.Time.Clock.POSIX (POSIXTime)-import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..), Fixity(..), Assoc(..))-import qualified Language.Haskell.Exts as Exts (Name(..))-import Text.Format--import Control.Apply.Util (chain)-import HsDev.Display-import HsDev.Error-import HsDev.PackageDb.Types-import HsDev.Project-import HsDev.Symbols.Name-import HsDev.Symbols.Class-import HsDev.Symbols.Location-import HsDev.Symbols.Documented-import HsDev.Symbols.Parsed-import HsDev.Util ((.::), (.::?), (.::?!), noNulls, objectUnion)-import System.Directory.Paths--instance NFData l => NFData (ModuleName l) where-	rnf (ModuleName l n) = rnf l `seq` rnf n--instance NFData l => NFData (Exts.Name l) where-	rnf (Exts.Ident l s) = rnf l `seq` rnf s-	rnf (Exts.Symbol l s) = rnf l `seq` rnf s--instance NFData Boxed where-	rnf Boxed = ()-	rnf Unboxed = ()--instance NFData l => NFData (SpecialCon l) where-	rnf (UnitCon l) = rnf l-	rnf (ListCon l) = rnf l-	rnf (FunCon l) = rnf l-	rnf (TupleCon l b i) = rnf l `seq` rnf b `seq` rnf i-	rnf (Cons l) = rnf l-	rnf (UnboxedSingleCon l) = rnf l-#if MIN_VERSION_haskell_src_exts(1,20,0)-	rnf (ExprHole l) = rnf l-#endif--instance NFData l => NFData (QName l) where-	rnf (Qual l m n) = rnf l `seq` rnf m `seq` rnf n-	rnf (UnQual l n) = rnf l `seq` rnf n-	rnf (Special l s) = rnf l `seq` rnf s---- | Import-data Import = Import {-	_importPosition :: Position, -- source line of import-	_importName :: Text, -- imported module name-	_importQualified :: Bool, -- is import qualified-	_importAs :: Maybe Text } -- alias of import-		deriving (Eq, Ord)--instance NFData Import where-	rnf (Import p n q a) = rnf p `seq` rnf n `seq` rnf q `seq` rnf a--instance Show Import where-	show (Import _ n q a) = concat $ catMaybes [-		Just "import",-		"qualified" `justIf` q,-		Just $ show n,-		fmap (("as " ++) . show) a]--instance ToJSON Import where-	toJSON (Import p n q a) = object [-		"pos" .= p,-		"name" .= n,-		"qualified" .= q,-		"as" .= a]--instance FromJSON Import where-	parseJSON = withObject "import" $ \v -> Import <$>-		v .:: "pos" <*>-		v .:: "name" <*>-		v .:: "qualified" <*>-		v .:: "as"---- | Module-data Module = Module {-	_moduleId :: ModuleId,-	_moduleDocs :: Maybe Text,-	_moduleImports :: [Import], -- list of module names imported-	_moduleExports :: [Symbol], -- exported module symbols-	_moduleFixities :: [Fixity], -- fixities of operators-	_moduleScope :: Map Name [Symbol], -- symbols in scope, only for source modules-	_moduleSource :: Maybe Parsed } -- source of module---- | Make each symbol appear only once-moduleSymbols :: Traversal' Module Symbol-moduleSymbols f m = getBack <$> (each . _1) f revList where-	revList = M.toList $ M.unionsWith mappend $ concat [-		[M.singleton sym ([], Any True) | sym <- _moduleExports m],-		[M.singleton sym ([nm], Any False) | (nm, syms) <- M.toList (_moduleScope m), sym <- syms]]-	getBack syms = m {-		_moduleExports = [sym' | (sym', (_, Any True)) <- syms],-		_moduleScope = M.unionsWith (++) [M.singleton n [sym'] | (sym', (ns, _)) <- syms, n <- ns] }--exportedSymbols :: Traversal' Module Symbol-exportedSymbols f m = (\e -> m { _moduleExports = e }) <$> traverse f (_moduleExports m)--scopeSymbols :: Traversal' Module (Symbol, [Name])-scopeSymbols f m = (\s -> m { _moduleScope = invMap s }) <$> traverse f (M.toList . invMap . M.toList $ _moduleScope m) where-	invMap :: Ord b => [(a, [b])] -> Map b [a]-	invMap es = M.unionsWith (++) [M.singleton v [k] | (k, vs) <- es, v <- vs]--fixitiesMap :: Lens' Module (Map Name Fixity)-fixitiesMap = lens g' s' where-	g' m = mconcat [M.singleton n f | f@(Fixity _ _ n) <- _moduleFixities m]-	s' m m' = m { _moduleFixities = M.elems m' }--instance ToJSON (Assoc ()) where-	toJSON (AssocNone _) = toJSON ("none" :: String)-	toJSON (AssocLeft _) = toJSON ("left" :: String)-	toJSON (AssocRight _) = toJSON ("right" :: String)--instance FromJSON (Assoc ()) where-	parseJSON = withText "assoc" $ \txt -> msum [-		guard (txt == "none") >> return (AssocNone ()),-		guard (txt == "left") >> return (AssocLeft ()),-		guard (txt == "right") >> return (AssocRight ())]--instance ToJSON Fixity where-	toJSON (Fixity assoc pr n) = object $ noNulls [-		"assoc" .= assoc,-		"prior" .= pr,-		"name" .= fromName n]--instance FromJSON Fixity where-	parseJSON = withObject "fixity" $ \v -> Fixity <$>-		v .:: "assoc" <*>-		v .:: "prior" <*>-		(toName <$> v .:: "name")--instance ToJSON Module where-	toJSON m = object $ noNulls [-		"id" .= _moduleId m,-		"docs" .= _moduleDocs m,-		"imports" .= _moduleImports m,-		"exports" .= _moduleExports m,-		"fixities" .= _moduleFixities m]--instance FromJSON Module where-	parseJSON = withObject "module" $ \v -> Module <$>-		v .:: "id" <*>-		v .::? "docs" <*>-		v .::?! "imports" <*>-		v .::?! "exports" <*>-		v .::?! "fixities" <*>-		pure mempty <*>-		pure Nothing--instance NFData (Assoc ()) where-	rnf (AssocNone _) = ()-	rnf (AssocLeft _) = ()-	rnf (AssocRight _) = ()--instance NFData Fixity where-	rnf (Fixity assoc pr n) = rnf assoc `seq` rnf pr `seq` rnf n--instance NFData Module where-	rnf (Module i d is e fs s msrc) = msrc `seq` rnf i `seq` rnf d `seq` rnf is `seq` rnf e `seq` rnf fs `seq` rnf s--instance Eq Module where-	l == r = _moduleId l == _moduleId r--instance Ord Module where-	compare l r = compare (_moduleId l) (_moduleId r)--instance Show Module where-	show = show . _moduleId--data Symbol = Symbol {-	_symbolId :: SymbolId,-	_symbolDocs :: Maybe Text,-	_symbolPosition :: Maybe Position,-	_symbolInfo :: SymbolInfo }--instance Eq Symbol where-	l == r = (_symbolId l, symbolType l) == (_symbolId r, symbolType r)--instance Ord Symbol where-	compare l r = compare (_symbolId l, symbolType l) (_symbolId r, symbolType r)--instance NFData Symbol where-	rnf (Symbol i d l info) = rnf i `seq` rnf d `seq` rnf l `seq` rnf info--instance Show Symbol where-	show = show . _symbolId--instance ToJSON Symbol where-	toJSON s = object $ noNulls [-		"id" .= _symbolId s,-		"docs" .= _symbolDocs s,-		"pos" .= _symbolPosition s,-		"info" .= _symbolInfo s]--instance FromJSON Symbol where-	parseJSON = withObject "symbol" $ \v -> Symbol <$>-		v .:: "id" <*>-		v .::? "docs" <*>-		v .::? "pos" <*>-		v .:: "info"--data SymbolInfo =-	Function { _functionType :: Maybe Text } |-	Method { _functionType :: Maybe Text, _parentClass :: Text } |-	Selector { _functionType :: Maybe Text, _parentType :: Text, _selectorConstructors :: [Text] } |-	Constructor { _typeArgs :: [Text], _parentType :: Text } |-	Type { _typeArgs :: [Text], _typeContext :: [Text] } |-	NewType { _typeArgs :: [Text], _typeContext :: [Text] } |-	Data { _typeArgs :: [Text], _typeContext :: [Text] } |-	Class { _typeArgs :: [Text], _typeContext :: [Text] } |-	TypeFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } |-	DataFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } |-	PatConstructor { _typeArgs :: [Text], _patternType :: Maybe Text } |-	PatSelector { _functionType :: Maybe Text, _patternType :: Maybe Text, _patternConstructor :: Text }-		deriving (Eq, Ord, Read, Show)--instance NFData SymbolInfo where-	rnf (Function ft) = rnf ft-	rnf (Method ft cls) = rnf ft `seq` rnf cls-	rnf (Selector ft t cs) = rnf ft `seq` rnf t `seq` rnf cs-	rnf (Constructor as t) = rnf as `seq` rnf t-	rnf (Type as ctx) = rnf as `seq` rnf ctx-	rnf (NewType as ctx) = rnf as `seq` rnf ctx-	rnf (Data as ctx) = rnf as `seq` rnf ctx-	rnf (Class as ctx) = rnf as `seq` rnf ctx-	rnf (TypeFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a-	rnf (DataFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a-	rnf (PatConstructor as t) = rnf as `seq` rnf t-	rnf (PatSelector ft t c) = rnf ft `seq` rnf t `seq` rnf c--instance ToJSON SymbolInfo where-	toJSON (Function ft) = object [what "function", "type" .= ft]-	toJSON (Method ft cls) = object [what "method", "type" .= ft, "class" .= cls]-	toJSON (Selector ft t cs) = object [what "selector", "type" .= ft, "parent" .= t, "constructors" .= cs]-	toJSON (Constructor as t) = object [what "ctor", "args" .= as, "type" .= t]-	toJSON (Type as ctx) = object [what "type", "args" .= as, "ctx" .= ctx]-	toJSON (NewType as ctx) = object [what "newtype", "args" .= as, "ctx" .= ctx]-	toJSON (Data as ctx) = object [what "data", "args" .= as, "ctx" .= ctx]-	toJSON (Class as ctx) = object [what "class", "args" .= as, "ctx" .= ctx]-	toJSON (TypeFam as ctx a) = object [what "type-family", "args" .= as, "ctx" .= ctx, "associate" .= a]-	toJSON (DataFam as ctx a) = object [what "data-family", "args" .= as, "ctx" .= ctx, "associate" .= a]-	toJSON (PatConstructor as t) = object [what "pat-ctor", "args" .= as, "pat-type" .= t]-	toJSON (PatSelector ft t c) = object [what "pat-selector", "type" .= ft, "pat-type" .= t, "constructor" .= c]--class EmptySymbolInfo a where-	infoOf :: a -> SymbolInfo--instance EmptySymbolInfo SymbolInfo where-	infoOf = id--instance (Monoid a, EmptySymbolInfo r) => EmptySymbolInfo (a -> r) where-	infoOf f = infoOf $ f mempty--symbolInfoType :: SymbolInfo -> String-symbolInfoType (Function{}) = "function"-symbolInfoType (Method{}) = "method"-symbolInfoType (Selector{}) = "selector"-symbolInfoType (Constructor{}) = "ctor"-symbolInfoType (Type{}) = "type"-symbolInfoType (NewType{}) = "newtype"-symbolInfoType (Data{}) = "data"-symbolInfoType (Class{}) = "class"-symbolInfoType (TypeFam{}) = "type-family"-symbolInfoType (DataFam{}) = "data-family"-symbolInfoType (PatConstructor{}) = "pat-ctor"-symbolInfoType (PatSelector{}) = "pat-selector"--symbolType :: Symbol -> String-symbolType = symbolInfoType . _symbolInfo--what :: String -> Pair-what n = "what" .= n--instance FromJSON SymbolInfo where-	parseJSON = withObject "symbol info" $ \v -> msum [-		gwhat "function" v >> (Function <$> v .::? "type"),-		gwhat "method" v >> (Method <$> v .::? "type" <*> v .:: "class"),-		gwhat "selector" v >> (Selector <$> v .::? "type" <*> v .:: "parent" <*> v .::?! "constructors"),-		gwhat "ctor" v >> (Constructor <$> v .::?! "args" <*> v .:: "type"),-		gwhat "type" v >> (Type <$> v .::?! "args" <*> v .::?! "ctx"),-		gwhat "newtype" v >> (NewType <$> v .::?! "args" <*> v .::?! "ctx"),-		gwhat "data" v >> (Data <$> v .::?! "args" <*> v .::?! "ctx"),-		gwhat "class" v >> (Class <$> v .::?! "args" <*> v .::?! "ctx"),-		gwhat "type-family" v >> (TypeFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"),-		gwhat "data-family" v >> (DataFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"),-		gwhat "pat-ctor" v >> (PatConstructor <$> v .::?! "args" <*> v .::? "pat-type"),-		gwhat "pat-selector" v >> (PatSelector <$> v .::? "type" <*> v .::? "pat-type" <*> v .:: "constructor")]--gwhat :: String -> Object -> Parser ()-gwhat n v = do-	s <- v .:: "what"-	guard (s == n)---- | Scoped entity with qualifier-data Scoped a = Scoped {-	_scopeQualifier :: Maybe Text,-	_scoped :: a }-		deriving (Eq, Ord)--instance Show a => Show (Scoped a) where-	show (Scoped q s) = maybe "" (\q' -> T.unpack q' ++ ".") q ++ show s--instance ToJSON a => ToJSON (Scoped a) where-	toJSON (Scoped q s) = toJSON s `objectUnion` object (noNulls ["qualifier" .= q])--instance FromJSON a => FromJSON (Scoped a) where-	parseJSON = withObject "scope-symbol" $ \v -> Scoped <$>-		(v .::? "qualifier") <*>-		parseJSON (Object v)---- | Symbol usage-data SymbolUsage = SymbolUsage {-	_symbolUsed :: Symbol,-	_symbolUsedQualifier :: Maybe Text,-	_symbolUsedIn :: ModuleId,-	_symbolUsedRegion :: Region }-		deriving (Eq, Ord)--instance Show SymbolUsage where-	show (SymbolUsage s _ m p) = show s ++ " at " ++ show m ++ ":" ++ show p--instance ToJSON SymbolUsage where-	toJSON (SymbolUsage s q m p) = object $ noNulls ["symbol" .= s, "qualifier" .= q, "in" .= m, "at" .= p]--instance FromJSON SymbolUsage where-	parseJSON = withObject "symbol-usage" $ \v -> SymbolUsage <$>-		v .:: "symbol" <*>-		v .::? "qualifier" <*>-		v .:: "in" <*>-		v .:: "at"---- | Symbol with module it's exported from-data ImportedSymbol = ImportedSymbol {-	_importedSymbol :: Symbol,-	_importedFrom :: ModuleId }-		deriving (Eq, Ord)--instance Show ImportedSymbol where-	show (ImportedSymbol s m) = show s ++ " imported from " ++ show m--instance ToJSON ImportedSymbol where-	toJSON (ImportedSymbol s m) = objectUnion (toJSON s) $ object [-		"imported" .= m]--instance FromJSON ImportedSymbol where-	parseJSON = withObject "imported-symbol" $ \v -> ImportedSymbol <$>-		parseJSON (Object v) <*>-		v .:: "imported"---- | Inspection data-data Inspection =-	-- | No inspection-	InspectionNone |-	-- | Time and flags of inspection-	InspectionAt {-		_inspectionAt :: POSIXTime,-		_inspectionOpts :: [Text] }-			deriving (Eq, Ord)--instance NFData Inspection where-	rnf InspectionNone = ()-	rnf (InspectionAt t fs) = rnf t `seq` rnf fs--instance Show Inspection where-	show InspectionNone = "none"-	show (InspectionAt tm fs) = "mtime " ++ show tm ++ ", flags [" ++ intercalate ", " (map T.unpack fs) ++ "]"--instance Read POSIXTime where-	readsPrec i = map (first (fromIntegral :: Integer -> POSIXTime)) . readsPrec i--instance Monoid Inspection where-	mempty = InspectionNone-	mappend InspectionNone r = r-	mappend l InspectionNone = l-	mappend (InspectionAt ltm lopts) (InspectionAt rtm ropts)-		| ltm >= rtm = InspectionAt ltm lopts-		| otherwise = InspectionAt rtm ropts--instance ToJSON Inspection where-	toJSON InspectionNone = object ["inspected" .= False]-	toJSON (InspectionAt tm fs) = object [-		"mtime" .= (fromRational (toRational tm) :: Double),-		"flags" .= fs]--instance FromJSON Inspection where-	parseJSON = withObject "inspection" $ \v ->-		((const InspectionNone :: Bool -> Inspection) <$> v .:: "inspected") <|>-		(InspectionAt <$> ((fromRational . (toRational :: Double -> Rational)) <$> v .:: "mtime") <*> (v .:: "flags"))---- | Is left @Inspection@ fresh comparing to right one-fresh :: Inspection -> Inspection -> Bool-fresh InspectionNone InspectionNone = True-fresh InspectionNone _ = False-fresh _ InspectionNone = True-fresh (InspectionAt tm _) (InspectionAt tm' _) = tm' - tm < 0.01---- | Inspected entity-data Inspected k t a = Inspected {-	_inspection :: Inspection,-	_inspectedKey :: k,-	_inspectionTags :: Set t,-	_inspectionResult :: Either HsDevError a }--inspectedTup :: Inspected k t a -> (Inspection, k, Set t, Maybe a)-inspectedTup (Inspected insp i tags res) = (insp, i, tags, either (const Nothing) Just res)--instance (Eq k, Eq t, Eq a) => Eq (Inspected k t a) where-	(==) = (==) `on` inspectedTup--instance (Ord k, Ord t, Ord a) => Ord (Inspected k t a) where-	compare = comparing inspectedTup--instance Functor (Inspected k t) where-	fmap f insp = insp {-		_inspectionResult = fmap f (_inspectionResult insp) }--instance Foldable (Inspected k t) where-	foldMap f = either mempty f . _inspectionResult--instance Traversable (Inspected k t) where-	traverse f (Inspected insp i ts r) = Inspected insp i ts <$> either (pure . Left) (liftA Right . f) r--instance (NFData k, NFData t, NFData a) => NFData (Inspected k t a) where-	rnf (Inspected t i ts r) = rnf t `seq` rnf i `seq` rnf ts `seq` rnf r--instance (ToJSON k, ToJSON t, ToJSON a) => ToJSON (Inspected k t a) where-	toJSON im = object [-		"inspection" .= _inspection im,-		"location" .= _inspectedKey im,-		"tags" .= S.toList (_inspectionTags im),-		either ("error" .=) ("result" .=) (_inspectionResult im)]--instance (FromJSON k, Ord t, FromJSON t, FromJSON a) => FromJSON (Inspected k t a) where-	parseJSON = withObject "inspected" $ \v -> Inspected <$>-		v .:: "inspection" <*>-		v .:: "location" <*>-		(S.fromList <$> (v .::?! "tags")) <*>-		((Left <$> v .:: "error") <|> (Right <$> v .:: "result"))--newtype InspectM k t m a = InspectM { runInspectM :: ReaderT k (ExceptT HsDevError (StateT (Inspection, S.Set t) m)) a }-	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadReader k, MonadError HsDevError, MonadState (Inspection, S.Set t))--instance MonadTrans (InspectM k t) where-	lift = InspectM . lift . lift . lift--runInspect :: (Monad m, Ord t) => k -> InspectM k t m a -> m (Inspected k t a)-runInspect key act = do-	(res, (insp, ts)) <- flip runStateT (InspectionNone, mempty) . runExceptT . flip runReaderT key . runInspectM $ act-	return $ Inspected insp key ts res---- | Continue inspection-continueInspect :: (Monad m, Ord t) => Inspected k t a -> (a -> InspectM k t m b) -> m (Inspected k t b)-continueInspect start act = runInspect (_inspectedKey start) $ do-	put (_inspection start, _inspectionTags start)-	val <- either throwError return $ _inspectionResult start-	act val--inspect :: MonadCatch m => m Inspection -> (k -> m a) -> InspectM k t m a-inspect insp act = withInspection insp $ do-	key <- ask-	lift (hsdevCatch (hsdevLiftIO $ act key)) >>= either throwError return--withInspection :: MonadCatch m => m Inspection -> InspectM k t m a -> InspectM k t m a-withInspection insp inner = do-	insp' <- lift insp-	let-		setInsp = modify (set _1 insp')-	catchError (inner <* setInsp) (\e -> setInsp >> throwError e)--inspect_ :: MonadCatch m => m Inspection -> m a -> InspectM k t m a-inspect_ insp = inspect insp . const---- | Empty tags-noTags :: Set t-noTags = S.empty---- | One tag-tag :: t -> Set t-tag = S.singleton--data ModuleTag = InferredTypesTag | RefinedDocsTag | OnlyHeaderTag | DirtyTag | ResolvedNamesTag deriving (Eq, Ord, Read, Show, Enum, Bounded)--instance NFData ModuleTag where-	rnf InferredTypesTag = ()-	rnf RefinedDocsTag = ()-	rnf OnlyHeaderTag = ()-	rnf DirtyTag = ()-	rnf ResolvedNamesTag = ()--instance Display ModuleTag where-	display InferredTypesTag = "types"-	display RefinedDocsTag = "docs"-	display OnlyHeaderTag = "header"-	display DirtyTag = "dirty"-	display ResolvedNamesTag = "resolved"-	displayType _ = "module-tag"--instance ToJSON ModuleTag where-	toJSON InferredTypesTag = toJSON ("types" :: String)-	toJSON RefinedDocsTag = toJSON ("docs" :: String)-	toJSON OnlyHeaderTag = toJSON ("header" :: String)-	toJSON DirtyTag = toJSON ("dirty" :: String)-	toJSON ResolvedNamesTag = toJSON ("resolved" :: String)--instance FromJSON ModuleTag where-	parseJSON = withText "module-tag" $ \txt -> msum [-		guard (txt == "types") >> return InferredTypesTag,-		guard (txt == "docs") >> return RefinedDocsTag,-		guard (txt == "header") >> return OnlyHeaderTag,-		guard (txt == "dirty") >> return DirtyTag,-		guard (txt == "resolved") >> return ResolvedNamesTag]---- | Inspected module-type InspectedModule = Inspected ModuleLocation ModuleTag Module--instance Show InspectedModule where-	show (Inspected i mi ts m) = unlines [either showError show m, "\tinspected: " ++ show i, "\ttags: " ++ intercalate ", " (map show $ S.toList ts)] where-		showError :: HsDevError -> String-		showError e = unlines $ ("\terror: " ++ show e) : case mi of-			FileModule f p -> ["file: " ++ f ^. path, "project: " ++ maybe "" (view (projectPath . path)) p]-			InstalledModule c p n _  -> ["cabal: " ++ show c, "package: " ++ show p, "name: " ++ T.unpack n]-			OtherLocation src -> ["other location: " ++ T.unpack src]-			NoLocation -> ["no location"]--notInspected :: ModuleLocation -> InspectedModule-notInspected mloc = Inspected mempty mloc noTags (Left $ NotInspected mloc)--instance Documented ModuleId where-	brief m = brief $ _moduleLocation m-	detailed = brief--instance Documented SymbolId where-	brief s = "{} from {}" ~~ _symbolName s ~~ brief (_symbolModule s)-	detailed = brief--instance Documented Module where-	brief = brief . _moduleId-	detailed m = T.unlines (brief m : info) where-		info = [-			"\texports: {}" ~~ T.intercalate ", " (map brief (_moduleExports m))]--instance Documented Symbol where-	brief = brief . _symbolId-	detailed s = T.unlines [brief s, info] where-		info = case _symbolInfo s of-			Function t -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "function", fmap ("type: {}" ~~) t])-			Method t p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "method", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p])-			Selector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "selector", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p])-			Constructor args p -> "\t" `T.append` T.intercalate ", " ["constructor", "args: {}" ~~ T.unwords args, "parent: {}" ~~ p]-			Type args ctx -> "\t" `T.append` T.intercalate ", " ["type", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]-			NewType args ctx -> "\t" `T.append` T.intercalate ", " ["newtype", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]-			Data args ctx -> "\t" `T.append` T.intercalate ", " ["data", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]-			Class args ctx -> "\t" `T.append` T.intercalate ", " ["class", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]-			TypeFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["type family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]-			DataFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["data family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]-			PatConstructor args p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern constructor", Just $ "args: {}" ~~ T.unwords args, fmap ("pat-type: {}" ~~) p])-			PatSelector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern selector", fmap ("type: {}" ~~) t, fmap ("pat-type: {}" ~~) p])--makeLenses ''Import-makeLenses ''Module-makeLenses ''Symbol-makeLenses ''SymbolInfo-makeLenses ''Scoped-makeLenses ''SymbolUsage-makeLenses ''ImportedSymbol-makeLenses ''Inspection-makeLenses ''Inspected--inspected :: Traversal (Inspected k t a) (Inspected k t b) a b-inspected = inspectionResult . _Right--nullifyInfo :: SymbolInfo -> SymbolInfo-nullifyInfo = chain [-	set functionType mempty,-	set parentClass mempty,-	set parentType mempty,-	set selectorConstructors mempty,-	set typeArgs mempty,-	set typeContext mempty,-	set familyAssociate mempty,-	set patternType mempty,-	set patternConstructor mempty]--instance Sourced Module where-	sourcedName = moduleId . moduleName-	sourcedDocs = moduleDocs . _Just-	sourcedModule = moduleId--instance Sourced Symbol where-	sourcedName = symbolId . symbolName-	sourcedDocs = symbolDocs . _Just-	sourcedModule = symbolId . symbolModule-	sourcedLocation = symbolPosition . _Just+{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Symbols.Types (
+	Import(..), importPosition, importName, importQualified, importAs,
+	Module(..), moduleSymbols, exportedSymbols, scopeSymbols, fixitiesMap, moduleFixities, moduleId, moduleDocs, moduleImports, moduleExports, moduleScope, moduleSource,
+	Symbol(..), symbolId, symbolDocs, symbolPosition, symbolInfo,
+	SymbolInfo(..), functionType, parentClass, parentType, selectorConstructors, typeArgs, typeContext, familyAssociate, symbolInfoType, symbolType, patternType, patternConstructor,
+	Scoped(..), scopeQualifier, scoped,
+	SymbolUsage(..), symbolUsed, symbolUsedQualifier, symbolUsedIn, symbolUsedRegion,
+	ImportedSymbol(..), importedSymbol, importedFrom,
+	infoOf, nullifyInfo,
+	Inspection(..), inspectionAt, inspectionOpts, fresh, Inspected(..), inspection, inspectedKey, inspectionTags, inspectionResult, inspected,
+	InspectM(..), runInspect, continueInspect, inspect, inspect_, withInspection,
+	inspectedTup, noTags, tag, ModuleTag(..), InspectedModule, notInspected,
+
+	module HsDev.PackageDb.Types,
+	module HsDev.Project,
+	module HsDev.Symbols.Name,
+	module HsDev.Symbols.Class,
+	module HsDev.Symbols.Location,
+	module HsDev.Symbols.Documented
+	) where
+
+import Control.Arrow
+import Control.Applicative
+import Control.Lens hiding ((.=))
+import Control.Monad
+import Control.Monad.Morph
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.DeepSeq (NFData(..))
+import Data.Aeson
+import Data.Aeson.Types (Pair, Parser)
+import Data.List (intercalate)
+import Data.Maybe (catMaybes)
+import Data.Maybe.JustIf
+import Data.Monoid (Any(..))
+import Data.Function
+import Data.Ord
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time.Clock.POSIX (POSIXTime)
+import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..), Fixity(..), Assoc(..))
+import qualified Language.Haskell.Exts as Exts (Name(..))
+import Text.Format
+
+import Control.Apply.Util (chain)
+import HsDev.Display
+import HsDev.Error
+import HsDev.PackageDb.Types
+import HsDev.Project
+import HsDev.Symbols.Name
+import HsDev.Symbols.Class
+import HsDev.Symbols.Location
+import HsDev.Symbols.Documented
+import HsDev.Symbols.Parsed
+import HsDev.Util ((.::), (.::?), (.::?!), noNulls, objectUnion)
+import System.Directory.Paths
+
+instance NFData l => NFData (ModuleName l) where
+	rnf (ModuleName l n) = rnf l `seq` rnf n
+
+instance NFData l => NFData (Exts.Name l) where
+	rnf (Exts.Ident l s) = rnf l `seq` rnf s
+	rnf (Exts.Symbol l s) = rnf l `seq` rnf s
+
+instance NFData Boxed where
+	rnf Boxed = ()
+	rnf Unboxed = ()
+
+instance NFData l => NFData (SpecialCon l) where
+	rnf (UnitCon l) = rnf l
+	rnf (ListCon l) = rnf l
+	rnf (FunCon l) = rnf l
+	rnf (TupleCon l b i) = rnf l `seq` rnf b `seq` rnf i
+	rnf (Cons l) = rnf l
+	rnf (UnboxedSingleCon l) = rnf l
+#if MIN_VERSION_haskell_src_exts(1,20,0)
+	rnf (ExprHole l) = rnf l
+#endif
+
+instance NFData l => NFData (QName l) where
+	rnf (Qual l m n) = rnf l `seq` rnf m `seq` rnf n
+	rnf (UnQual l n) = rnf l `seq` rnf n
+	rnf (Special l s) = rnf l `seq` rnf s
+
+-- | Import
+data Import = Import {
+	_importPosition :: Position, -- source line of import
+	_importName :: Text, -- imported module name
+	_importQualified :: Bool, -- is import qualified
+	_importAs :: Maybe Text } -- alias of import
+		deriving (Eq, Ord)
+
+instance NFData Import where
+	rnf (Import p n q a) = rnf p `seq` rnf n `seq` rnf q `seq` rnf a
+
+instance Show Import where
+	show (Import _ n q a) = concat $ catMaybes [
+		Just "import",
+		"qualified" `justIf` q,
+		Just $ show n,
+		fmap (("as " ++) . show) a]
+
+instance ToJSON Import where
+	toJSON (Import p n q a) = object [
+		"pos" .= p,
+		"name" .= n,
+		"qualified" .= q,
+		"as" .= a]
+
+instance FromJSON Import where
+	parseJSON = withObject "import" $ \v -> Import <$>
+		v .:: "pos" <*>
+		v .:: "name" <*>
+		v .:: "qualified" <*>
+		v .:: "as"
+
+-- | Module
+data Module = Module {
+	_moduleId :: ModuleId,
+	_moduleDocs :: Maybe Text,
+	_moduleImports :: [Import], -- list of module names imported
+	_moduleExports :: [Symbol], -- exported module symbols
+	_moduleFixities :: [Fixity], -- fixities of operators
+	_moduleScope :: Map Name [Symbol], -- symbols in scope, only for source modules
+	_moduleSource :: Maybe Parsed } -- source of module
+
+-- | Make each symbol appear only once
+moduleSymbols :: Traversal' Module Symbol
+moduleSymbols f m = getBack <$> (each . _1) f revList where
+	revList = M.toList $ M.unionsWith mappend $ concat [
+		[M.singleton sym ([], Any True) | sym <- _moduleExports m],
+		[M.singleton sym ([nm], Any False) | (nm, syms) <- M.toList (_moduleScope m), sym <- syms]]
+	getBack syms = m {
+		_moduleExports = [sym' | (sym', (_, Any True)) <- syms],
+		_moduleScope = M.unionsWith (++) [M.singleton n [sym'] | (sym', (ns, _)) <- syms, n <- ns] }
+
+exportedSymbols :: Traversal' Module Symbol
+exportedSymbols f m = (\e -> m { _moduleExports = e }) <$> traverse f (_moduleExports m)
+
+scopeSymbols :: Traversal' Module (Symbol, [Name])
+scopeSymbols f m = (\s -> m { _moduleScope = invMap s }) <$> traverse f (M.toList . invMap . M.toList $ _moduleScope m) where
+	invMap :: Ord b => [(a, [b])] -> Map b [a]
+	invMap es = M.unionsWith (++) [M.singleton v [k] | (k, vs) <- es, v <- vs]
+
+fixitiesMap :: Lens' Module (Map Name Fixity)
+fixitiesMap = lens g' s' where
+	g' m = mconcat [M.singleton n f | f@(Fixity _ _ n) <- _moduleFixities m]
+	s' m m' = m { _moduleFixities = M.elems m' }
+
+instance ToJSON (Assoc ()) where
+	toJSON (AssocNone _) = toJSON ("none" :: String)
+	toJSON (AssocLeft _) = toJSON ("left" :: String)
+	toJSON (AssocRight _) = toJSON ("right" :: String)
+
+instance FromJSON (Assoc ()) where
+	parseJSON = withText "assoc" $ \txt -> msum [
+		guard (txt == "none") >> return (AssocNone ()),
+		guard (txt == "left") >> return (AssocLeft ()),
+		guard (txt == "right") >> return (AssocRight ())]
+
+instance ToJSON Fixity where
+	toJSON (Fixity assoc pr n) = object $ noNulls [
+		"assoc" .= assoc,
+		"prior" .= pr,
+		"name" .= fromName n]
+
+instance FromJSON Fixity where
+	parseJSON = withObject "fixity" $ \v -> Fixity <$>
+		v .:: "assoc" <*>
+		v .:: "prior" <*>
+		(toName <$> v .:: "name")
+
+instance ToJSON Module where
+	toJSON m = object $ noNulls [
+		"id" .= _moduleId m,
+		"docs" .= _moduleDocs m,
+		"imports" .= _moduleImports m,
+		"exports" .= _moduleExports m,
+		"fixities" .= _moduleFixities m]
+
+instance FromJSON Module where
+	parseJSON = withObject "module" $ \v -> Module <$>
+		v .:: "id" <*>
+		v .::? "docs" <*>
+		v .::?! "imports" <*>
+		v .::?! "exports" <*>
+		v .::?! "fixities" <*>
+		pure mempty <*>
+		pure Nothing
+
+instance NFData (Assoc ()) where
+	rnf (AssocNone _) = ()
+	rnf (AssocLeft _) = ()
+	rnf (AssocRight _) = ()
+
+instance NFData Fixity where
+	rnf (Fixity assoc pr n) = rnf assoc `seq` rnf pr `seq` rnf n
+
+instance NFData Module where
+	rnf (Module i d is e fs s msrc) = msrc `seq` rnf i `seq` rnf d `seq` rnf is `seq` rnf e `seq` rnf fs `seq` rnf s
+
+instance Eq Module where
+	l == r = _moduleId l == _moduleId r
+
+instance Ord Module where
+	compare l r = compare (_moduleId l) (_moduleId r)
+
+instance Show Module where
+	show = show . _moduleId
+
+data Symbol = Symbol {
+	_symbolId :: SymbolId,
+	_symbolDocs :: Maybe Text,
+	_symbolPosition :: Maybe Position,
+	_symbolInfo :: SymbolInfo }
+
+instance Eq Symbol where
+	l == r = (_symbolId l, symbolType l) == (_symbolId r, symbolType r)
+
+instance Ord Symbol where
+	compare l r = compare (_symbolId l, symbolType l) (_symbolId r, symbolType r)
+
+instance NFData Symbol where
+	rnf (Symbol i d l info) = rnf i `seq` rnf d `seq` rnf l `seq` rnf info
+
+instance Show Symbol where
+	show = show . _symbolId
+
+instance ToJSON Symbol where
+	toJSON s = object $ noNulls [
+		"id" .= _symbolId s,
+		"docs" .= _symbolDocs s,
+		"pos" .= _symbolPosition s,
+		"info" .= _symbolInfo s]
+
+instance FromJSON Symbol where
+	parseJSON = withObject "symbol" $ \v -> Symbol <$>
+		v .:: "id" <*>
+		v .::? "docs" <*>
+		v .::? "pos" <*>
+		v .:: "info"
+
+data SymbolInfo =
+	Function { _functionType :: Maybe Text } |
+	Method { _functionType :: Maybe Text, _parentClass :: Text } |
+	Selector { _functionType :: Maybe Text, _parentType :: Text, _selectorConstructors :: [Text] } |
+	Constructor { _typeArgs :: [Text], _parentType :: Text } |
+	Type { _typeArgs :: [Text], _typeContext :: [Text] } |
+	NewType { _typeArgs :: [Text], _typeContext :: [Text] } |
+	Data { _typeArgs :: [Text], _typeContext :: [Text] } |
+	Class { _typeArgs :: [Text], _typeContext :: [Text] } |
+	TypeFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } |
+	DataFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } |
+	PatConstructor { _typeArgs :: [Text], _patternType :: Maybe Text } |
+	PatSelector { _functionType :: Maybe Text, _patternType :: Maybe Text, _patternConstructor :: Text }
+		deriving (Eq, Ord, Read, Show)
+
+instance NFData SymbolInfo where
+	rnf (Function ft) = rnf ft
+	rnf (Method ft cls) = rnf ft `seq` rnf cls
+	rnf (Selector ft t cs) = rnf ft `seq` rnf t `seq` rnf cs
+	rnf (Constructor as t) = rnf as `seq` rnf t
+	rnf (Type as ctx) = rnf as `seq` rnf ctx
+	rnf (NewType as ctx) = rnf as `seq` rnf ctx
+	rnf (Data as ctx) = rnf as `seq` rnf ctx
+	rnf (Class as ctx) = rnf as `seq` rnf ctx
+	rnf (TypeFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a
+	rnf (DataFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a
+	rnf (PatConstructor as t) = rnf as `seq` rnf t
+	rnf (PatSelector ft t c) = rnf ft `seq` rnf t `seq` rnf c
+
+instance ToJSON SymbolInfo where
+	toJSON (Function ft) = object [what "function", "type" .= ft]
+	toJSON (Method ft cls) = object [what "method", "type" .= ft, "class" .= cls]
+	toJSON (Selector ft t cs) = object [what "selector", "type" .= ft, "parent" .= t, "constructors" .= cs]
+	toJSON (Constructor as t) = object [what "ctor", "args" .= as, "type" .= t]
+	toJSON (Type as ctx) = object [what "type", "args" .= as, "ctx" .= ctx]
+	toJSON (NewType as ctx) = object [what "newtype", "args" .= as, "ctx" .= ctx]
+	toJSON (Data as ctx) = object [what "data", "args" .= as, "ctx" .= ctx]
+	toJSON (Class as ctx) = object [what "class", "args" .= as, "ctx" .= ctx]
+	toJSON (TypeFam as ctx a) = object [what "type-family", "args" .= as, "ctx" .= ctx, "associate" .= a]
+	toJSON (DataFam as ctx a) = object [what "data-family", "args" .= as, "ctx" .= ctx, "associate" .= a]
+	toJSON (PatConstructor as t) = object [what "pat-ctor", "args" .= as, "pat-type" .= t]
+	toJSON (PatSelector ft t c) = object [what "pat-selector", "type" .= ft, "pat-type" .= t, "constructor" .= c]
+
+class EmptySymbolInfo a where
+	infoOf :: a -> SymbolInfo
+
+instance EmptySymbolInfo SymbolInfo where
+	infoOf = id
+
+instance (Monoid a, EmptySymbolInfo r) => EmptySymbolInfo (a -> r) where
+	infoOf f = infoOf $ f mempty
+
+symbolInfoType :: SymbolInfo -> String
+symbolInfoType (Function{}) = "function"
+symbolInfoType (Method{}) = "method"
+symbolInfoType (Selector{}) = "selector"
+symbolInfoType (Constructor{}) = "ctor"
+symbolInfoType (Type{}) = "type"
+symbolInfoType (NewType{}) = "newtype"
+symbolInfoType (Data{}) = "data"
+symbolInfoType (Class{}) = "class"
+symbolInfoType (TypeFam{}) = "type-family"
+symbolInfoType (DataFam{}) = "data-family"
+symbolInfoType (PatConstructor{}) = "pat-ctor"
+symbolInfoType (PatSelector{}) = "pat-selector"
+
+symbolType :: Symbol -> String
+symbolType = symbolInfoType . _symbolInfo
+
+what :: String -> Pair
+what n = "what" .= n
+
+instance FromJSON SymbolInfo where
+	parseJSON = withObject "symbol info" $ \v -> msum [
+		gwhat "function" v >> (Function <$> v .::? "type"),
+		gwhat "method" v >> (Method <$> v .::? "type" <*> v .:: "class"),
+		gwhat "selector" v >> (Selector <$> v .::? "type" <*> v .:: "parent" <*> v .::?! "constructors"),
+		gwhat "ctor" v >> (Constructor <$> v .::?! "args" <*> v .:: "type"),
+		gwhat "type" v >> (Type <$> v .::?! "args" <*> v .::?! "ctx"),
+		gwhat "newtype" v >> (NewType <$> v .::?! "args" <*> v .::?! "ctx"),
+		gwhat "data" v >> (Data <$> v .::?! "args" <*> v .::?! "ctx"),
+		gwhat "class" v >> (Class <$> v .::?! "args" <*> v .::?! "ctx"),
+		gwhat "type-family" v >> (TypeFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"),
+		gwhat "data-family" v >> (DataFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"),
+		gwhat "pat-ctor" v >> (PatConstructor <$> v .::?! "args" <*> v .::? "pat-type"),
+		gwhat "pat-selector" v >> (PatSelector <$> v .::? "type" <*> v .::? "pat-type" <*> v .:: "constructor")]
+
+gwhat :: String -> Object -> Parser ()
+gwhat n v = do
+	s <- v .:: "what"
+	guard (s == n)
+
+-- | Scoped entity with qualifier
+data Scoped a = Scoped {
+	_scopeQualifier :: Maybe Text,
+	_scoped :: a }
+		deriving (Eq, Ord)
+
+instance Show a => Show (Scoped a) where
+	show (Scoped q s) = maybe "" (\q' -> T.unpack q' ++ ".") q ++ show s
+
+instance ToJSON a => ToJSON (Scoped a) where
+	toJSON (Scoped q s) = toJSON s `objectUnion` object (noNulls ["qualifier" .= q])
+
+instance FromJSON a => FromJSON (Scoped a) where
+	parseJSON = withObject "scope-symbol" $ \v -> Scoped <$>
+		(v .::? "qualifier") <*>
+		parseJSON (Object v)
+
+-- | Symbol usage
+data SymbolUsage = SymbolUsage {
+	_symbolUsed :: Symbol,
+	_symbolUsedQualifier :: Maybe Text,
+	_symbolUsedIn :: ModuleId,
+	_symbolUsedRegion :: Region }
+		deriving (Eq, Ord)
+
+instance Show SymbolUsage where
+	show (SymbolUsage s _ m p) = show s ++ " at " ++ show m ++ ":" ++ show p
+
+instance ToJSON SymbolUsage where
+	toJSON (SymbolUsage s q m p) = object $ noNulls ["symbol" .= s, "qualifier" .= q, "in" .= m, "at" .= p]
+
+instance FromJSON SymbolUsage where
+	parseJSON = withObject "symbol-usage" $ \v -> SymbolUsage <$>
+		v .:: "symbol" <*>
+		v .::? "qualifier" <*>
+		v .:: "in" <*>
+		v .:: "at"
+
+-- | Symbol with module it's exported from
+data ImportedSymbol = ImportedSymbol {
+	_importedSymbol :: Symbol,
+	_importedFrom :: ModuleId }
+		deriving (Eq, Ord)
+
+instance Show ImportedSymbol where
+	show (ImportedSymbol s m) = show s ++ " imported from " ++ show m
+
+instance ToJSON ImportedSymbol where
+	toJSON (ImportedSymbol s m) = objectUnion (toJSON s) $ object [
+		"imported" .= m]
+
+instance FromJSON ImportedSymbol where
+	parseJSON = withObject "imported-symbol" $ \v -> ImportedSymbol <$>
+		parseJSON (Object v) <*>
+		v .:: "imported"
+
+-- | Inspection data
+data Inspection =
+	-- | No inspection
+	InspectionNone |
+	-- | Time and flags of inspection
+	InspectionAt {
+		_inspectionAt :: POSIXTime,
+		_inspectionOpts :: [Text] }
+			deriving (Eq, Ord)
+
+instance NFData Inspection where
+	rnf InspectionNone = ()
+	rnf (InspectionAt t fs) = rnf t `seq` rnf fs
+
+instance Show Inspection where
+	show InspectionNone = "none"
+	show (InspectionAt tm fs) = "mtime " ++ show tm ++ ", flags [" ++ intercalate ", " (map T.unpack fs) ++ "]"
+
+instance Read POSIXTime where
+	readsPrec i = map (first (fromIntegral :: Integer -> POSIXTime)) . readsPrec i
+
+instance Monoid Inspection where
+	mempty = InspectionNone
+	mappend InspectionNone r = r
+	mappend l InspectionNone = l
+	mappend (InspectionAt ltm lopts) (InspectionAt rtm ropts)
+		| ltm >= rtm = InspectionAt ltm lopts
+		| otherwise = InspectionAt rtm ropts
+
+instance ToJSON Inspection where
+	toJSON InspectionNone = object ["inspected" .= False]
+	toJSON (InspectionAt tm fs) = object [
+		"mtime" .= (fromRational (toRational tm) :: Double),
+		"flags" .= fs]
+
+instance FromJSON Inspection where
+	parseJSON = withObject "inspection" $ \v ->
+		((const InspectionNone :: Bool -> Inspection) <$> v .:: "inspected") <|>
+		(InspectionAt <$> ((fromRational . (toRational :: Double -> Rational)) <$> v .:: "mtime") <*> (v .:: "flags"))
+
+-- | Is left @Inspection@ fresh comparing to right one
+fresh :: Inspection -> Inspection -> Bool
+fresh InspectionNone InspectionNone = True
+fresh InspectionNone _ = False
+fresh _ InspectionNone = True
+fresh (InspectionAt tm _) (InspectionAt tm' _) = tm' - tm < 0.01
+
+-- | Inspected entity
+data Inspected k t a = Inspected {
+	_inspection :: Inspection,
+	_inspectedKey :: k,
+	_inspectionTags :: Set t,
+	_inspectionResult :: Either HsDevError a }
+
+inspectedTup :: Inspected k t a -> (Inspection, k, Set t, Maybe a)
+inspectedTup (Inspected insp i tags res) = (insp, i, tags, either (const Nothing) Just res)
+
+instance (Eq k, Eq t, Eq a) => Eq (Inspected k t a) where
+	(==) = (==) `on` inspectedTup
+
+instance (Ord k, Ord t, Ord a) => Ord (Inspected k t a) where
+	compare = comparing inspectedTup
+
+instance Functor (Inspected k t) where
+	fmap f insp = insp {
+		_inspectionResult = fmap f (_inspectionResult insp) }
+
+instance Foldable (Inspected k t) where
+	foldMap f = either mempty f . _inspectionResult
+
+instance Traversable (Inspected k t) where
+	traverse f (Inspected insp i ts r) = Inspected insp i ts <$> either (pure . Left) (liftA Right . f) r
+
+instance (NFData k, NFData t, NFData a) => NFData (Inspected k t a) where
+	rnf (Inspected t i ts r) = rnf t `seq` rnf i `seq` rnf ts `seq` rnf r
+
+instance (ToJSON k, ToJSON t, ToJSON a) => ToJSON (Inspected k t a) where
+	toJSON im = object [
+		"inspection" .= _inspection im,
+		"location" .= _inspectedKey im,
+		"tags" .= S.toList (_inspectionTags im),
+		either ("error" .=) ("result" .=) (_inspectionResult im)]
+
+instance (FromJSON k, Ord t, FromJSON t, FromJSON a) => FromJSON (Inspected k t a) where
+	parseJSON = withObject "inspected" $ \v -> Inspected <$>
+		v .:: "inspection" <*>
+		v .:: "location" <*>
+		(S.fromList <$> (v .::?! "tags")) <*>
+		((Left <$> v .:: "error") <|> (Right <$> v .:: "result"))
+
+newtype InspectM k t m a = InspectM { runInspectM :: ReaderT k (ExceptT HsDevError (StateT (Inspection, S.Set t) m)) a }
+	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadReader k, MonadError HsDevError, MonadState (Inspection, S.Set t))
+
+instance MonadTrans (InspectM k t) where
+	lift = InspectM . lift . lift . lift
+
+runInspect :: (Monad m, Ord t) => k -> InspectM k t m a -> m (Inspected k t a)
+runInspect key act = do
+	(res, (insp, ts)) <- flip runStateT (InspectionNone, mempty) . runExceptT . flip runReaderT key . runInspectM $ act
+	return $ Inspected insp key ts res
+
+-- | Continue inspection
+continueInspect :: (Monad m, Ord t) => Inspected k t a -> (a -> InspectM k t m b) -> m (Inspected k t b)
+continueInspect start act = runInspect (_inspectedKey start) $ do
+	put (_inspection start, _inspectionTags start)
+	val <- either throwError return $ _inspectionResult start
+	act val
+
+inspect :: MonadCatch m => m Inspection -> (k -> m a) -> InspectM k t m a
+inspect insp act = withInspection insp $ do
+	key <- ask
+	lift (hsdevCatch (hsdevLiftIO $ act key)) >>= either throwError return
+
+withInspection :: MonadCatch m => m Inspection -> InspectM k t m a -> InspectM k t m a
+withInspection insp inner = do
+	insp' <- lift insp
+	let
+		setInsp = modify (set _1 insp')
+	catchError (inner <* setInsp) (\e -> setInsp >> throwError e)
+
+inspect_ :: MonadCatch m => m Inspection -> m a -> InspectM k t m a
+inspect_ insp = inspect insp . const
+
+-- | Empty tags
+noTags :: Set t
+noTags = S.empty
+
+-- | One tag
+tag :: t -> Set t
+tag = S.singleton
+
+data ModuleTag = InferredTypesTag | RefinedDocsTag | OnlyHeaderTag | DirtyTag | ResolvedNamesTag deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+instance NFData ModuleTag where
+	rnf InferredTypesTag = ()
+	rnf RefinedDocsTag = ()
+	rnf OnlyHeaderTag = ()
+	rnf DirtyTag = ()
+	rnf ResolvedNamesTag = ()
+
+instance Display ModuleTag where
+	display InferredTypesTag = "types"
+	display RefinedDocsTag = "docs"
+	display OnlyHeaderTag = "header"
+	display DirtyTag = "dirty"
+	display ResolvedNamesTag = "resolved"
+	displayType _ = "module-tag"
+
+instance ToJSON ModuleTag where
+	toJSON InferredTypesTag = toJSON ("types" :: String)
+	toJSON RefinedDocsTag = toJSON ("docs" :: String)
+	toJSON OnlyHeaderTag = toJSON ("header" :: String)
+	toJSON DirtyTag = toJSON ("dirty" :: String)
+	toJSON ResolvedNamesTag = toJSON ("resolved" :: String)
+
+instance FromJSON ModuleTag where
+	parseJSON = withText "module-tag" $ \txt -> msum [
+		guard (txt == "types") >> return InferredTypesTag,
+		guard (txt == "docs") >> return RefinedDocsTag,
+		guard (txt == "header") >> return OnlyHeaderTag,
+		guard (txt == "dirty") >> return DirtyTag,
+		guard (txt == "resolved") >> return ResolvedNamesTag]
+
+-- | Inspected module
+type InspectedModule = Inspected ModuleLocation ModuleTag Module
+
+instance Show InspectedModule where
+	show (Inspected i mi ts m) = unlines [either showError show m, "\tinspected: " ++ show i, "\ttags: " ++ intercalate ", " (map show $ S.toList ts)] where
+		showError :: HsDevError -> String
+		showError e = unlines $ ("\terror: " ++ show e) : case mi of
+			FileModule f p -> ["file: " ++ f ^. path, "project: " ++ maybe "" (view (projectPath . path)) p]
+			InstalledModule c p n _  -> ["cabal: " ++ show c, "package: " ++ show p, "name: " ++ T.unpack n]
+			OtherLocation src -> ["other location: " ++ T.unpack src]
+			NoLocation -> ["no location"]
+
+notInspected :: ModuleLocation -> InspectedModule
+notInspected mloc = Inspected mempty mloc noTags (Left $ NotInspected mloc)
+
+instance Documented ModuleId where
+	brief m = brief $ _moduleLocation m
+	detailed = brief
+
+instance Documented SymbolId where
+	brief s = "{} from {}" ~~ _symbolName s ~~ brief (_symbolModule s)
+	detailed = brief
+
+instance Documented Module where
+	brief = brief . _moduleId
+	detailed m = T.unlines (brief m : info) where
+		info = [
+			"\texports: {}" ~~ T.intercalate ", " (map brief (_moduleExports m))]
+
+instance Documented Symbol where
+	brief = brief . _symbolId
+	detailed s = T.unlines [brief s, info] where
+		info = case _symbolInfo s of
+			Function t -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "function", fmap ("type: {}" ~~) t])
+			Method t p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "method", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p])
+			Selector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "selector", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p])
+			Constructor args p -> "\t" `T.append` T.intercalate ", " ["constructor", "args: {}" ~~ T.unwords args, "parent: {}" ~~ p]
+			Type args ctx -> "\t" `T.append` T.intercalate ", " ["type", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]
+			NewType args ctx -> "\t" `T.append` T.intercalate ", " ["newtype", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]
+			Data args ctx -> "\t" `T.append` T.intercalate ", " ["data", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]
+			Class args ctx -> "\t" `T.append` T.intercalate ", " ["class", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]
+			TypeFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["type family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]
+			DataFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["data family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx]
+			PatConstructor args p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern constructor", Just $ "args: {}" ~~ T.unwords args, fmap ("pat-type: {}" ~~) p])
+			PatSelector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern selector", fmap ("type: {}" ~~) t, fmap ("pat-type: {}" ~~) p])
+
+makeLenses ''Import
+makeLenses ''Module
+makeLenses ''Symbol
+makeLenses ''SymbolInfo
+makeLenses ''Scoped
+makeLenses ''SymbolUsage
+makeLenses ''ImportedSymbol
+makeLenses ''Inspection
+makeLenses ''Inspected
+
+inspected :: Traversal (Inspected k t a) (Inspected k t b) a b
+inspected = inspectionResult . _Right
+
+nullifyInfo :: SymbolInfo -> SymbolInfo
+nullifyInfo = chain [
+	set functionType mempty,
+	set parentClass mempty,
+	set parentType mempty,
+	set selectorConstructors mempty,
+	set typeArgs mempty,
+	set typeContext mempty,
+	set familyAssociate mempty,
+	set patternType mempty,
+	set patternConstructor mempty]
+
+instance Sourced Module where
+	sourcedName = moduleId . moduleName
+	sourcedDocs = moduleDocs . _Just
+	sourcedModule = moduleId
+
+instance Sourced Symbol where
+	sourcedName = symbolId . symbolName
+	sourcedDocs = symbolDocs . _Just
+	sourcedModule = symbolId . symbolModule
+	sourcedLocation = symbolPosition . _Just
src/HsDev/Tools/AutoFix.hs view
@@ -1,67 +1,67 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Tools.AutoFix (-	corrections,-	CorrectorMatch,-	correctors,-	match,-	findCorrector,--	module Data.Text.Region,-	module HsDev.Tools.Refact,-	module HsDev.Tools.Types-	) where--import Control.Applicative-import Control.Lens hiding ((.=), at)-import Data.Maybe (listToMaybe, mapMaybe)-import Data.String (fromString)-import Data.Text (Text)-import Data.Text.Lens (unpacked)-import Data.Text.Region hiding (Region(..), update)-import qualified Data.Text.Region as R--import HsDev.Tools.Refact-import HsDev.Tools.Base-import HsDev.Tools.Types--instance Regioned a => Regioned (Note a) where-	regions = note . regions--corrections :: [Note OutputMessage] -> [Note Refact]-corrections = mapMaybe toRefact where-	toRefact :: Note OutputMessage -> Maybe (Note Refact)-	toRefact n = useSuggestion <|> findCorrector n where-		-- Use existing suggestion-		useSuggestion :: Maybe (Note Refact)-		useSuggestion = do-			sugg <- view (note . messageSuggestion) n-			return $ set-				note-				(Refact-					(view (note . message) n)-					(replace (fromRegion $ view noteRegion n) sugg))-				n--type CorrectorMatch = Note OutputMessage -> Maybe (Note Refact)--correctors :: [CorrectorMatch]-correctors = [-	match "^The (?:qualified )?import of .([\\w\\.]+). is redundant" $ \_ rgn -> Refact -- There are different quotes in Windows/Linux-		"Redundant import"-		(cut-			(expandLines rgn)),-	match "^(.*?)\nFound:\n  (.*?)\nWhy not:\n  (.*?)$" $ \g rgn -> Refact-		(g `at` 1)-		(replace-			((rgn ^. regionFrom) `regionSize` pt 0 (contentsLength $ g `at` 2))-			(g `at` 3))]--match :: String -> ((Int -> Maybe Text) -> R.Region -> Refact) -> CorrectorMatch-match pat f n = do-	g <- matchRx pat (view (note . message . unpacked) n)-	return $ set note (f (fmap fromString . g) (fromRegion $ view noteRegion n)) n--findCorrector :: Note OutputMessage -> Maybe (Note Refact)-findCorrector n = listToMaybe $ mapMaybe ($ n) correctors+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.AutoFix (
+	corrections,
+	CorrectorMatch,
+	correctors,
+	match,
+	findCorrector,
+
+	module Data.Text.Region,
+	module HsDev.Tools.Refact,
+	module HsDev.Tools.Types
+	) where
+
+import Control.Applicative
+import Control.Lens hiding ((.=), at)
+import Data.Maybe (listToMaybe, mapMaybe)
+import Data.String (fromString)
+import Data.Text (Text)
+import Data.Text.Lens (unpacked)
+import Data.Text.Region hiding (Region(..), update)
+import qualified Data.Text.Region as R
+
+import HsDev.Tools.Refact
+import HsDev.Tools.Base
+import HsDev.Tools.Types
+
+instance Regioned a => Regioned (Note a) where
+	regions = note . regions
+
+corrections :: [Note OutputMessage] -> [Note Refact]
+corrections = mapMaybe toRefact where
+	toRefact :: Note OutputMessage -> Maybe (Note Refact)
+	toRefact n = useSuggestion <|> findCorrector n where
+		-- Use existing suggestion
+		useSuggestion :: Maybe (Note Refact)
+		useSuggestion = do
+			sugg <- view (note . messageSuggestion) n
+			return $ set
+				note
+				(Refact
+					(view (note . message) n)
+					(replace (fromRegion $ view noteRegion n) sugg))
+				n
+
+type CorrectorMatch = Note OutputMessage -> Maybe (Note Refact)
+
+correctors :: [CorrectorMatch]
+correctors = [
+	match "^The (?:qualified )?import of .([\\w\\.]+). is redundant" $ \_ rgn -> Refact -- There are different quotes in Windows/Linux
+		"Redundant import"
+		(cut
+			(expandLines rgn)),
+	match "^(.*?)\nFound:\n  (.*?)\nWhy not:\n  (.*?)$" $ \g rgn -> Refact
+		(g `at` 1)
+		(replace
+			((rgn ^. regionFrom) `regionSize` pt 0 (contentsLength $ g `at` 2))
+			(g `at` 3))]
+
+match :: String -> ((Int -> Maybe Text) -> R.Region -> Refact) -> CorrectorMatch
+match pat f n = do
+	g <- matchRx pat (view (note . message . unpacked) n)
+	return $ set note (f (fmap fromString . g) (fromRegion $ view noteRegion n)) n
+
+findCorrector :: Note OutputMessage -> Maybe (Note Refact)
+findCorrector n = listToMaybe $ mapMaybe ($ n) correctors
src/HsDev/Tools/Base.hs view
@@ -1,87 +1,87 @@-module HsDev.Tools.Base (-	runTool, runTool_,-	Result, ToolM,-	runWait, runWait_,-	tool, tool_,-	matchRx, splitRx, replaceRx,-	at, at_,--	module HsDev.Tools.Types-	) where--import Control.Monad.Except-import Data.Array (assocs)-import Data.List (unfoldr, intercalate)-import Data.Maybe (fromMaybe)-import Data.String-import System.Exit-import System.Process-import Text.Regex.PCRE ((=~), MatchResult(..))--import HsDev.Error-import HsDev.Tools.Types-import HsDev.Util (liftIOErrors)---- | Run tool, throwing HsDevError on fail-runTool :: FilePath -> [String] -> String -> IO String-runTool name args input = hsdevLiftIOWith onIOError $ do-	(code, out, err) <- readProcessWithExitCode name args input-	case code of-		ExitFailure ecode -> hsdevError $ ToolError name $-			"exited with code " ++ show ecode ++ ": " ++ err-		ExitSuccess -> return out-	where-		onIOError s = ToolError name $ unlines [-			"args: [" ++ intercalate ", " args ++ "]",-			"stdin: " ++ input,-			"error: " ++ s]---- | Run tool with not stdin-runTool_ :: FilePath -> [String] -> IO String-runTool_ name args = runTool name args ""--type Result = Either String String-type ToolM a = ExceptT String IO a---- | Run command and wait for result-runWait :: FilePath -> [String] -> String -> IO Result-runWait name args input = do-	(code, out, err) <- readProcessWithExitCode name args input-	return $ if code == ExitSuccess && not (null out) then Right out else Left err---- | Run command with no input-runWait_ :: FilePath -> [String] -> IO Result-runWait_ name args = runWait name args ""---- | Tool-tool :: FilePath -> [String] -> String -> ToolM String-tool name args input = liftIOErrors $ ExceptT $ runWait name args input---- | Tool with no input-tool_ :: FilePath -> [String] -> ToolM String-tool_ name args = tool name args ""--matchRx :: String -> String -> Maybe (Int -> Maybe String)-matchRx pat str = if matched then Just look else Nothing where-	m :: MatchResult String-	m = str =~ pat-	matched = not $ null $ mrMatch m-	groups = filter (not . null . snd) $ assocs $ mrSubs m-	look i = lookup i groups--splitRx :: String -> String -> [String]-splitRx pat = unfoldr split' . Just where-	split' :: Maybe String -> Maybe (String, Maybe String)-	split' Nothing = Nothing-	split' (Just str) = case str =~ pat of-		(pre, "", "") -> Just (pre, Nothing)-		(pre, _, post) -> Just (pre, Just post)--replaceRx :: String -> String -> String -> String-replaceRx pat w = intercalate w . splitRx pat--at :: (Int -> Maybe a) -> Int -> a-at g i = fromMaybe (error $ "Can't find group " ++ show i) $ g i--at_ :: IsString s => (Int -> Maybe s) -> Int -> s-at_ g = fromMaybe (fromString "") . g+module HsDev.Tools.Base (
+	runTool, runTool_,
+	Result, ToolM,
+	runWait, runWait_,
+	tool, tool_,
+	matchRx, splitRx, replaceRx,
+	at, at_,
+
+	module HsDev.Tools.Types
+	) where
+
+import Control.Monad.Except
+import Data.Array (assocs)
+import Data.List (unfoldr, intercalate)
+import Data.Maybe (fromMaybe)
+import Data.String
+import System.Exit
+import System.Process
+import Text.Regex.PCRE ((=~), MatchResult(..))
+
+import HsDev.Error
+import HsDev.Tools.Types
+import HsDev.Util (liftIOErrors)
+
+-- | Run tool, throwing HsDevError on fail
+runTool :: FilePath -> [String] -> String -> IO String
+runTool name args input = hsdevLiftIOWith onIOError $ do
+	(code, out, err) <- readProcessWithExitCode name args input
+	case code of
+		ExitFailure ecode -> hsdevError $ ToolError name $
+			"exited with code " ++ show ecode ++ ": " ++ err
+		ExitSuccess -> return out
+	where
+		onIOError s = ToolError name $ unlines [
+			"args: [" ++ intercalate ", " args ++ "]",
+			"stdin: " ++ input,
+			"error: " ++ s]
+
+-- | Run tool with not stdin
+runTool_ :: FilePath -> [String] -> IO String
+runTool_ name args = runTool name args ""
+
+type Result = Either String String
+type ToolM a = ExceptT String IO a
+
+-- | Run command and wait for result
+runWait :: FilePath -> [String] -> String -> IO Result
+runWait name args input = do
+	(code, out, err) <- readProcessWithExitCode name args input
+	return $ if code == ExitSuccess && not (null out) then Right out else Left err
+
+-- | Run command with no input
+runWait_ :: FilePath -> [String] -> IO Result
+runWait_ name args = runWait name args ""
+
+-- | Tool
+tool :: FilePath -> [String] -> String -> ToolM String
+tool name args input = liftIOErrors $ ExceptT $ runWait name args input
+
+-- | Tool with no input
+tool_ :: FilePath -> [String] -> ToolM String
+tool_ name args = tool name args ""
+
+matchRx :: String -> String -> Maybe (Int -> Maybe String)
+matchRx pat str = if matched then Just look else Nothing where
+	m :: MatchResult String
+	m = str =~ pat
+	matched = not $ null $ mrMatch m
+	groups = filter (not . null . snd) $ assocs $ mrSubs m
+	look i = lookup i groups
+
+splitRx :: String -> String -> [String]
+splitRx pat = unfoldr split' . Just where
+	split' :: Maybe String -> Maybe (String, Maybe String)
+	split' Nothing = Nothing
+	split' (Just str) = case str =~ pat of
+		(pre, "", "") -> Just (pre, Nothing)
+		(pre, _, post) -> Just (pre, Just post)
+
+replaceRx :: String -> String -> String -> String
+replaceRx pat w = intercalate w . splitRx pat
+
+at :: (Int -> Maybe a) -> Int -> a
+at g i = fromMaybe (error $ "Can't find group " ++ show i) $ g i
+
+at_ :: IsString s => (Int -> Maybe s) -> Int -> s
+at_ g = fromMaybe (fromString "") . g
src/HsDev/Tools/Cabal.hs view
@@ -1,85 +1,85 @@-{-# LANGUAGE OverloadedStrings, CPP #-}--module HsDev.Tools.Cabal (-	CabalPackage(..),-	cabalList,--	-- * Reexports-	Version, License(..)-	) where--import Control.Arrow-import Control.Monad-import Data.Aeson-import Data.Char (isSpace)-import Data.Maybe-import Distribution.License-import Distribution.Text-import Distribution.Version--import HsDev.Tools.Base-import HsDev.Util--data CabalPackage = CabalPackage {-	cabalPackageName :: String,-	cabalPackageSynopsis :: Maybe String,-	cabalPackageDefaultVersion :: Maybe Version,-	cabalPackageInstalledVersions :: [Version],-	cabalPackageHomepage :: Maybe String,-	cabalPackageLicense :: Maybe License }-		deriving (Eq, Read, Show)--instance ToJSON CabalPackage where-	toJSON cp = object [-		"name" .= cabalPackageName cp,-		"synopsis" .= cabalPackageSynopsis cp,-		"default-version" .= fmap display (cabalPackageDefaultVersion cp),-		"installed-versions" .= map display (cabalPackageInstalledVersions cp),-		"homepage" .= cabalPackageHomepage cp,-		"license" .= fmap display (cabalPackageLicense cp)]--instance FromJSON CabalPackage where-	parseJSON = withObject "cabal-package" $ \v -> CabalPackage <$>-		(v .:: "name") <*>-		(v .:: "synopsis") <*>-		((join . fmap simpleParse) <$> (v .:: "default-version")) <*>-		(mapMaybe simpleParse <$> (v .:: "installed-versions")) <*>-		(v .:: "homepage") <*>-		((join . fmap simpleParse) <$> (v .:: "license"))--cabalList :: [String] -> ToolM [CabalPackage]-cabalList queries = do-#if mingw32_HOST_OS-	rs <- liftM (split (all isSpace) . lines) $ tool_ "powershell" [-		"-Command",-		unwords (["&", "{", "chcp 65001 | out-null;", "cabal list"] ++ queries ++ ["}"])]-#else-	rs <- liftM (split (all isSpace) . lines) $ tool_ "cabal" ("list" : queries)-#endif-	return $ map toPackage $ mapMaybe parseFields rs-	where-		toPackage :: (String, [(String, String)]) -> CabalPackage-		toPackage (name, fs) = CabalPackage {-			cabalPackageName = name,-			cabalPackageSynopsis = lookup "Synopsis" fs,-			cabalPackageDefaultVersion = (lookup "Default available version" fs >>= simpleParse),-			cabalPackageInstalledVersions = fromMaybe [] (lookup "Installed versions" fs >>= mapM (simpleParse . trim) . split (== ',')),-			cabalPackageHomepage = lookup "Homepage" fs,-			cabalPackageLicense = lookup "License" fs >>= simpleParse }--		parseFields :: [String] -> Maybe (String, [(String, String)])-		parseFields [] = Nothing-		parseFields (('*':name):fs) = Just (trim name, mapMaybe parseField' fs) where-			parseField' :: String -> Maybe (String, String)-			parseField' str = case parseField str of-				(fname, Just fval) -> Just (fname, fval)-				_ -> Nothing-		parseFields _ = Nothing--		-- foo: bar → (foo, bar)-		parseField :: String -> (String, Maybe String)-		parseField = (trim *** (parseValue . trim . drop 1)) . break (== ':')-		-- [ ... ] → Nothing, ... → Just ...-		parseValue :: String -> Maybe String-		parseValue ('[':_) = Nothing-		parseValue v = Just v+{-# LANGUAGE OverloadedStrings, CPP #-}
+
+module HsDev.Tools.Cabal (
+	CabalPackage(..),
+	cabalList,
+
+	-- * Reexports
+	Version, License(..)
+	) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Aeson
+import Data.Char (isSpace)
+import Data.Maybe
+import Distribution.License
+import Distribution.Text
+import Distribution.Version
+
+import HsDev.Tools.Base
+import HsDev.Util
+
+data CabalPackage = CabalPackage {
+	cabalPackageName :: String,
+	cabalPackageSynopsis :: Maybe String,
+	cabalPackageDefaultVersion :: Maybe Version,
+	cabalPackageInstalledVersions :: [Version],
+	cabalPackageHomepage :: Maybe String,
+	cabalPackageLicense :: Maybe License }
+		deriving (Eq, Read, Show)
+
+instance ToJSON CabalPackage where
+	toJSON cp = object [
+		"name" .= cabalPackageName cp,
+		"synopsis" .= cabalPackageSynopsis cp,
+		"default-version" .= fmap display (cabalPackageDefaultVersion cp),
+		"installed-versions" .= map display (cabalPackageInstalledVersions cp),
+		"homepage" .= cabalPackageHomepage cp,
+		"license" .= fmap display (cabalPackageLicense cp)]
+
+instance FromJSON CabalPackage where
+	parseJSON = withObject "cabal-package" $ \v -> CabalPackage <$>
+		(v .:: "name") <*>
+		(v .:: "synopsis") <*>
+		((join . fmap simpleParse) <$> (v .:: "default-version")) <*>
+		(mapMaybe simpleParse <$> (v .:: "installed-versions")) <*>
+		(v .:: "homepage") <*>
+		((join . fmap simpleParse) <$> (v .:: "license"))
+
+cabalList :: [String] -> ToolM [CabalPackage]
+cabalList queries = do
+#if mingw32_HOST_OS
+	rs <- liftM (split (all isSpace) . lines) $ tool_ "powershell" [
+		"-Command",
+		unwords (["&", "{", "chcp 65001 | out-null;", "cabal list"] ++ queries ++ ["}"])]
+#else
+	rs <- liftM (split (all isSpace) . lines) $ tool_ "cabal" ("list" : queries)
+#endif
+	return $ map toPackage $ mapMaybe parseFields rs
+	where
+		toPackage :: (String, [(String, String)]) -> CabalPackage
+		toPackage (name, fs) = CabalPackage {
+			cabalPackageName = name,
+			cabalPackageSynopsis = lookup "Synopsis" fs,
+			cabalPackageDefaultVersion = (lookup "Default available version" fs >>= simpleParse),
+			cabalPackageInstalledVersions = fromMaybe [] (lookup "Installed versions" fs >>= mapM (simpleParse . trim) . split (== ',')),
+			cabalPackageHomepage = lookup "Homepage" fs,
+			cabalPackageLicense = lookup "License" fs >>= simpleParse }
+
+		parseFields :: [String] -> Maybe (String, [(String, String)])
+		parseFields [] = Nothing
+		parseFields (('*':name):fs) = Just (trim name, mapMaybe parseField' fs) where
+			parseField' :: String -> Maybe (String, String)
+			parseField' str = case parseField str of
+				(fname, Just fval) -> Just (fname, fval)
+				_ -> Nothing
+		parseFields _ = Nothing
+
+		-- foo: bar → (foo, bar)
+		parseField :: String -> (String, Maybe String)
+		parseField = (trim *** (parseValue . trim . drop 1)) . break (== ':')
+		-- [ ... ] → Nothing, ... → Just ...
+		parseValue :: String -> Maybe String
+		parseValue ('[':_) = Nothing
+		parseValue v = Just v
src/HsDev/Tools/ClearImports.hs view
@@ -1,113 +1,113 @@-module HsDev.Tools.ClearImports (-	dumpMinimalImports, waitImports, cleanTmpImports,-	findMinimalImports,-	groupImports, splitImport,-	clearImports,--	module Control.Monad.Except-	) where--import Control.Arrow-import Control.Concurrent (threadDelay)-import Control.Exception-import Control.Monad.Except-import Data.Char-import Data.List-import Data.Maybe (mapMaybe)-import Data.Text (unpack)-import System.Directory-import System.FilePath-import qualified Language.Haskell.Exts as Exts--import GHC-import GHC.Paths (libdir)--import HsDev.Util-import HsDev.Tools.Ghc.Compat---- | Dump minimal imports-dumpMinimalImports :: [String] -> FilePath -> ExceptT String IO String-dumpMinimalImports opts f = do-	cur <- liftE getCurrentDirectory-	file <- liftE $ canonicalizePath f-	cts <- liftE $ fmap unpack $ readFileUtf8 file--	mname <- case Exts.parseFileContentsWithMode (pmode file) cts of-		Exts.ParseFailed loc err -> throwError $-			"Failed to parse file at " ++-			Exts.prettyPrint loc ++ ":" ++ err-		Exts.ParseOk (Exts.Module _ (Just (Exts.ModuleHead _ (Exts.ModuleName _ mname) _ _)) _ _ _) -> return mname-		_ -> throwError "Error"--	void $ liftE $ runGhc (Just libdir) $ do-		df <- getSessionDynFlags-		let-			df' = df {-				ghcLink = NoLink,-				hscTarget = HscNothing,-				dumpDir = Just cur,-				stubDir = Just cur,-				objectDir = Just cur,-				hiDir = Just cur }-		(df'', _, _) <- parseDynamicFlags df' (map noLoc ("-ddump-minimal-imports" : opts))-		_ <- setSessionDynFlags df''-		cleanupHandler df'' $ do-			t <- guessTarget file Nothing-			setTargets [t]-			load LoadAllTargets--	length mname `seq` return mname-	where-		pmode :: FilePath -> Exts.ParseMode-		pmode f' = Exts.defaultParseMode {-			Exts.parseFilename = f',-			Exts.baseLanguage = Exts.Haskell2010,-			Exts.extensions = Exts.glasgowExts ++ map Exts.parseExtension exts,-			Exts.fixities = Just Exts.baseFixities }-		exts = mapMaybe (stripPrefix "-X") opts---- | Read imports from file-waitImports :: FilePath -> IO [String]-waitImports f = retry 1000 $ do-	is <- liftM lines $ readFile f-	length is `seq` return is---- | Clean temporary files-cleanTmpImports :: FilePath -> IO ()-cleanTmpImports dir = do-	dumps <- liftM (filter ((== ".imports") . takeExtension)) $ directoryContents dir-	forM_ dumps $ handle ignoreIO' . retry 1000 . removeFile-	where-		ignoreIO' :: IOException -> IO ()-		ignoreIO' _ = return ()---- | Dump and read imports-findMinimalImports :: [String] -> FilePath -> ExceptT String IO [String]-findMinimalImports opts f = do-	file <- liftE $ canonicalizePath f-	mname <- dumpMinimalImports opts file-	is <- liftE $ waitImports (mname <.> "imports")-	tmp <- liftE getCurrentDirectory-	liftE $ cleanTmpImports tmp-	return is---- | Groups several lines related to one import by indents-groupImports :: [String] -> [[String]]-groupImports = unfoldr getPack where-	getPack [] = Nothing-	getPack (s:ss) = Just $ first (s:) $ break (null . takeWhile isSpace) ss---- | Split import to import and import-list-splitImport :: [String] -> (String, String)-splitImport = splitBraces . unwords . map trim where-	cut = twice $ reverse . drop 1-	twice f = f . f-	splitBraces = (trim *** (trim . cut)) . break (== '(')---- | Returns minimal imports for file specified-clearImports :: [String] -> FilePath -> ExceptT String IO [(String, String)]-clearImports opts = liftM (map splitImport . groupImports) . findMinimalImports opts---- | Retry action on fail-retry :: (MonadPlus m, MonadIO m) => Int -> m a -> m a-retry dt act = msum $ act : repeat ((liftIO (threadDelay dt) >>) act)+module HsDev.Tools.ClearImports (
+	dumpMinimalImports, waitImports, cleanTmpImports,
+	findMinimalImports,
+	groupImports, splitImport,
+	clearImports,
+
+	module Control.Monad.Except
+	) where
+
+import Control.Arrow
+import Control.Concurrent (threadDelay)
+import Control.Exception
+import Control.Monad.Except
+import Data.Char
+import Data.List
+import Data.Maybe (mapMaybe)
+import Data.Text (unpack)
+import System.Directory
+import System.FilePath
+import qualified Language.Haskell.Exts as Exts
+
+import GHC
+import GHC.Paths (libdir)
+
+import HsDev.Util
+import HsDev.Tools.Ghc.Compat
+
+-- | Dump minimal imports
+dumpMinimalImports :: [String] -> FilePath -> ExceptT String IO String
+dumpMinimalImports opts f = do
+	cur <- liftE getCurrentDirectory
+	file <- liftE $ canonicalizePath f
+	cts <- liftE $ fmap unpack $ readFileUtf8 file
+
+	mname <- case Exts.parseFileContentsWithMode (pmode file) cts of
+		Exts.ParseFailed loc err -> throwError $
+			"Failed to parse file at " ++
+			Exts.prettyPrint loc ++ ":" ++ err
+		Exts.ParseOk (Exts.Module _ (Just (Exts.ModuleHead _ (Exts.ModuleName _ mname) _ _)) _ _ _) -> return mname
+		_ -> throwError "Error"
+
+	void $ liftE $ runGhc (Just libdir) $ do
+		df <- getSessionDynFlags
+		let
+			df' = df {
+				ghcLink = NoLink,
+				hscTarget = HscNothing,
+				dumpDir = Just cur,
+				stubDir = Just cur,
+				objectDir = Just cur,
+				hiDir = Just cur }
+		(df'', _, _) <- parseDynamicFlags df' (map noLoc ("-ddump-minimal-imports" : opts))
+		_ <- setSessionDynFlags df''
+		cleanupHandler df'' $ do
+			t <- guessTarget file Nothing
+			setTargets [t]
+			load LoadAllTargets
+
+	length mname `seq` return mname
+	where
+		pmode :: FilePath -> Exts.ParseMode
+		pmode f' = Exts.defaultParseMode {
+			Exts.parseFilename = f',
+			Exts.baseLanguage = Exts.Haskell2010,
+			Exts.extensions = Exts.glasgowExts ++ map Exts.parseExtension exts,
+			Exts.fixities = Just Exts.baseFixities }
+		exts = mapMaybe (stripPrefix "-X") opts
+
+-- | Read imports from file
+waitImports :: FilePath -> IO [String]
+waitImports f = retry 1000 $ do
+	is <- liftM lines $ readFile f
+	length is `seq` return is
+
+-- | Clean temporary files
+cleanTmpImports :: FilePath -> IO ()
+cleanTmpImports dir = do
+	dumps <- liftM (filter ((== ".imports") . takeExtension)) $ directoryContents dir
+	forM_ dumps $ handle ignoreIO' . retry 1000 . removeFile
+	where
+		ignoreIO' :: IOException -> IO ()
+		ignoreIO' _ = return ()
+
+-- | Dump and read imports
+findMinimalImports :: [String] -> FilePath -> ExceptT String IO [String]
+findMinimalImports opts f = do
+	file <- liftE $ canonicalizePath f
+	mname <- dumpMinimalImports opts file
+	is <- liftE $ waitImports (mname <.> "imports")
+	tmp <- liftE getCurrentDirectory
+	liftE $ cleanTmpImports tmp
+	return is
+
+-- | Groups several lines related to one import by indents
+groupImports :: [String] -> [[String]]
+groupImports = unfoldr getPack where
+	getPack [] = Nothing
+	getPack (s:ss) = Just $ first (s:) $ break (null . takeWhile isSpace) ss
+
+-- | Split import to import and import-list
+splitImport :: [String] -> (String, String)
+splitImport = splitBraces . unwords . map trim where
+	cut = twice $ reverse . drop 1
+	twice f = f . f
+	splitBraces = (trim *** (trim . cut)) . break (== '(')
+
+-- | Returns minimal imports for file specified
+clearImports :: [String] -> FilePath -> ExceptT String IO [(String, String)]
+clearImports opts = liftM (map splitImport . groupImports) . findMinimalImports opts
+
+-- | Retry action on fail
+retry :: (MonadPlus m, MonadIO m) => Int -> m a -> m a
+retry dt act = msum $ act : repeat ((liftIO (threadDelay dt) >>) act)
src/HsDev/Tools/Ghc/Base.hs view
@@ -1,196 +1,196 @@-{-# LANGUAGE PatternGuards #-}--module HsDev.Tools.Ghc.Base (-	-- * Running Ghc-	ghcRun, ghcRunWith,-	-- * Commonly used DynFlags-	interpretedFlags, noLinkFlags,-	-- * Setting DynFlags-	withFlags, modifyFlags,-	-- * Loading targets-	clearTargets, makeTarget, loadTargets,-	loadInteractive, reload,-	-- * Logging messages-	collectMessages, collectMessages_,--	-- * Util-	formatType,-	spanRegion,-	withCurrentDirectory,-	logToChan, logToNull-	) where--import Control.Lens (view, over)-import Control.Monad-import Control.Monad.Except-import Data.Time.Clock (getCurrentTime)-import Data.String (fromString)-import Data.Text (Text)-import qualified Data.Text as T-import System.Directory (getCurrentDirectory, setCurrentDirectory)-import System.FilePath--import Exception (ExceptionMonad(..))-import GHC hiding (Warning, Module)-import Outputable-import FastString (unpackFS)-import StringBuffer-import Type-import qualified Pretty--import Control.Concurrent.FiniteChan-import System.Directory.Paths-import HsDev.Symbols.Location (Position(..), Region(..), region, ModuleLocation(..))-import HsDev.Tools.Types-import HsDev.Tools.Ghc.Compat-import qualified HsDev.Tools.Ghc.Compat as C (setLogAction, addLogAction, unqualStyle)---- | Run ghc-ghcRun :: GhcMonad m => [String] -> m a -> m a-ghcRun = ghcRunWith interpretedFlags---- | Run ghc-ghcRunWith :: GhcMonad m => (DynFlags -> DynFlags) -> [String] -> m a -> m a-ghcRunWith onFlags opts act = do-	fs <- getSessionDynFlags-	cleanupHandler fs $ do-		(fs', _, _) <- parseDynamicFlags fs (map noLoc opts)-		void $ setSessionDynFlags $ onFlags fs'-		modifyFlags $ C.setLogAction logToNull-		act--interpretedFlags :: DynFlags -> DynFlags-interpretedFlags fs = fs {-	ghcMode = CompManager,-	ghcLink = LinkInMemory,-	hscTarget = HscInterpreted }--noLinkFlags :: DynFlags -> DynFlags-noLinkFlags fs = fs {-	ghcMode = CompManager,-	ghcLink = NoLink,-	hscTarget = HscNothing }---- | Alter @DynFlags@ temporary-withFlags :: GhcMonad m => m a -> m a-withFlags = gbracket getSessionDynFlags (void . setSessionDynFlags) . const---- | Update @DynFlags@-modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()-modifyFlags f = do-	fs <- getSessionDynFlags-	let-		fs' = f fs-	_ <- setSessionDynFlags fs'-	-- _ <- liftIO $ initPackages fs'-	return ()---- | Clear loaded targets-clearTargets :: GhcMonad m => m ()-clearTargets = loadTargets []---- | Make target with its source code optional-makeTarget :: GhcMonad m => Text -> Maybe Text -> m Target-makeTarget name Nothing = guessTarget (T.unpack name) Nothing-makeTarget name (Just cts) = do-	t <- guessTarget (T.unpack name) Nothing-	tm <- liftIO getCurrentTime-	return t { targetContents = Just (stringToStringBuffer $ T.unpack cts, tm) }---- | Load all targets-loadTargets :: GhcMonad m => [Target] -> m ()-loadTargets ts = setTargets ts >> load LoadAllTargets >> return ()---- | Load and set interactive context-loadInteractive :: GhcMonad m => Path -> Maybe Text -> m ()-loadInteractive fpath mcts = do-	fpath' <- liftIO $ canonicalize fpath-	withCurrentDirectory (view path $ takeDir fpath') $ do-		t <- makeTarget (over path takeFileName fpath') mcts-		loadTargets [t]-		g <- getModuleGraph-		setContext [IIModule (ms_mod_name m) | m <- g]---- | Reload targets-reload :: GhcMonad m => m ()-reload = do-	ts <- getTargets-	ctx <- getContext-	setContext []-	clearTargets-	setTargets ts-	setContext ctx---- | Collect messages from ghc for underlying computation-collectMessages :: GhcMonad m => m a -> m (a, [Note OutputMessage])-collectMessages act = do-	ch <- liftIO newChan-	r <- gbracket (liftM log_action getSessionDynFlags) (\action' -> modifyFlags (\fs -> fs { log_action = action' })) $ \_ -> do-		modifyFlags (C.addLogAction $ logToChan ch)-		act-	notes <- liftIO $ stopChan ch-	return (r, notes)---- | Same as @collectMessages@, but when no result except notes needed-collectMessages_ :: GhcMonad m => m () -> m [Note OutputMessage]-collectMessages_ = fmap snd . collectMessages---- | Format type for output-formatType :: GHC.DynFlags -> GHC.Type -> String-formatType dflag t = showOutputable dflag (removeForAlls t)---- | Get region of @SrcSpan@-spanRegion :: SrcSpan -> Region-spanRegion (RealSrcSpan s) = Position (srcSpanStartLine s) (srcSpanStartCol s) `region` Position (srcSpanEndLine s) (srcSpanEndCol s)-spanRegion _ = Position 0 0 `region` Position 0 0---- | Set current directory and restore it after action-withCurrentDirectory :: GhcMonad m => FilePath -> m a -> m a-withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $-	const (liftIO (setCurrentDirectory dir) >> act)---- | Log  ghc warnings and errors as to chan--- You may have to apply recalcTabs on result notes-logToChan :: Chan (Note OutputMessage) -> LogAction-logToChan ch fs sev src msg-	| Just sev' <- checkSev sev = do-		src' <- canonicalize srcMod-		void $ sendChan ch Note {-			_noteSource = src',-			_noteRegion = spanRegion src,-			_noteLevel = Just sev',-			_note = OutputMessage {-				_message = fromString $ showSDoc fs msg,-				_messageSuggestion = Nothing } }-	| otherwise = return ()-	where-		checkSev SevWarning = Just Warning-		checkSev SevError = Just Error-		checkSev SevFatal = Just Error-		checkSev _ = Nothing-		srcMod = case src of-			RealSrcSpan s' -> FileModule (fromFilePath $ unpackFS $ srcSpanFile s') Nothing-			_ -> NoLocation---- | Don't log ghc warnings and errors-logToNull :: LogAction-logToNull _ _ _ _ = return ()---- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@--removeForAlls :: Type -> Type-removeForAlls ty = removeForAlls' ty' tty' where-	ty'  = dropForAlls ty-	tty' = splitFunTy_maybe ty'--removeForAlls' :: Type -> Maybe (Type, Type) -> Type-removeForAlls' ty Nothing = ty-removeForAlls' ty (Just (pre, ftype))-	| isPredTy pre = mkFunTy pre (dropForAlls ftype)-	| otherwise = ty--showOutputable :: Outputable a => DynFlags -> a -> String-showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr--showUnqualifiedPage :: DynFlags -> SDoc -> String-showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . withPprStyleDoc dflag (C.unqualStyle dflag)+{-# LANGUAGE PatternGuards #-}
+
+module HsDev.Tools.Ghc.Base (
+	-- * Running Ghc
+	ghcRun, ghcRunWith,
+	-- * Commonly used DynFlags
+	interpretedFlags, noLinkFlags,
+	-- * Setting DynFlags
+	withFlags, modifyFlags,
+	-- * Loading targets
+	clearTargets, makeTarget, loadTargets,
+	loadInteractive, reload,
+	-- * Logging messages
+	collectMessages, collectMessages_,
+
+	-- * Util
+	formatType,
+	spanRegion,
+	withCurrentDirectory,
+	logToChan, logToNull
+	) where
+
+import Control.Lens (view, over)
+import Control.Monad
+import Control.Monad.Except
+import Data.Time.Clock (getCurrentTime)
+import Data.String (fromString)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory (getCurrentDirectory, setCurrentDirectory)
+import System.FilePath
+
+import Exception (ExceptionMonad(..))
+import GHC hiding (Warning, Module)
+import Outputable
+import FastString (unpackFS)
+import StringBuffer
+import Type
+import qualified Pretty
+
+import Control.Concurrent.FiniteChan
+import System.Directory.Paths
+import HsDev.Symbols.Location (Position(..), Region(..), region, ModuleLocation(..))
+import HsDev.Tools.Types
+import HsDev.Tools.Ghc.Compat
+import qualified HsDev.Tools.Ghc.Compat as C (setLogAction, addLogAction, unqualStyle)
+
+-- | Run ghc
+ghcRun :: GhcMonad m => [String] -> m a -> m a
+ghcRun = ghcRunWith interpretedFlags
+
+-- | Run ghc
+ghcRunWith :: GhcMonad m => (DynFlags -> DynFlags) -> [String] -> m a -> m a
+ghcRunWith onFlags opts act = do
+	fs <- getSessionDynFlags
+	cleanupHandler fs $ do
+		(fs', _, _) <- parseDynamicFlags fs (map noLoc opts)
+		void $ setSessionDynFlags $ onFlags fs'
+		modifyFlags $ C.setLogAction logToNull
+		act
+
+interpretedFlags :: DynFlags -> DynFlags
+interpretedFlags fs = fs {
+	ghcMode = CompManager,
+	ghcLink = LinkInMemory,
+	hscTarget = HscInterpreted }
+
+noLinkFlags :: DynFlags -> DynFlags
+noLinkFlags fs = fs {
+	ghcMode = CompManager,
+	ghcLink = NoLink,
+	hscTarget = HscNothing }
+
+-- | Alter @DynFlags@ temporary
+withFlags :: GhcMonad m => m a -> m a
+withFlags = gbracket getSessionDynFlags (void . setSessionDynFlags) . const
+
+-- | Update @DynFlags@
+modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
+modifyFlags f = do
+	fs <- getSessionDynFlags
+	let
+		fs' = f fs
+	_ <- setSessionDynFlags fs'
+	-- _ <- liftIO $ initPackages fs'
+	return ()
+
+-- | Clear loaded targets
+clearTargets :: GhcMonad m => m ()
+clearTargets = loadTargets []
+
+-- | Make target with its source code optional
+makeTarget :: GhcMonad m => Text -> Maybe Text -> m Target
+makeTarget name Nothing = guessTarget (T.unpack name) Nothing
+makeTarget name (Just cts) = do
+	t <- guessTarget (T.unpack name) Nothing
+	tm <- liftIO getCurrentTime
+	return t { targetContents = Just (stringToStringBuffer $ T.unpack cts, tm) }
+
+-- | Load all targets
+loadTargets :: GhcMonad m => [Target] -> m ()
+loadTargets ts = setTargets ts >> load LoadAllTargets >> return ()
+
+-- | Load and set interactive context
+loadInteractive :: GhcMonad m => Path -> Maybe Text -> m ()
+loadInteractive fpath mcts = do
+	fpath' <- liftIO $ canonicalize fpath
+	withCurrentDirectory (view path $ takeDir fpath') $ do
+		t <- makeTarget (over path takeFileName fpath') mcts
+		loadTargets [t]
+		g <- getModuleGraph
+		setContext [IIModule (ms_mod_name m) | m <- g]
+
+-- | Reload targets
+reload :: GhcMonad m => m ()
+reload = do
+	ts <- getTargets
+	ctx <- getContext
+	setContext []
+	clearTargets
+	setTargets ts
+	setContext ctx
+
+-- | Collect messages from ghc for underlying computation
+collectMessages :: GhcMonad m => m a -> m (a, [Note OutputMessage])
+collectMessages act = do
+	ch <- liftIO newChan
+	r <- gbracket (liftM log_action getSessionDynFlags) (\action' -> modifyFlags (\fs -> fs { log_action = action' })) $ \_ -> do
+		modifyFlags (C.addLogAction $ logToChan ch)
+		act
+	notes <- liftIO $ stopChan ch
+	return (r, notes)
+
+-- | Same as @collectMessages@, but when no result except notes needed
+collectMessages_ :: GhcMonad m => m () -> m [Note OutputMessage]
+collectMessages_ = fmap snd . collectMessages
+
+-- | Format type for output
+formatType :: GHC.DynFlags -> GHC.Type -> String
+formatType dflag t = showOutputable dflag (removeForAlls t)
+
+-- | Get region of @SrcSpan@
+spanRegion :: SrcSpan -> Region
+spanRegion (RealSrcSpan s) = Position (srcSpanStartLine s) (srcSpanStartCol s) `region` Position (srcSpanEndLine s) (srcSpanEndCol s)
+spanRegion _ = Position 0 0 `region` Position 0 0
+
+-- | Set current directory and restore it after action
+withCurrentDirectory :: GhcMonad m => FilePath -> m a -> m a
+withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $
+	const (liftIO (setCurrentDirectory dir) >> act)
+
+-- | Log  ghc warnings and errors as to chan
+-- You may have to apply recalcTabs on result notes
+logToChan :: Chan (Note OutputMessage) -> LogAction
+logToChan ch fs sev src msg
+	| Just sev' <- checkSev sev = do
+		src' <- canonicalize srcMod
+		void $ sendChan ch Note {
+			_noteSource = src',
+			_noteRegion = spanRegion src,
+			_noteLevel = Just sev',
+			_note = OutputMessage {
+				_message = fromString $ showSDoc fs msg,
+				_messageSuggestion = Nothing } }
+	| otherwise = return ()
+	where
+		checkSev SevWarning = Just Warning
+		checkSev SevError = Just Error
+		checkSev SevFatal = Just Error
+		checkSev _ = Nothing
+		srcMod = case src of
+			RealSrcSpan s' -> FileModule (fromFilePath $ unpackFS $ srcSpanFile s') Nothing
+			_ -> NoLocation
+
+-- | Don't log ghc warnings and errors
+logToNull :: LogAction
+logToNull _ _ _ _ = return ()
+
+-- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@
+
+removeForAlls :: Type -> Type
+removeForAlls ty = removeForAlls' ty' tty' where
+	ty'  = dropForAlls ty
+	tty' = splitFunTy_maybe ty'
+
+removeForAlls' :: Type -> Maybe (Type, Type) -> Type
+removeForAlls' ty Nothing = ty
+removeForAlls' ty (Just (pre, ftype))
+	| isPredTy pre = mkFunTy pre (dropForAlls ftype)
+	| otherwise = ty
+
+showOutputable :: Outputable a => DynFlags -> a -> String
+showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr
+
+showUnqualifiedPage :: DynFlags -> SDoc -> String
+showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . withPprStyleDoc dflag (C.unqualStyle dflag)
src/HsDev/Tools/Ghc/Check.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE OverloadedStrings #-}--module HsDev.Tools.Ghc.Check (-	check,--	Ghc,-	module HsDev.Tools.Types,-	module HsDev.Symbols.Types,-	PackageDb(..), PackageDbStack(..), Project(..),--	module Control.Monad.Except-	) where--import Control.Lens (view, (^.))-import Control.Monad.Except-import qualified Data.Map as M-import Data.Text (Text)-import System.Log.Simple (MonadLog(..), scope, sendLog, Level(Trace))--import GHC hiding (Warning, Module)--import HsDev.Error-import HsDev.PackageDb-import HsDev.Symbols.Location-import HsDev.Symbols.Types-import HsDev.Tools.Base-import HsDev.Tools.Ghc.Worker-import HsDev.Tools.Types-import HsDev.Tools.Tabs-import System.Directory.Paths---- | Check module source-check :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m [Note OutputMessage]-check m msrc = scope "check" $ case view (moduleId . moduleLocation) m of-	FileModule file _ -> do-		let-			dir = sourceRoot_ (m ^. moduleId)-			-- FIXME: There can be dependent modules with modified file contents-			-- Their contents should be set here too-			srcs = maybe mempty (M.singleton file) msrc-		ex <- liftIO $ dirExists dir-		sendLog Trace "loading targets"-		notes <- withFlags $ (if ex then withCurrentDirectory (dir ^. path) else id) $ collectMessages_ $ do-			target <- makeTarget (relPathTo dir file) msrc-			loadTargets [target]-		sendLog Trace "targets checked"-		liftIO $ recalcNotesTabs srcs notes-	_ -> scope "check" $ hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m)+{-# LANGUAGE OverloadedStrings #-}
+
+module HsDev.Tools.Ghc.Check (
+	check,
+
+	Ghc,
+	module HsDev.Tools.Types,
+	module HsDev.Symbols.Types,
+	PackageDb(..), PackageDbStack(..), Project(..),
+
+	module Control.Monad.Except
+	) where
+
+import Control.Lens (view, (^.))
+import Control.Monad.Except
+import qualified Data.Map as M
+import Data.Text (Text)
+import System.Log.Simple (MonadLog(..), scope, sendLog, Level(Trace))
+
+import GHC hiding (Warning, Module)
+
+import HsDev.Error
+import HsDev.PackageDb
+import HsDev.Symbols.Location
+import HsDev.Symbols.Types
+import HsDev.Tools.Base
+import HsDev.Tools.Ghc.Worker
+import HsDev.Tools.Types
+import HsDev.Tools.Tabs
+import System.Directory.Paths
+
+-- | Check module source
+check :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m [Note OutputMessage]
+check m msrc = scope "check" $ case view (moduleId . moduleLocation) m of
+	FileModule file _ -> do
+		let
+			dir = sourceRoot_ (m ^. moduleId)
+			-- FIXME: There can be dependent modules with modified file contents
+			-- Their contents should be set here too
+			srcs = maybe mempty (M.singleton file) msrc
+		ex <- liftIO $ dirExists dir
+		sendLog Trace "loading targets"
+		notes <- withFlags $ (if ex then withCurrentDirectory (dir ^. path) else id) $ collectMessages_ $ do
+			target <- makeTarget (relPathTo dir file) msrc
+			loadTargets [target]
+		sendLog Trace "targets checked"
+		liftIO $ recalcNotesTabs srcs notes
+	_ -> scope "check" $ hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m)
src/HsDev/Tools/Ghc/Compat.hs view
@@ -1,211 +1,211 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Tools.Ghc.Compat (-	pkgDatabase,-	UnitId, InstalledUnitId, toInstalledUnitId,-	unitId, moduleUnitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle,-	LogAction, setLogAction, addLogAction,-	languages, flags,-	recSelParent, recSelCtors,-	getFixity,-	unqualStyle,-	exposedModuleName,-	exprType-	) where--import qualified BasicTypes-import qualified DynFlags as GHC-import qualified ErrUtils-import qualified InteractiveEval as Eval-import qualified GHC-import qualified Module-import qualified Name-import qualified Packages as GHC-import qualified PatSyn as GHC-import qualified Pretty-import Outputable--#if __GLASGOW_HASKELL__ >= 800-import Data.List (nub)-import qualified IdInfo-import TcRnDriver-#endif--#if __GLASGOW_HASKELL__ == 710-import Exception (ExceptionMonad)-import Control.Monad.Reader-#endif--#if __GLASGOW_HASKELL__ <= 800-import qualified GHC.PackageDb as GHC-#endif--pkgDatabase :: GHC.DynFlags -> Maybe [GHC.PackageConfig]-#if __GLASGOW_HASKELL__ >= 800-pkgDatabase = fmap (nub . concatMap snd) . GHC.pkgDatabase-#elif __GLASGOW_HASKELL__ == 710-pkgDatabase = GHC.pkgDatabase-#endif--#if __GLASGOW_HASKELL__ >= 800-type UnitId = Module.UnitId-#elif __GLASGOW_HASKELL__ == 710-type UnitId = Module.PackageKey-#endif--#if __GLASGOW_HASKELL__ == 802-type InstalledUnitId = Module.InstalledUnitId-#else-type InstalledUnitId = UnitId-#endif--toInstalledUnitId :: UnitId -> InstalledUnitId-#if __GLASGOW_HASKELL__ == 802-toInstalledUnitId = Module.toInstalledUnitId-#else-toInstalledUnitId = id-#endif--unitId :: GHC.PackageConfig -> InstalledUnitId-#if __GLASGOW_HASKELL__ >= 800-unitId = GHC.unitId-#elif __GLASGOW_HASKELL__ == 710-unitId = GHC.packageKey-#endif--moduleUnitId :: GHC.Module -> UnitId-#if __GLASGOW_HASKELL__ >= 800-moduleUnitId = GHC.moduleUnitId-#elif __GLASGOW_HASKELL__ == 710-moduleUnitId = GHC.modulePackageKey-#endif--depends :: GHC.DynFlags -> GHC.PackageConfig -> [InstalledUnitId]-#if __GLASGOW_HASKELL__ >= 800-depends _ = GHC.depends-#elif __GLASGOW_HASKELL__ == 710-depends df = map (GHC.resolveInstalledPackageId df) . GHC.depends-#endif--getPackageDetails :: GHC.DynFlags -> InstalledUnitId -> GHC.PackageConfig-#if __GLASGOW_HASKELL__ == 802-getPackageDetails = GHC.getInstalledPackageDetails-#else-getPackageDetails = GHC.getPackageDetails-#endif--patSynType :: GHC.PatSyn -> GHC.Type-patSynType p = GHC.patSynInstResTy p (GHC.patSynArgs p)--#if __GLASGOW_HASKELL__ >= 800-cleanupHandler :: GHC.DynFlags -> m a -> m a-cleanupHandler _ = id-#elif __GLASGOW_HASKELL__ == 710-cleanupHandler :: (ExceptionMonad m) => GHC.DynFlags -> m a -> m a-cleanupHandler = GHC.defaultCleanupHandler-#endif--renderStyle :: Pretty.Mode -> Int -> Pretty.Doc -> String-#if __GLASGOW_HASKELL__ >= 800-renderStyle m cols = Pretty.renderStyle (Pretty.Style m cols 1.5)-#elif __GLASGOW_HASKELL__ == 710-renderStyle = Pretty.showDoc-#endif--type LogAction = GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> ErrUtils.MsgDoc -> IO ()--setLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags-setLogAction act fs = fs { GHC.log_action = act' } where-	act' :: GHC.LogAction-#if __GLASGOW_HASKELL__ >= 800-	act' df _ sev src _ msg = act df sev src msg-#elif __GLASGOW_HASKELL__ == 710-	act' df sev src _ msg = act df sev src msg-#endif--addLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags-addLogAction act fs = fs { GHC.log_action = logBoth } where-	logBoth :: GHC.LogAction-#if __GLASGOW_HASKELL__ >= 800-	logBoth df wreason sev src style msg = do-		GHC.log_action fs df wreason sev src style msg-		GHC.log_action (setLogAction act fs) df wreason sev src style msg-#elif __GLASGOW_HASKELL__ == 710-	logBoth df sev src style ms = do-		GHC.log_action fs df sev src style msg-		GHC.log_action (setLogAction act fs) df sev src style msg-#endif--#if __GLASGOW_HASKELL__ == 710-instance (Monad m, GHC.HasDynFlags m) => GHC.HasDynFlags (ReaderT r m) where-	getDynFlags = lift GHC.getDynFlags-#endif--flags :: [String]-#if __GLASGOW_HASKELL__ >= 800-flags = concat [-	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],-	["warn-" ++ option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags],-	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]-#elif __GLASGOW_HASKELL__ >= 710-flags = concat [-	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],-	[option | (GHC.FlagSpec option _ _ _) <- GHC.fWarningFlags],-	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]-#elif __GLASGOW_HASKELL__ >= 704-flags = concat [-	[option | (option, _, _) <- GHC.fFlags],-	[option | (option, _, _) <- GHC.fWarningFlags],-	[option | (option, _, _) <- GHC.fLangFlags]]-#endif--#if __GLASGOW_HASKELL__ >= 800-recSelParent :: IdInfo.RecSelParent -> String-recSelParent (IdInfo.RecSelData p) = Name.getOccString p-recSelParent (IdInfo.RecSelPatSyn p) = Name.getOccString p-#else-recSelParent :: GHC.TyCon -> String-recSelParent = Name.getOccString-#endif--#if __GLASGOW_HASKELL__ >= 800-recSelCtors :: IdInfo.RecSelParent -> [String]-recSelCtors (IdInfo.RecSelData p) = map Name.getOccString (GHC.tyConDataCons p)-recSelCtors (IdInfo.RecSelPatSyn p) = [Name.getOccString p]-#else-recSelCtors :: GHC.TyCon -> [String]-recSelCtors = return . Name.getOccString-#endif--getFixity :: BasicTypes.Fixity -> (Int, BasicTypes.FixityDirection)-#if __GLASGOW_HASKELL__ >= 800-getFixity (BasicTypes.Fixity _ i d) = (i, d)-#else-getFixity (BasicTypes.Fixity i d) = (i, d)-#endif--languages :: [String]-languages = GHC.supportedLanguagesAndExtensions--unqualStyle :: GHC.DynFlags -> PprStyle-#if __GLASGOW_HASKELL__ == 802-unqualStyle df = mkUserStyle df neverQualify AllTheWay-#else-unqualStyle _ = mkUserStyle neverQualify AllTheWay-#endif--#if __GLASGOW_HASKELL__ == 802-exposedModuleName :: (a, Maybe b) -> a-exposedModuleName = fst-#else-exposedModuleName :: GHC.ExposedModule unit mname -> mname-exposedModuleName = GHC.exposedName-#endif--exprType :: GHC.GhcMonad m => String -> m GHC.Type-#if __GLASGOW_HASKELL__ > 800-exprType = Eval.exprType TM_Inst-#else-exprType = Eval.exprType-#endif+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.Ghc.Compat (
+	pkgDatabase,
+	UnitId, InstalledUnitId, toInstalledUnitId,
+	unitId, moduleUnitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle,
+	LogAction, setLogAction, addLogAction,
+	languages, flags,
+	recSelParent, recSelCtors,
+	getFixity,
+	unqualStyle,
+	exposedModuleName,
+	exprType
+	) where
+
+import qualified BasicTypes
+import qualified DynFlags as GHC
+import qualified ErrUtils
+import qualified InteractiveEval as Eval
+import qualified GHC
+import qualified Module
+import qualified Name
+import qualified Packages as GHC
+import qualified PatSyn as GHC
+import qualified Pretty
+import Outputable
+
+#if __GLASGOW_HASKELL__ >= 800
+import Data.List (nub)
+import qualified IdInfo
+import TcRnDriver
+#endif
+
+#if __GLASGOW_HASKELL__ == 710
+import Exception (ExceptionMonad)
+import Control.Monad.Reader
+#endif
+
+#if __GLASGOW_HASKELL__ <= 800
+import qualified GHC.PackageDb as GHC
+#endif
+
+pkgDatabase :: GHC.DynFlags -> Maybe [GHC.PackageConfig]
+#if __GLASGOW_HASKELL__ >= 800
+pkgDatabase = fmap (nub . concatMap snd) . GHC.pkgDatabase
+#elif __GLASGOW_HASKELL__ == 710
+pkgDatabase = GHC.pkgDatabase
+#endif
+
+#if __GLASGOW_HASKELL__ >= 800
+type UnitId = Module.UnitId
+#elif __GLASGOW_HASKELL__ == 710
+type UnitId = Module.PackageKey
+#endif
+
+#if __GLASGOW_HASKELL__ == 802
+type InstalledUnitId = Module.InstalledUnitId
+#else
+type InstalledUnitId = UnitId
+#endif
+
+toInstalledUnitId :: UnitId -> InstalledUnitId
+#if __GLASGOW_HASKELL__ == 802
+toInstalledUnitId = Module.toInstalledUnitId
+#else
+toInstalledUnitId = id
+#endif
+
+unitId :: GHC.PackageConfig -> InstalledUnitId
+#if __GLASGOW_HASKELL__ >= 800
+unitId = GHC.unitId
+#elif __GLASGOW_HASKELL__ == 710
+unitId = GHC.packageKey
+#endif
+
+moduleUnitId :: GHC.Module -> UnitId
+#if __GLASGOW_HASKELL__ >= 800
+moduleUnitId = GHC.moduleUnitId
+#elif __GLASGOW_HASKELL__ == 710
+moduleUnitId = GHC.modulePackageKey
+#endif
+
+depends :: GHC.DynFlags -> GHC.PackageConfig -> [InstalledUnitId]
+#if __GLASGOW_HASKELL__ >= 800
+depends _ = GHC.depends
+#elif __GLASGOW_HASKELL__ == 710
+depends df = map (GHC.resolveInstalledPackageId df) . GHC.depends
+#endif
+
+getPackageDetails :: GHC.DynFlags -> InstalledUnitId -> GHC.PackageConfig
+#if __GLASGOW_HASKELL__ == 802
+getPackageDetails = GHC.getInstalledPackageDetails
+#else
+getPackageDetails = GHC.getPackageDetails
+#endif
+
+patSynType :: GHC.PatSyn -> GHC.Type
+patSynType p = GHC.patSynInstResTy p (GHC.patSynArgs p)
+
+#if __GLASGOW_HASKELL__ >= 800
+cleanupHandler :: GHC.DynFlags -> m a -> m a
+cleanupHandler _ = id
+#elif __GLASGOW_HASKELL__ == 710
+cleanupHandler :: (ExceptionMonad m) => GHC.DynFlags -> m a -> m a
+cleanupHandler = GHC.defaultCleanupHandler
+#endif
+
+renderStyle :: Pretty.Mode -> Int -> Pretty.Doc -> String
+#if __GLASGOW_HASKELL__ >= 800
+renderStyle m cols = Pretty.renderStyle (Pretty.Style m cols 1.5)
+#elif __GLASGOW_HASKELL__ == 710
+renderStyle = Pretty.showDoc
+#endif
+
+type LogAction = GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> ErrUtils.MsgDoc -> IO ()
+
+setLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags
+setLogAction act fs = fs { GHC.log_action = act' } where
+	act' :: GHC.LogAction
+#if __GLASGOW_HASKELL__ >= 800
+	act' df _ sev src _ msg = act df sev src msg
+#elif __GLASGOW_HASKELL__ == 710
+	act' df sev src _ msg = act df sev src msg
+#endif
+
+addLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags
+addLogAction act fs = fs { GHC.log_action = logBoth } where
+	logBoth :: GHC.LogAction
+#if __GLASGOW_HASKELL__ >= 800
+	logBoth df wreason sev src style msg = do
+		GHC.log_action fs df wreason sev src style msg
+		GHC.log_action (setLogAction act fs) df wreason sev src style msg
+#elif __GLASGOW_HASKELL__ == 710
+	logBoth df sev src style ms = do
+		GHC.log_action fs df sev src style msg
+		GHC.log_action (setLogAction act fs) df sev src style msg
+#endif
+
+#if __GLASGOW_HASKELL__ == 710
+instance (Monad m, GHC.HasDynFlags m) => GHC.HasDynFlags (ReaderT r m) where
+	getDynFlags = lift GHC.getDynFlags
+#endif
+
+flags :: [String]
+#if __GLASGOW_HASKELL__ >= 800
+flags = concat [
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],
+	["warn-" ++ option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags],
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]
+#elif __GLASGOW_HASKELL__ >= 710
+flags = concat [
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fWarningFlags],
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]
+#elif __GLASGOW_HASKELL__ >= 704
+flags = concat [
+	[option | (option, _, _) <- GHC.fFlags],
+	[option | (option, _, _) <- GHC.fWarningFlags],
+	[option | (option, _, _) <- GHC.fLangFlags]]
+#endif
+
+#if __GLASGOW_HASKELL__ >= 800
+recSelParent :: IdInfo.RecSelParent -> String
+recSelParent (IdInfo.RecSelData p) = Name.getOccString p
+recSelParent (IdInfo.RecSelPatSyn p) = Name.getOccString p
+#else
+recSelParent :: GHC.TyCon -> String
+recSelParent = Name.getOccString
+#endif
+
+#if __GLASGOW_HASKELL__ >= 800
+recSelCtors :: IdInfo.RecSelParent -> [String]
+recSelCtors (IdInfo.RecSelData p) = map Name.getOccString (GHC.tyConDataCons p)
+recSelCtors (IdInfo.RecSelPatSyn p) = [Name.getOccString p]
+#else
+recSelCtors :: GHC.TyCon -> [String]
+recSelCtors = return . Name.getOccString
+#endif
+
+getFixity :: BasicTypes.Fixity -> (Int, BasicTypes.FixityDirection)
+#if __GLASGOW_HASKELL__ >= 800
+getFixity (BasicTypes.Fixity _ i d) = (i, d)
+#else
+getFixity (BasicTypes.Fixity i d) = (i, d)
+#endif
+
+languages :: [String]
+languages = GHC.supportedLanguagesAndExtensions
+
+unqualStyle :: GHC.DynFlags -> PprStyle
+#if __GLASGOW_HASKELL__ == 802
+unqualStyle df = mkUserStyle df neverQualify AllTheWay
+#else
+unqualStyle _ = mkUserStyle neverQualify AllTheWay
+#endif
+
+#if __GLASGOW_HASKELL__ == 802
+exposedModuleName :: (a, Maybe b) -> a
+exposedModuleName = fst
+#else
+exposedModuleName :: GHC.ExposedModule unit mname -> mname
+exposedModuleName = GHC.exposedName
+#endif
+
+exprType :: GHC.GhcMonad m => String -> m GHC.Type
+#if __GLASGOW_HASKELL__ > 800
+exprType = Eval.exprType TM_Inst
+#else
+exprType = Eval.exprType
+#endif
src/HsDev/Tools/Ghc/MGhc.hs view
@@ -1,241 +1,241 @@-{-# LANGUAGE UnicodeSyntax, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Tools.Ghc.MGhc (-	Session(..), sessionKey, sessionData,-	SessionState(..), sessionActive, sessionMap,-	MGhcT(..), runMGhcT, liftGhc,-	currentSession, getSessionData, setSessionData, hasSession, findSession, findSessionBy, saveSession,-	initSession, newSession,-	switchSession, switchSession_,-	deleteSession, restoreSession, usingSession, tempSession-	) where--import Control.Lens-import Control.Monad.Morph-import Control.Monad.Catch-import Control.Monad.Reader-import Control.Monad.State-import Data.Default-import Data.IORef-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe (fromMaybe, isJust)-import System.Log.Simple.Monad (MonadLog(..))--import DynFlags-import Exception hiding (catch, mask, uninterruptibleMask, bracket, finally)-import GHC-import GHCi-import GhcMonad hiding (Session(..))-import qualified GhcMonad (Session(..))-import HscTypes-import Outputable-import SysTools--data Session s d = Session {-	_sessionKey :: s,-	_sessionData :: d }-		deriving (Eq, Ord, Read, Show)--sessionKey :: Lens' (Session s d) s-sessionKey = lens g s where-	g = _sessionKey-	s sess k = sess { _sessionKey = k }--sessionData :: Lens' (Session s d) d-sessionData = lens g s where-	g = _sessionData-	s sess dat = sess { _sessionData = dat }--data SessionState s d = SessionState {-	_sessionActive :: Maybe (Session s d),-	_sessionMap :: Map s (HscEnv, d) }--instance Default (SessionState s d) where-	def = SessionState Nothing M.empty--sessionActive :: Lens' (SessionState s d) (Maybe (Session s d))-sessionActive = lens g s where-	g = _sessionActive-	s st nm = st { _sessionActive = nm }--sessionMap :: Lens' (SessionState s d) (Map s (HscEnv, d))-sessionMap = lens g s where-	g = _sessionMap-	s st m = st { _sessionMap = m }--instance ExceptionMonad m => ExceptionMonad (StateT s m) where-	gcatch act onError = StateT $ \st -> gcatch (runStateT act st) (\e -> runStateT (onError e) st)-	gmask f = StateT $ gmask . f' where-		f' st' act' = runStateT (f act) st' where-			act st = StateT $ act' . runStateT st--instance ExceptionMonad m => ExceptionMonad (ReaderT r m) where-	gcatch act onError = ReaderT $ \v -> gcatch (runReaderT act v) (\e -> runReaderT (onError e) v)-	gmask f = ReaderT $ gmask . f' where-		f' v' act' = runReaderT (f act) v' where-			act v = ReaderT $ act' . runReaderT v---- | Multi-session ghc monad-newtype MGhcT s d m a = MGhcT { unMGhcT :: GhcT (ReaderT (Maybe FilePath) (StateT (SessionState s d) m)) a }-	deriving (Functor, Applicative, Monad, MonadIO, ExceptionMonad, HasDynFlags, GhcMonad, MonadState (SessionState s d), MonadReader (Maybe FilePath), MonadThrow, MonadCatch, MonadMask, MonadLog)--instance MonadTrans GhcT where-	lift = liftGhcT--instance MFunctor GhcT where-	hoist fn = GhcT . (fn .) . unGhcT--instance MonadState st m => MonadState st (GhcT m) where-	get = lift get-	put = lift . put-	state = lift . state--instance MonadReader r m => MonadReader r (GhcT m) where-	ask = lift ask-	local f act = GhcT $ local f . unGhcT act--instance MonadThrow m => MonadThrow (GhcT m) where-	throwM = lift . throwM--instance MonadCatch m => MonadCatch (GhcT m) where-	catch act onError = GhcT $ \sess -> catch (unGhcT act sess) (flip unGhcT sess . onError)--instance MonadMask m => MonadMask (GhcT m) where-	mask f = GhcT $ \s -> mask $ \g -> unGhcT (f $ q g) s where-		q g' act = GhcT $ g' . unGhcT act-	uninterruptibleMask f = GhcT $ \s -> uninterruptibleMask $ \g -> unGhcT (f $ q g) s where-		q g' act = GhcT $ g' . unGhcT act---- | Run multi-session ghc-runMGhcT :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => Maybe FilePath -> MGhcT s d m a -> m a-runMGhcT lib act = do-	ref <- liftIO $ newIORef (panic "empty session")-	let-		session = GhcMonad.Session ref-	flip evalStateT def $ flip runReaderT lib $ flip unGhcT session $ unMGhcT $ act `gfinally` cleanup-	where-		cleanup :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m ()-		cleanup = do-			void saveSession-			sessions <- gets (M.elems . view sessionMap)-			liftIO $ mapM_ (cleanupSession . view _1) sessions-			modify (set sessionMap M.empty)---- | Lift `Ghc` monad onto `MGhc`-liftGhc :: MonadIO m => Ghc a -> MGhcT s d m a-liftGhc (Ghc act) = MGhcT $ GhcT $ liftIO . act---- | Get current session-currentSession :: MonadIO m => MGhcT s d m (Maybe (Session s d))-currentSession = gets (view sessionActive)---- | Get current session data-getSessionData :: MonadIO m => MGhcT s d m (Maybe d)-getSessionData = gets (preview (sessionActive . _Just . sessionData))---- | Set current session data-setSessionData :: MonadIO m => d -> MGhcT s d m ()-setSessionData sdata = modify (set (sessionActive . _Just . sessionData) sdata)---- | Does session exist-hasSession :: (MonadIO m, Ord s) => s -> MGhcT s d m Bool-hasSession key = do-	msess <- findSession key-	return $ isJust msess---- | Find session-findSession :: (MonadIO m, Ord s) => s -> MGhcT s d m (Maybe (Session s d))-findSession key = do-	sdata <- gets (preview (sessionMap . ix key . _2))-	return $ fmap (Session key) sdata---- | Find session by-findSessionBy :: MonadIO m => (s -> Bool) -> MGhcT s d m [Session s d]-findSessionBy p = do-	sessions <- gets (M.toList . view sessionMap)-	return [Session key sdata | (key, (_, sdata)) <- sessions, p key]---- | Save current session-saveSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m (Maybe (Session s d))-saveSession = do-	msess <- currentSession-	case msess of-		Just (Session key' dat') -> do-			sess <- getSession-			modify (set (sessionMap . at key') (Just (sess, dat')))-		Nothing -> return ()-	return msess---- | Initialize new session-initSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m ()-initSession = do-	lib <- ask-	initGhcMonad lib-	void saveSession--activateSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m (Maybe HscEnv)-activateSession key = do-	void saveSession-	sdata <- gets (view (sessionMap . ix key . _2))-	modify (set sessionActive $ Just (Session key sdata))-	gets (preview (sessionMap . ix key . _1))---- | Create new named session, deleting existing session-newSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m ()-newSession key = do-	msess <- activateSession key-	maybe (return ()) (liftIO . cleanupSession) msess-	initSession---- | Switch to session, creating if not exist, returns True if session was created-switchSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m Bool-switchSession key = do-	msess <- activateSession key-	case msess of-		Nothing -> initSession >> return True-		Just sess -> setSession sess >> return False---- | Switch to session, creating if not exist and initializing with passed function-switchSession_ :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> Maybe (MGhcT s d m ()) -> MGhcT s d m ()-switchSession_ key f = do-	new <- switchSession key-	when new $ fromMaybe (return ()) f---- | Delete existing session-deleteSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m ()-deleteSession key = do-	cur <- saveSession-	when (preview (_Just . sessionKey) cur == Just key) $-		modify (set sessionActive Nothing)-	msess <- gets (preview (sessionMap . ix key . _1))-	modify (set (sessionMap . at key) Nothing)-	case msess of-		Nothing -> return ()-		Just sess -> liftIO $ cleanupSession sess---- | Save and restore session-restoreSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m a -> MGhcT s d m a-restoreSession act = bracket saveSession (maybe (return ()) (void . switchSession . view sessionKey)) $ const act---- | Run action using session, restoring session back-usingSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a-usingSession key act = restoreSession $ do-	void $ switchSession key-	act---- | Run with temporary session, like @usingSession@, but deletes self session-tempSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a-tempSession key act = do-	exist' <- hasSession key-	usingSession key act `finally` unless exist' (deleteSession key)---- | Cleanup session-cleanupSession :: HscEnv -> IO ()-cleanupSession env = do-	cleanTempFiles df-	cleanTempDirs df-	stopIServ env-	where-		df = hsc_dflags env+{-# LANGUAGE UnicodeSyntax, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.Ghc.MGhc (
+	Session(..), sessionKey, sessionData,
+	SessionState(..), sessionActive, sessionMap,
+	MGhcT(..), runMGhcT, liftGhc,
+	currentSession, getSessionData, setSessionData, hasSession, findSession, findSessionBy, saveSession,
+	initSession, newSession,
+	switchSession, switchSession_,
+	deleteSession, restoreSession, usingSession, tempSession
+	) where
+
+import Control.Lens
+import Control.Monad.Morph
+import Control.Monad.Catch
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Default
+import Data.IORef
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe, isJust)
+import System.Log.Simple.Monad (MonadLog(..))
+
+import DynFlags
+import Exception hiding (catch, mask, uninterruptibleMask, bracket, finally)
+import GHC
+import GHCi
+import GhcMonad hiding (Session(..))
+import qualified GhcMonad (Session(..))
+import HscTypes
+import Outputable
+import SysTools
+
+data Session s d = Session {
+	_sessionKey :: s,
+	_sessionData :: d }
+		deriving (Eq, Ord, Read, Show)
+
+sessionKey :: Lens' (Session s d) s
+sessionKey = lens g s where
+	g = _sessionKey
+	s sess k = sess { _sessionKey = k }
+
+sessionData :: Lens' (Session s d) d
+sessionData = lens g s where
+	g = _sessionData
+	s sess dat = sess { _sessionData = dat }
+
+data SessionState s d = SessionState {
+	_sessionActive :: Maybe (Session s d),
+	_sessionMap :: Map s (HscEnv, d) }
+
+instance Default (SessionState s d) where
+	def = SessionState Nothing M.empty
+
+sessionActive :: Lens' (SessionState s d) (Maybe (Session s d))
+sessionActive = lens g s where
+	g = _sessionActive
+	s st nm = st { _sessionActive = nm }
+
+sessionMap :: Lens' (SessionState s d) (Map s (HscEnv, d))
+sessionMap = lens g s where
+	g = _sessionMap
+	s st m = st { _sessionMap = m }
+
+instance ExceptionMonad m => ExceptionMonad (StateT s m) where
+	gcatch act onError = StateT $ \st -> gcatch (runStateT act st) (\e -> runStateT (onError e) st)
+	gmask f = StateT $ gmask . f' where
+		f' st' act' = runStateT (f act) st' where
+			act st = StateT $ act' . runStateT st
+
+instance ExceptionMonad m => ExceptionMonad (ReaderT r m) where
+	gcatch act onError = ReaderT $ \v -> gcatch (runReaderT act v) (\e -> runReaderT (onError e) v)
+	gmask f = ReaderT $ gmask . f' where
+		f' v' act' = runReaderT (f act) v' where
+			act v = ReaderT $ act' . runReaderT v
+
+-- | Multi-session ghc monad
+newtype MGhcT s d m a = MGhcT { unMGhcT :: GhcT (ReaderT (Maybe FilePath) (StateT (SessionState s d) m)) a }
+	deriving (Functor, Applicative, Monad, MonadIO, ExceptionMonad, HasDynFlags, GhcMonad, MonadState (SessionState s d), MonadReader (Maybe FilePath), MonadThrow, MonadCatch, MonadMask, MonadLog)
+
+instance MonadTrans GhcT where
+	lift = liftGhcT
+
+instance MFunctor GhcT where
+	hoist fn = GhcT . (fn .) . unGhcT
+
+instance MonadState st m => MonadState st (GhcT m) where
+	get = lift get
+	put = lift . put
+	state = lift . state
+
+instance MonadReader r m => MonadReader r (GhcT m) where
+	ask = lift ask
+	local f act = GhcT $ local f . unGhcT act
+
+instance MonadThrow m => MonadThrow (GhcT m) where
+	throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (GhcT m) where
+	catch act onError = GhcT $ \sess -> catch (unGhcT act sess) (flip unGhcT sess . onError)
+
+instance MonadMask m => MonadMask (GhcT m) where
+	mask f = GhcT $ \s -> mask $ \g -> unGhcT (f $ q g) s where
+		q g' act = GhcT $ g' . unGhcT act
+	uninterruptibleMask f = GhcT $ \s -> uninterruptibleMask $ \g -> unGhcT (f $ q g) s where
+		q g' act = GhcT $ g' . unGhcT act
+
+-- | Run multi-session ghc
+runMGhcT :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => Maybe FilePath -> MGhcT s d m a -> m a
+runMGhcT lib act = do
+	ref <- liftIO $ newIORef (panic "empty session")
+	let
+		session = GhcMonad.Session ref
+	flip evalStateT def $ flip runReaderT lib $ flip unGhcT session $ unMGhcT $ act `gfinally` cleanup
+	where
+		cleanup :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m ()
+		cleanup = do
+			void saveSession
+			sessions <- gets (M.elems . view sessionMap)
+			liftIO $ mapM_ (cleanupSession . view _1) sessions
+			modify (set sessionMap M.empty)
+
+-- | Lift `Ghc` monad onto `MGhc`
+liftGhc :: MonadIO m => Ghc a -> MGhcT s d m a
+liftGhc (Ghc act) = MGhcT $ GhcT $ liftIO . act
+
+-- | Get current session
+currentSession :: MonadIO m => MGhcT s d m (Maybe (Session s d))
+currentSession = gets (view sessionActive)
+
+-- | Get current session data
+getSessionData :: MonadIO m => MGhcT s d m (Maybe d)
+getSessionData = gets (preview (sessionActive . _Just . sessionData))
+
+-- | Set current session data
+setSessionData :: MonadIO m => d -> MGhcT s d m ()
+setSessionData sdata = modify (set (sessionActive . _Just . sessionData) sdata)
+
+-- | Does session exist
+hasSession :: (MonadIO m, Ord s) => s -> MGhcT s d m Bool
+hasSession key = do
+	msess <- findSession key
+	return $ isJust msess
+
+-- | Find session
+findSession :: (MonadIO m, Ord s) => s -> MGhcT s d m (Maybe (Session s d))
+findSession key = do
+	sdata <- gets (preview (sessionMap . ix key . _2))
+	return $ fmap (Session key) sdata
+
+-- | Find session by
+findSessionBy :: MonadIO m => (s -> Bool) -> MGhcT s d m [Session s d]
+findSessionBy p = do
+	sessions <- gets (M.toList . view sessionMap)
+	return [Session key sdata | (key, (_, sdata)) <- sessions, p key]
+
+-- | Save current session
+saveSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m (Maybe (Session s d))
+saveSession = do
+	msess <- currentSession
+	case msess of
+		Just (Session key' dat') -> do
+			sess <- getSession
+			modify (set (sessionMap . at key') (Just (sess, dat')))
+		Nothing -> return ()
+	return msess
+
+-- | Initialize new session
+initSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m ()
+initSession = do
+	lib <- ask
+	initGhcMonad lib
+	void saveSession
+
+activateSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m (Maybe HscEnv)
+activateSession key = do
+	void saveSession
+	sdata <- gets (view (sessionMap . ix key . _2))
+	modify (set sessionActive $ Just (Session key sdata))
+	gets (preview (sessionMap . ix key . _1))
+
+-- | Create new named session, deleting existing session
+newSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m ()
+newSession key = do
+	msess <- activateSession key
+	maybe (return ()) (liftIO . cleanupSession) msess
+	initSession
+
+-- | Switch to session, creating if not exist, returns True if session was created
+switchSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m Bool
+switchSession key = do
+	msess <- activateSession key
+	case msess of
+		Nothing -> initSession >> return True
+		Just sess -> setSession sess >> return False
+
+-- | Switch to session, creating if not exist and initializing with passed function
+switchSession_ :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> Maybe (MGhcT s d m ()) -> MGhcT s d m ()
+switchSession_ key f = do
+	new <- switchSession key
+	when new $ fromMaybe (return ()) f
+
+-- | Delete existing session
+deleteSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m ()
+deleteSession key = do
+	cur <- saveSession
+	when (preview (_Just . sessionKey) cur == Just key) $
+		modify (set sessionActive Nothing)
+	msess <- gets (preview (sessionMap . ix key . _1))
+	modify (set (sessionMap . at key) Nothing)
+	case msess of
+		Nothing -> return ()
+		Just sess -> liftIO $ cleanupSession sess
+
+-- | Save and restore session
+restoreSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m a -> MGhcT s d m a
+restoreSession act = bracket saveSession (maybe (return ()) (void . switchSession . view sessionKey)) $ const act
+
+-- | Run action using session, restoring session back
+usingSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a
+usingSession key act = restoreSession $ do
+	void $ switchSession key
+	act
+
+-- | Run with temporary session, like @usingSession@, but deletes self session
+tempSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a
+tempSession key act = do
+	exist' <- hasSession key
+	usingSession key act `finally` unless exist' (deleteSession key)
+
+-- | Cleanup session
+cleanupSession :: HscEnv -> IO ()
+cleanupSession env = do
+	cleanTempFiles df
+	cleanTempDirs df
+	stopIServ env
+	where
+		df = hsc_dflags env
src/HsDev/Tools/Ghc/Prelude.hs view
@@ -1,91 +1,91 @@-module HsDev.Tools.Ghc.Prelude (-	reduce, trim,-	-- * Regexes-	rx, srx, splitRx,-	-- * Case-	lowerCase, upperCase, titleCase, camelCase, underscoreCase,--	module Control.Lens,-	module Data.Char,-	module Data.List,-	module Data.Maybe-	) where--import Control.Lens-import Data.Array (assocs)-import Data.Char-import Data.List hiding (uncons)-import Data.Maybe-import Text.Regex.PCRE---- | Reduce list to one element-reduce :: ([a] -> a) -> [a] -> [a]-reduce = (return .)---- | Trim string-trim :: String -> String-trim = p . p where-	p = reverse . dropWhile isSpace---- | Match regex-rx :: String -> String -> Maybe String-rx r s = case s =~ r of-	"" -> Nothing-	res -> Just res---- | Replace regex-srx :: String -> String -> String -> String-srx pat s = concat . unfoldr split' . Just where-	split' :: Maybe String -> Maybe (String, Maybe String)-	split' Nothing = Nothing-	split' (Just str) = case mrMatch r of-		"" -> Just (mrBefore r, Nothing)-		_ -> Just (mrBefore r ++ subst, Just $ mrAfter r)-		where-			r = str =~ pat-			groups = filter (not . null . snd) $ assocs $ mrSubs r-			look i = lookup i groups-			subst = subst' s where-				subst' :: String -> String-				subst' "" = ""-				subst' "\\" = "\\"-				subst' ('\\':'\\':ss') = '\\' : subst' ss'-				subst' ('\\':ss') = case span isDigit ss' of-					([], _) -> '\\' : subst' ss'-					(num, tl) -> fromMaybe "" (look $ read num) ++ subst' tl-				subst' (s':ss') = s' : subst' ss'---- | Split by regex-splitRx :: String -> String -> [String]-splitRx pat = unfoldr split' . Just where-	split' :: Maybe String -> Maybe (String, Maybe String)-	split' Nothing = Nothing-	split' (Just str) = case mrMatch r of-		"" -> Just (mrBefore r, Nothing)-		_ -> Just (mrBefore r, Just $ mrAfter r)-		where-			r = str =~ pat--lowerCase :: String -> String-lowerCase = map toLower--upperCase :: String -> String-upperCase = map toUpper---- | Convert to title case-titleCase :: String -> String-titleCase = over _head toUpper---- | Convert to camel case-camelCase :: String -> String-camelCase = concatMap titleCase . splitRx "[\\s_]+"---- | Convert to underscore case-underscoreCase :: String -> String-underscoreCase = intercalate "_" . map lowerCase . unfoldr break' where-	break' :: String -> Maybe (String, String)-	break' str = do-		(s, ss) <- uncons str-		let-			(h, tl) = break isUpper ss-		return (s:h, tl)+module HsDev.Tools.Ghc.Prelude (
+	reduce, trim,
+	-- * Regexes
+	rx, srx, splitRx,
+	-- * Case
+	lowerCase, upperCase, titleCase, camelCase, underscoreCase,
+
+	module Control.Lens,
+	module Data.Char,
+	module Data.List,
+	module Data.Maybe
+	) where
+
+import Control.Lens
+import Data.Array (assocs)
+import Data.Char
+import Data.List hiding (uncons)
+import Data.Maybe
+import Text.Regex.PCRE
+
+-- | Reduce list to one element
+reduce :: ([a] -> a) -> [a] -> [a]
+reduce = (return .)
+
+-- | Trim string
+trim :: String -> String
+trim = p . p where
+	p = reverse . dropWhile isSpace
+
+-- | Match regex
+rx :: String -> String -> Maybe String
+rx r s = case s =~ r of
+	"" -> Nothing
+	res -> Just res
+
+-- | Replace regex
+srx :: String -> String -> String -> String
+srx pat s = concat . unfoldr split' . Just where
+	split' :: Maybe String -> Maybe (String, Maybe String)
+	split' Nothing = Nothing
+	split' (Just str) = case mrMatch r of
+		"" -> Just (mrBefore r, Nothing)
+		_ -> Just (mrBefore r ++ subst, Just $ mrAfter r)
+		where
+			r = str =~ pat
+			groups = filter (not . null . snd) $ assocs $ mrSubs r
+			look i = lookup i groups
+			subst = subst' s where
+				subst' :: String -> String
+				subst' "" = ""
+				subst' "\\" = "\\"
+				subst' ('\\':'\\':ss') = '\\' : subst' ss'
+				subst' ('\\':ss') = case span isDigit ss' of
+					([], _) -> '\\' : subst' ss'
+					(num, tl) -> fromMaybe "" (look $ read num) ++ subst' tl
+				subst' (s':ss') = s' : subst' ss'
+
+-- | Split by regex
+splitRx :: String -> String -> [String]
+splitRx pat = unfoldr split' . Just where
+	split' :: Maybe String -> Maybe (String, Maybe String)
+	split' Nothing = Nothing
+	split' (Just str) = case mrMatch r of
+		"" -> Just (mrBefore r, Nothing)
+		_ -> Just (mrBefore r, Just $ mrAfter r)
+		where
+			r = str =~ pat
+
+lowerCase :: String -> String
+lowerCase = map toLower
+
+upperCase :: String -> String
+upperCase = map toUpper
+
+-- | Convert to title case
+titleCase :: String -> String
+titleCase = over _head toUpper
+
+-- | Convert to camel case
+camelCase :: String -> String
+camelCase = concatMap titleCase . splitRx "[\\s_]+"
+
+-- | Convert to underscore case
+underscoreCase :: String -> String
+underscoreCase = intercalate "_" . map lowerCase . unfoldr break' where
+	break' :: String -> Maybe (String, String)
+	break' str = do
+		(s, ss) <- uncons str
+		let
+			(h, tl) = break isUpper ss
+		return (s:h, tl)
src/HsDev/Tools/Ghc/Repl.hs view
@@ -1,57 +1,57 @@-{-# LANGUAGE OverloadedStrings, TypeApplications #-}--module HsDev.Tools.Ghc.Repl (-	importModules, preludeModules,-	evaluate,-	expressionType,--	ReplResult(..),-	tryRepl-	) where--import Control.Monad-import Control.Monad.Catch-import Data.Aeson-import Data.Dynamic-import Text.Format--import GhcMonad-import GHC--import HsDev.Tools.Ghc.Base-import qualified HsDev.Tools.Ghc.Compat as C-import HsDev.Util---- | Import some modules-importModules :: GhcMonad m => [String] -> m ()-importModules mods = mapM parseImportDecl ["import " ++ m | m <- mods] >>= setContext . map IIDecl---- | Default interpreter modules-preludeModules :: [String]-preludeModules = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"]---- | Evaluate expression-evaluate :: GhcMonad m => String -> m String-evaluate expr = liftM fromDynamic (dynCompileExpr $ "show ({})" ~~ expr) >>=-	maybe (fail "evaluate fail") return---- | Get expression type as string-expressionType :: GhcMonad m => String -> m String-expressionType expr = do-	dflags <- getSessionDynFlags-	ty <- C.exprType expr-	return $ formatType dflags ty--data ReplResult a = ReplError String | ReplOk a deriving (Eq, Ord, Read, Show)--instance ToJSON a => ToJSON (ReplResult a) where-	toJSON (ReplError e) = object ["error" .= e]-	toJSON (ReplOk v) = object ["ok" .= v]--instance FromJSON a => FromJSON (ReplResult a) where-	parseJSON = withObject "repl-result" $ \v -> msum [-		ReplError <$> v .:: "error",-		ReplOk <$> v .:: "ok"]--tryRepl :: (GhcMonad m, MonadCatch m) => m a -> m (ReplResult a)-tryRepl = fmap (either (ReplError . displayException @SomeException) ReplOk) . try+{-# LANGUAGE OverloadedStrings, TypeApplications #-}
+
+module HsDev.Tools.Ghc.Repl (
+	importModules, preludeModules,
+	evaluate,
+	expressionType,
+
+	ReplResult(..),
+	tryRepl
+	) where
+
+import Control.Monad
+import Control.Monad.Catch
+import Data.Aeson
+import Data.Dynamic
+import Text.Format
+
+import GhcMonad
+import GHC
+
+import HsDev.Tools.Ghc.Base
+import qualified HsDev.Tools.Ghc.Compat as C
+import HsDev.Util
+
+-- | Import some modules
+importModules :: GhcMonad m => [String] -> m ()
+importModules mods = mapM parseImportDecl ["import " ++ m | m <- mods] >>= setContext . map IIDecl
+
+-- | Default interpreter modules
+preludeModules :: [String]
+preludeModules = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"]
+
+-- | Evaluate expression
+evaluate :: GhcMonad m => String -> m String
+evaluate expr = liftM fromDynamic (dynCompileExpr $ "show ({})" ~~ expr) >>=
+	maybe (fail "evaluate fail") return
+
+-- | Get expression type as string
+expressionType :: GhcMonad m => String -> m String
+expressionType expr = do
+	dflags <- getSessionDynFlags
+	ty <- C.exprType expr
+	return $ formatType dflags ty
+
+data ReplResult a = ReplError String | ReplOk a deriving (Eq, Ord, Read, Show)
+
+instance ToJSON a => ToJSON (ReplResult a) where
+	toJSON (ReplError e) = object ["error" .= e]
+	toJSON (ReplOk v) = object ["ok" .= v]
+
+instance FromJSON a => FromJSON (ReplResult a) where
+	parseJSON = withObject "repl-result" $ \v -> msum [
+		ReplError <$> v .:: "error",
+		ReplOk <$> v .:: "ok"]
+
+tryRepl :: (GhcMonad m, MonadCatch m) => m a -> m (ReplResult a)
+tryRepl = fmap (either (ReplError . displayException @SomeException) ReplOk) . try
src/HsDev/Tools/Ghc/Session.hs view
@@ -1,42 +1,42 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Tools.Ghc.Session (-	targetSession, interpretModule,--	module HsDev.Tools.Ghc.Worker-	) where--import Control.Lens-import Data.Maybe (isJust)-import Data.Text (Text, unpack)-import System.Log.Simple--import Control.Concurrent.Worker-import System.Directory.Paths-import HsDev.Symbols.Types-import HsDev.Sandbox (getModuleOpts)-import HsDev.Tools.Ghc.Worker--import qualified GHC---- | Session for module-targetSession :: [String] -> Module -> GhcM ()-targetSession opts m = do-	(pdbs, opts') <- getModuleOpts opts m-	ghcSession pdbs ("-Wall" : opts')---- | Interpret file-interpretModule :: Module -> Maybe Text -> GhcM ()-interpretModule m mcts-	| isJust mpath = do-		let-			rootDir = maybe (takeDir fpath) (view projectPath) (m ^? moduleId . moduleLocation . moduleProject . _Just)-		withCurrentDirectory (view path rootDir) $ do-			t <- makeTarget (relPathTo rootDir fpath) mcts-			loadTargets [t]-			GHC.setContext [GHC.IIModule . GHC.mkModuleName . unpack . view (moduleId . moduleName) $ m]-	| otherwise = return ()-	where-		mpath = m ^? moduleId . moduleLocation . moduleFile-		Just fpath = mpath+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.Ghc.Session (
+	targetSession, interpretModule,
+
+	module HsDev.Tools.Ghc.Worker
+	) where
+
+import Control.Lens
+import Data.Maybe (isJust)
+import Data.Text (Text, unpack)
+import System.Log.Simple
+
+import Control.Concurrent.Worker
+import System.Directory.Paths
+import HsDev.Symbols.Types
+import HsDev.Sandbox (getModuleOpts)
+import HsDev.Tools.Ghc.Worker
+
+import qualified GHC
+
+-- | Session for module
+targetSession :: [String] -> Module -> GhcM ()
+targetSession opts m = do
+	(pdbs, opts') <- getModuleOpts opts m
+	ghcSession pdbs ("-Wall" : opts')
+
+-- | Interpret file
+interpretModule :: Module -> Maybe Text -> GhcM ()
+interpretModule m mcts
+	| isJust mpath = do
+		let
+			rootDir = maybe (takeDir fpath) (view projectPath) (m ^? moduleId . moduleLocation . moduleProject . _Just)
+		withCurrentDirectory (view path rootDir) $ do
+			t <- makeTarget (relPathTo rootDir fpath) mcts
+			loadTargets [t]
+			GHC.setContext [GHC.IIModule . GHC.mkModuleName . unpack . view (moduleId . moduleName) $ m]
+	| otherwise = return ()
+	where
+		mpath = m ^? moduleId . moduleLocation . moduleFile
+		Just fpath = mpath
src/HsDev/Tools/Ghc/System.hs view
@@ -1,55 +1,55 @@-{-# LANGUAGE OverloadedStrings #-}--module HsDev.Tools.Ghc.System (-	BuildInfo(..), buildInfo,-	examineCompilerVersion,--	formatBuildPath, buildPath-	) where--import Control.Arrow-import qualified Data.Map as M-import Data.Maybe-import Distribution.Text (display)-import Distribution.System (buildOS)-import qualified System.Info as Sys-import Text.Format--import DynFlags (DynFlags)-import PackageConfig as GHC-import GHC (getSessionDynFlags)--import HsDev.Tools.Ghc.Compat as Compat-import HsDev.Tools.Ghc.Worker (GhcM)--data BuildInfo = BuildInfo {-	targetArch :: String,-	targetOS :: String,-	cabalOS :: String,-	compilerName :: String,-	compilerVersion :: String }--buildInfo :: DynFlags -> BuildInfo-buildInfo = BuildInfo Sys.arch Sys.os (display buildOS) Sys.compilerName . examineCompilerVersion--examineCompilerVersion :: DynFlags -> String-examineCompilerVersion =-	display .-	fromMaybe Sys.compilerVersion .-	M.lookup Sys.compilerName .-	M.fromList .-	map (GHC.packageNameString &&& GHC.packageVersion) .-	fromMaybe [] . Compat.pkgDatabase---- | Can contain {arch}, {os}/{platform}, {compiler}, {version}-formatBuildPath :: String -> BuildInfo -> String-formatBuildPath f = formats f . toArgs where-	toArgs b = [-		"arch" ~% targetArch b,-		"os" ~% targetOS b,-		"os/cabal" ~% cabalOS b,-		"compiler" ~% compilerName b,-		"version" ~% compilerVersion b]--buildPath :: String -> GhcM FilePath-buildPath f = fmap (formatBuildPath f . buildInfo) getSessionDynFlags+{-# LANGUAGE OverloadedStrings #-}
+
+module HsDev.Tools.Ghc.System (
+	BuildInfo(..), buildInfo,
+	examineCompilerVersion,
+
+	formatBuildPath, buildPath
+	) where
+
+import Control.Arrow
+import qualified Data.Map as M
+import Data.Maybe
+import Distribution.Text (display)
+import Distribution.System (buildOS)
+import qualified System.Info as Sys
+import Text.Format
+
+import DynFlags (DynFlags)
+import PackageConfig as GHC
+import GHC (getSessionDynFlags)
+
+import HsDev.Tools.Ghc.Compat as Compat
+import HsDev.Tools.Ghc.Worker (GhcM)
+
+data BuildInfo = BuildInfo {
+	targetArch :: String,
+	targetOS :: String,
+	cabalOS :: String,
+	compilerName :: String,
+	compilerVersion :: String }
+
+buildInfo :: DynFlags -> BuildInfo
+buildInfo = BuildInfo Sys.arch Sys.os (display buildOS) Sys.compilerName . examineCompilerVersion
+
+examineCompilerVersion :: DynFlags -> String
+examineCompilerVersion =
+	display .
+	fromMaybe Sys.compilerVersion .
+	M.lookup Sys.compilerName .
+	M.fromList .
+	map (GHC.packageNameString &&& GHC.packageVersion) .
+	fromMaybe [] . Compat.pkgDatabase
+
+-- | Can contain {arch}, {os}/{platform}, {compiler}, {version}
+formatBuildPath :: String -> BuildInfo -> String
+formatBuildPath f = formats f . toArgs where
+	toArgs b = [
+		"arch" ~% targetArch b,
+		"os" ~% targetOS b,
+		"os/cabal" ~% cabalOS b,
+		"compiler" ~% compilerName b,
+		"version" ~% compilerVersion b]
+
+buildPath :: String -> GhcM FilePath
+buildPath f = fmap (formatBuildPath f . buildInfo) getSessionDynFlags
src/HsDev/Tools/Ghc/Types.hs view
@@ -1,141 +1,141 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, TemplateHaskell, OverloadedStrings #-}--module HsDev.Tools.Ghc.Types (-	TypedExpr(..), typedExpr, typedType,-	moduleTypes, fileTypes,-	setModuleTypes, inferTypes-	) where--import Control.DeepSeq-import Control.Lens (over, view, set, each, preview, makeLenses, _Just)-import Control.Monad-import Control.Monad.IO.Class-import Data.Aeson-import Data.Generics-import Data.List (find)-import Data.Maybe-import Data.String (fromString)-import Data.Text (Text)-import System.Log.Simple (MonadLog(..), scope)--import GHC hiding (exprType, Module, moduleName)-import GHC.SYB.Utils (everythingStaged, Stage(TypeChecker))-import GhcPlugins (mkFunTys)-import CoreUtils as C-import Desugar (deSugarExpr)-import TcHsSyn (hsPatType)-import Outputable-import PprTyThing-import qualified Pretty--import System.Directory.Paths-import HsDev.Error-import HsDev.Symbols-import HsDev.Tools.Ghc.Worker as Ghc-import HsDev.Tools.Ghc.Compat-import HsDev.Tools.Types-import HsDev.Util--class HasType a where-	getType :: GhcMonad m => a -> m (Maybe (SrcSpan, Type))--instance HasType (LHsExpr Id) where-	getType e = do-		env <- getSession-		mbe <- liftIO $ liftM snd $ deSugarExpr env e-		return $ do-			ex <- mbe-			return (getLoc e, C.exprType ex)--instance HasType (LHsBind Id) where-	getType (L _ FunBind { fun_id = fid, fun_matches = m}) = return $ Just (getLoc fid, typ) where-		typ = mkFunTys (mg_arg_tys m) (mg_res_ty m)-	getType _ = return Nothing--instance HasType (LPat Id) where-	getType (L spn pat) = return $ Just (spn, hsPatType pat)--locatedTypes :: Typeable a => TypecheckedSource -> [Located a]-locatedTypes = types' p where-	types' :: Typeable r => (r -> Bool) -> GenericQ [r]-	types' p' = everythingStaged TypeChecker (++) [] ([] `mkQ` (\x -> [x | p' x]))-	p (L spn _) = isGoodSrcSpan spn--moduleTypes :: GhcMonad m => Path -> m [(SrcSpan, Type)]-moduleTypes fpath = do-	fpath' <- liftIO $ canonicalize fpath-	mg <- getModuleGraph-	[m] <- liftIO $ flip filterM mg $ \m -> do-		mfile <- traverse (liftIO . canonicalize) $ ml_hs_file (ms_location m)-		return (Just (view path fpath') == mfile)-	p <- parseModule m-	tm <- typecheckModule p-	let-		ts = tm_typechecked_source tm-	liftM (catMaybes . concat) $ sequence [-		mapM getType (locatedTypes ts :: [LHsExpr Id]),-		mapM getType (locatedTypes ts :: [LHsBind Id]),-		mapM getType (locatedTypes ts :: [LPat Id])]--data TypedExpr = TypedExpr {-	_typedExpr :: Maybe Text,-	_typedType :: Text }-		deriving (Eq, Ord, Read, Show)--makeLenses ''TypedExpr--instance NFData TypedExpr where-	rnf (TypedExpr e t) = rnf e `seq` rnf t--instance ToJSON TypedExpr where-	toJSON (TypedExpr e t) = object $ noNulls [-		"expr" .= e,-		"type" .= t]--instance FromJSON TypedExpr where-	parseJSON = withObject "typed-expr" $ \v -> TypedExpr <$>-		v .::? "expr" <*>-		v .:: "type"---- | Get all types in module-fileTypes :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m [Note TypedExpr]-fileTypes m msrc = scope "types" $ case view (moduleId . moduleLocation) m of-	FileModule file proj -> do-		file' <- liftIO $ canonicalize file-		cts <- maybe (liftIO $ readFileUtf8 (view path file')) return msrc-		let-			dir = fromMaybe-				(sourceModuleRoot (view (moduleId . moduleName) m) file') $-				preview (_Just . projectPath) proj-		ex <- liftIO $ dirExists dir-		(if ex then Ghc.withCurrentDirectory (view path dir) else id) $ do-			target <- makeTarget (relPathTo dir file') msrc-			loadTargets [target]-			ts <- moduleTypes file'-			df <- getSessionDynFlags-			return $ map (setExpr cts . recalcTabs cts 8 . uncurry (toNote df)) ts-	_ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m)-	where-		toNote :: DynFlags -> SrcSpan -> Type -> Note Text-		toNote df spn tp = Note {-			_noteSource = noLocation,-			_noteRegion = spanRegion spn,-			_noteLevel = Nothing,-			_note = fromString $ showType df tp }-		setExpr :: Text -> Note Text -> Note TypedExpr-		setExpr cts n = over note (TypedExpr (Just (regionStr (view noteRegion n) cts))) n-		showType :: DynFlags -> Type -> String-		showType df = renderStyle Pretty.OneLineMode 80 . withPprStyleDoc df (unqualStyle df) . pprTypeForUser---- | Set types to module-setModuleTypes :: [Note TypedExpr] -> Module -> Module-setModuleTypes ts = over (moduleScope . each . each) setType . over (moduleExports . each) setType where-	setType :: Symbol -> Symbol-	setType d = fromMaybe d $ do-		pos <- view symbolPosition d-		tnote <- find ((== pos) . view (noteRegion . regionFrom)) ts-		return $ set (symbolInfo . functionType) (Just $ view (note . typedType) tnote) d---- | Infer types in module-inferTypes :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m Module-inferTypes m msrc = scope "infer" $ liftM (`setModuleTypes` m) $ fileTypes m msrc+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, TemplateHaskell, OverloadedStrings #-}
+
+module HsDev.Tools.Ghc.Types (
+	TypedExpr(..), typedExpr, typedType,
+	moduleTypes, fileTypes,
+	setModuleTypes, inferTypes
+	) where
+
+import Control.DeepSeq
+import Control.Lens (over, view, set, each, preview, makeLenses, _Just)
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson
+import Data.Generics
+import Data.List (find)
+import Data.Maybe
+import Data.String (fromString)
+import Data.Text (Text)
+import System.Log.Simple (MonadLog(..), scope)
+
+import GHC hiding (exprType, Module, moduleName)
+import GHC.SYB.Utils (everythingStaged, Stage(TypeChecker))
+import GhcPlugins (mkFunTys)
+import CoreUtils as C
+import Desugar (deSugarExpr)
+import TcHsSyn (hsPatType)
+import Outputable
+import PprTyThing
+import qualified Pretty
+
+import System.Directory.Paths
+import HsDev.Error
+import HsDev.Symbols
+import HsDev.Tools.Ghc.Worker as Ghc
+import HsDev.Tools.Ghc.Compat
+import HsDev.Tools.Types
+import HsDev.Util
+
+class HasType a where
+	getType :: GhcMonad m => a -> m (Maybe (SrcSpan, Type))
+
+instance HasType (LHsExpr Id) where
+	getType e = do
+		env <- getSession
+		mbe <- liftIO $ liftM snd $ deSugarExpr env e
+		return $ do
+			ex <- mbe
+			return (getLoc e, C.exprType ex)
+
+instance HasType (LHsBind Id) where
+	getType (L _ FunBind { fun_id = fid, fun_matches = m}) = return $ Just (getLoc fid, typ) where
+		typ = mkFunTys (mg_arg_tys m) (mg_res_ty m)
+	getType _ = return Nothing
+
+instance HasType (LPat Id) where
+	getType (L spn pat) = return $ Just (spn, hsPatType pat)
+
+locatedTypes :: Typeable a => TypecheckedSource -> [Located a]
+locatedTypes = types' p where
+	types' :: Typeable r => (r -> Bool) -> GenericQ [r]
+	types' p' = everythingStaged TypeChecker (++) [] ([] `mkQ` (\x -> [x | p' x]))
+	p (L spn _) = isGoodSrcSpan spn
+
+moduleTypes :: GhcMonad m => Path -> m [(SrcSpan, Type)]
+moduleTypes fpath = do
+	fpath' <- liftIO $ canonicalize fpath
+	mg <- getModuleGraph
+	[m] <- liftIO $ flip filterM mg $ \m -> do
+		mfile <- traverse (liftIO . canonicalize) $ ml_hs_file (ms_location m)
+		return (Just (view path fpath') == mfile)
+	p <- parseModule m
+	tm <- typecheckModule p
+	let
+		ts = tm_typechecked_source tm
+	liftM (catMaybes . concat) $ sequence [
+		mapM getType (locatedTypes ts :: [LHsExpr Id]),
+		mapM getType (locatedTypes ts :: [LHsBind Id]),
+		mapM getType (locatedTypes ts :: [LPat Id])]
+
+data TypedExpr = TypedExpr {
+	_typedExpr :: Maybe Text,
+	_typedType :: Text }
+		deriving (Eq, Ord, Read, Show)
+
+makeLenses ''TypedExpr
+
+instance NFData TypedExpr where
+	rnf (TypedExpr e t) = rnf e `seq` rnf t
+
+instance ToJSON TypedExpr where
+	toJSON (TypedExpr e t) = object $ noNulls [
+		"expr" .= e,
+		"type" .= t]
+
+instance FromJSON TypedExpr where
+	parseJSON = withObject "typed-expr" $ \v -> TypedExpr <$>
+		v .::? "expr" <*>
+		v .:: "type"
+
+-- | Get all types in module
+fileTypes :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m [Note TypedExpr]
+fileTypes m msrc = scope "types" $ case view (moduleId . moduleLocation) m of
+	FileModule file proj -> do
+		file' <- liftIO $ canonicalize file
+		cts <- maybe (liftIO $ readFileUtf8 (view path file')) return msrc
+		let
+			dir = fromMaybe
+				(sourceModuleRoot (view (moduleId . moduleName) m) file') $
+				preview (_Just . projectPath) proj
+		ex <- liftIO $ dirExists dir
+		(if ex then Ghc.withCurrentDirectory (view path dir) else id) $ do
+			target <- makeTarget (relPathTo dir file') msrc
+			loadTargets [target]
+			ts <- moduleTypes file'
+			df <- getSessionDynFlags
+			return $ map (setExpr cts . recalcTabs cts 8 . uncurry (toNote df)) ts
+	_ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m)
+	where
+		toNote :: DynFlags -> SrcSpan -> Type -> Note Text
+		toNote df spn tp = Note {
+			_noteSource = noLocation,
+			_noteRegion = spanRegion spn,
+			_noteLevel = Nothing,
+			_note = fromString $ showType df tp }
+		setExpr :: Text -> Note Text -> Note TypedExpr
+		setExpr cts n = over note (TypedExpr (Just (regionStr (view noteRegion n) cts))) n
+		showType :: DynFlags -> Type -> String
+		showType df = renderStyle Pretty.OneLineMode 80 . withPprStyleDoc df (unqualStyle df) . pprTypeForUser
+
+-- | Set types to module
+setModuleTypes :: [Note TypedExpr] -> Module -> Module
+setModuleTypes ts = over (moduleScope . each . each) setType . over (moduleExports . each) setType where
+	setType :: Symbol -> Symbol
+	setType d = fromMaybe d $ do
+		pos <- view symbolPosition d
+		tnote <- find ((== pos) . view (noteRegion . regionFrom)) ts
+		return $ set (symbolInfo . functionType) (Just $ view (note . typedType) tnote) d
+
+-- | Infer types in module
+inferTypes :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m Module
+inferTypes m msrc = scope "infer" $ liftM (`setModuleTypes` m) $ fileTypes m msrc
src/HsDev/Tools/Ghc/Worker.hs view
@@ -1,131 +1,131 @@-{-# LANGUAGE PatternGuards, OverloadedStrings, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Tools.Ghc.Worker (-	-- * Workers-	SessionType(..), SessionConfig(..),-	GhcM, GhcWorker, MGhcT(..), runGhcM,-	ghcWorker,-	workerSession, ghcSession, ghciSession, haddockSession, tmpSession,--	Ghc,-	LogT(..),--	module HsDev.Tools.Ghc.Base,-	module HsDev.Tools.Ghc.Repl,-	module HsDev.Tools.Ghc.MGhc,-	module Control.Concurrent.Worker-	) where--import Control.Lens (view)-import Control.Monad-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Catch-import Data.Monoid-import qualified System.Log.Simple as Log-import System.Log.Simple.Monad (MonadLog(..), LogT(..), withLog)-import Text.Format hiding (withFlags)--import Exception (ExceptionMonad(..), ghandle)-import GHC hiding (Warning, Module)-import GHC.Paths--import Control.Concurrent.Worker-import HsDev.PackageDb.Types-import HsDev.Tools.Ghc.Base-import HsDev.Tools.Ghc.Repl-import HsDev.Tools.Ghc.MGhc--data SessionType = SessionGhci | SessionGhc | SessionHaddock | SessionTmp deriving (Eq, Ord)-data SessionConfig = SessionConfig SessionType PackageDbStack deriving (Eq, Ord)--instance Show SessionType where-	show SessionGhci = "ghci"-	show SessionGhc = "ghc"-	show SessionHaddock = "haddock"-	show SessionTmp = "tmp"--instance Formattable SessionType--instance Show SessionConfig where-	show (SessionConfig t pdb) = "{} {}" ~~ t ~~ pdb--instance Formattable SessionConfig--type GhcM a = MGhcT SessionConfig (First DynFlags) (LogT IO) a--type GhcWorker = Worker (MGhcT SessionConfig (First DynFlags) (LogT IO))--instance (Monad m, GhcMonad m) => GhcMonad (ReaderT r m) where-	getSession = lift getSession-	setSession = lift . setSession--instance ExceptionMonad m => ExceptionMonad (LogT m) where-	gcatch act onError = LogT $ gcatch (runLogT act) (runLogT . onError)-	gmask f = LogT $ gmask f' where-		f' g' = runLogT $ f (LogT . g' . runLogT)--instance MonadThrow Ghc where-	throwM = liftIO . throwM--runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a-runGhcM dir act = do-	l <- Log.askLog-	liftIO $ withLog l $ runMGhcT dir act---- | Multi-session ghc worker-ghcWorker :: MonadLog m => m GhcWorker-ghcWorker = do-	l <- Log.askLog-	liftIO $ startWorker (withLog l . runGhcM (Just libdir)) (Log.scope "ghc") (ghandle logErr)-	where-		logErr :: MonadLog m => SomeException -> m ()-		logErr e = Log.sendLog Log.Warning ("exception in ghc worker task: {}" ~~ displayException e)---- | Create session with options-workerSession :: SessionType -> PackageDbStack -> [String] -> GhcM ()-workerSession ty pdbs opts = do-	ms <- findSessionBy toKill-	forM_ ms $ \s' -> do-		Log.sendLog Log.Trace $ "killing session: {}" ~~ view sessionKey s'-		deleteSession $ view sessionKey s'-	Log.sendLog Log.Trace $ "session: {}" ~~ SessionConfig ty pdbs-	switchSession_ (SessionConfig ty pdbs) $ Just initialize-	setSessionFlags-	where-		toKill (SessionConfig ty' pdbs') = or [-			(ty == ty' && pdbs /= pdbs'),-			(ty /= ty' && ty' `elem` [SessionTmp, SessionHaddock] && ty /= SessionTmp)]-		initialize = do-			run-			dflags <- getSessionDynFlags-			setSessionData (First $ Just dflags)-		run = case ty of-			SessionGhci -> ghcRun pdbsOpts (importModules preludeModules)-			SessionGhc -> ghcRun pdbsOpts (return ())-			SessionTmp -> ghcRun pdbsOpts (return ())-			SessionHaddock -> ghcRunWith noLinkFlags ("-haddock" : pdbsOpts) (return ())-		setSessionFlags = do-			Log.sendLog Log.Trace $ "setting flags: {}" ~~ unwords opts-			mdflags <- fmap (join . fmap getFirst) getSessionData-			dflags <- maybe getSessionDynFlags return mdflags-			(df', _, _) <- parseDynamicFlags dflags (map noLoc opts)-			void $ setSessionDynFlags df'-		pdbsOpts = packageDbStackOpts pdbs---- | Get ghc session-ghcSession :: PackageDbStack -> [String] -> GhcM ()-ghcSession = workerSession SessionGhc---- | Get ghci session-ghciSession :: GhcM ()-ghciSession = workerSession SessionGhci userDb []---- | Get haddock session with flags-haddockSession :: PackageDbStack -> [String] -> GhcM ()-haddockSession = workerSession SessionHaddock---- | Get haddock session with flags-tmpSession :: PackageDbStack -> [String] -> GhcM ()-tmpSession = workerSession SessionTmp+{-# LANGUAGE PatternGuards, OverloadedStrings, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.Ghc.Worker (
+	-- * Workers
+	SessionType(..), SessionConfig(..),
+	GhcM, GhcWorker, MGhcT(..), runGhcM,
+	ghcWorker,
+	workerSession, ghcSession, ghciSession, haddockSession, tmpSession,
+
+	Ghc,
+	LogT(..),
+
+	module HsDev.Tools.Ghc.Base,
+	module HsDev.Tools.Ghc.Repl,
+	module HsDev.Tools.Ghc.MGhc,
+	module Control.Concurrent.Worker
+	) where
+
+import Control.Lens (view)
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Catch
+import Data.Monoid
+import qualified System.Log.Simple as Log
+import System.Log.Simple.Monad (MonadLog(..), LogT(..), withLog)
+import Text.Format hiding (withFlags)
+
+import Exception (ExceptionMonad(..), ghandle)
+import GHC hiding (Warning, Module)
+import GHC.Paths
+
+import Control.Concurrent.Worker
+import HsDev.PackageDb.Types
+import HsDev.Tools.Ghc.Base
+import HsDev.Tools.Ghc.Repl
+import HsDev.Tools.Ghc.MGhc
+
+data SessionType = SessionGhci | SessionGhc | SessionHaddock | SessionTmp deriving (Eq, Ord)
+data SessionConfig = SessionConfig SessionType PackageDbStack deriving (Eq, Ord)
+
+instance Show SessionType where
+	show SessionGhci = "ghci"
+	show SessionGhc = "ghc"
+	show SessionHaddock = "haddock"
+	show SessionTmp = "tmp"
+
+instance Formattable SessionType
+
+instance Show SessionConfig where
+	show (SessionConfig t pdb) = "{} {}" ~~ t ~~ pdb
+
+instance Formattable SessionConfig
+
+type GhcM a = MGhcT SessionConfig (First DynFlags) (LogT IO) a
+
+type GhcWorker = Worker (MGhcT SessionConfig (First DynFlags) (LogT IO))
+
+instance (Monad m, GhcMonad m) => GhcMonad (ReaderT r m) where
+	getSession = lift getSession
+	setSession = lift . setSession
+
+instance ExceptionMonad m => ExceptionMonad (LogT m) where
+	gcatch act onError = LogT $ gcatch (runLogT act) (runLogT . onError)
+	gmask f = LogT $ gmask f' where
+		f' g' = runLogT $ f (LogT . g' . runLogT)
+
+instance MonadThrow Ghc where
+	throwM = liftIO . throwM
+
+runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a
+runGhcM dir act = do
+	l <- Log.askLog
+	liftIO $ withLog l $ runMGhcT dir act
+
+-- | Multi-session ghc worker
+ghcWorker :: MonadLog m => m GhcWorker
+ghcWorker = do
+	l <- Log.askLog
+	liftIO $ startWorker (withLog l . runGhcM (Just libdir)) (Log.scope "ghc") (ghandle logErr)
+	where
+		logErr :: MonadLog m => SomeException -> m ()
+		logErr e = Log.sendLog Log.Warning ("exception in ghc worker task: {}" ~~ displayException e)
+
+-- | Create session with options
+workerSession :: SessionType -> PackageDbStack -> [String] -> GhcM ()
+workerSession ty pdbs opts = do
+	ms <- findSessionBy toKill
+	forM_ ms $ \s' -> do
+		Log.sendLog Log.Trace $ "killing session: {}" ~~ view sessionKey s'
+		deleteSession $ view sessionKey s'
+	Log.sendLog Log.Trace $ "session: {}" ~~ SessionConfig ty pdbs
+	switchSession_ (SessionConfig ty pdbs) $ Just initialize
+	setSessionFlags
+	where
+		toKill (SessionConfig ty' pdbs') = or [
+			(ty == ty' && pdbs /= pdbs'),
+			(ty /= ty' && ty' `elem` [SessionTmp, SessionHaddock] && ty /= SessionTmp)]
+		initialize = do
+			run
+			dflags <- getSessionDynFlags
+			setSessionData (First $ Just dflags)
+		run = case ty of
+			SessionGhci -> ghcRun pdbsOpts (importModules preludeModules)
+			SessionGhc -> ghcRun pdbsOpts (return ())
+			SessionTmp -> ghcRun pdbsOpts (return ())
+			SessionHaddock -> ghcRunWith noLinkFlags ("-haddock" : pdbsOpts) (return ())
+		setSessionFlags = do
+			Log.sendLog Log.Trace $ "setting flags: {}" ~~ unwords opts
+			mdflags <- fmap (join . fmap getFirst) getSessionData
+			dflags <- maybe getSessionDynFlags return mdflags
+			(df', _, _) <- parseDynamicFlags dflags (map noLoc opts)
+			void $ setSessionDynFlags df'
+		pdbsOpts = packageDbStackOpts pdbs
+
+-- | Get ghc session
+ghcSession :: PackageDbStack -> [String] -> GhcM ()
+ghcSession = workerSession SessionGhc
+
+-- | Get ghci session
+ghciSession :: GhcM ()
+ghciSession = workerSession SessionGhci userDb []
+
+-- | Get haddock session with flags
+haddockSession :: PackageDbStack -> [String] -> GhcM ()
+haddockSession = workerSession SessionHaddock
+
+-- | Get haddock session with flags
+tmpSession :: PackageDbStack -> [String] -> GhcM ()
+tmpSession = workerSession SessionTmp
src/HsDev/Tools/HDocs.hs view
@@ -1,179 +1,179 @@-{-# LANGUAGE CPP, OverloadedStrings #-}--module HsDev.Tools.HDocs (-	hdocsy, hdocs, hdocsPackage, hdocsCabal,-	setSymbolDocs, setDocs, setModuleDocs,--	hdocsProcess,--	readDocs, readModuleDocs, readProjectTargetDocs,--	hdocsSupported,--	module Control.Monad.Except-	) where--import Control.Lens-import Control.Monad ()-import Control.Monad.Except--import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Text (Text)-#ifdef NODOCS-import qualified System.Log.Simple as Log-#endif--#ifndef NODOCS-import Control.DeepSeq-import Data.Aeson (decode)-import qualified Data.ByteString.Lazy.Char8 as L (pack)-import Data.String (fromString)-import qualified Data.Text as T--import qualified HDocs.Module as HDocs-import qualified HDocs.Haddock as HDocs--import qualified GHC-#endif--import qualified PackageConfig as P--import Data.LookupTable-#ifndef NODOCS-import HsDev.Error-import HsDev.Scan.Browse (packageConfigs, readPackage)-import HsDev.Tools.Base-#endif-import HsDev.Symbols-import HsDev.Tools.Ghc.Worker-import System.Directory.Paths---- | Get docs for modules-hdocsy :: PackageDbStack -> [ModuleLocation] -> [String] -> GhcM [Map String String]-#ifndef NODOCS-hdocsy pdbs mlocs opts = (map $ force . HDocs.formatDocs) <$> docs' mlocs where-	docs' :: [ModuleLocation] -> GhcM [HDocs.ModuleDocMap]-	docs' ms = do-		haddockSession pdbs opts-		liftGhc $ hsdevLiftWith (ToolError "hdocs") $-			liftM (map snd) $ HDocs.readSourcesGhc opts $ map (view (moduleFile . path)) ms-#else-hdocsy _ _ _ = notSupported >> return mempty-#endif---- | Get docs for module-hdocs :: PackageDbStack -> ModuleLocation -> [String] -> GhcM (Map String String)-#ifndef NODOCS-hdocs pdbs mloc opts = (force . HDocs.formatDocs) <$> docs' mloc where-	docs' :: ModuleLocation -> GhcM HDocs.ModuleDocMap-	docs' mloc' = do-		haddockSession pdbs opts-		liftGhc $ case mloc' of-			(FileModule fpath _) -> hsdevLiftWith (ToolError "hdocs") $ liftM snd $ HDocs.readSourceGhc opts (view path fpath)-			(InstalledModule _ _ mname _) -> do-				df <- GHC.getSessionDynFlags-				liftIO $ hsdevLiftWith (ToolError "hdocs") $ HDocs.moduleDocsF df (T.unpack mname)-			_ -> hsdevError $ ToolError "hdocs" $ "Can't get docs for: " ++ show mloc'-#else-hdocs _ _ _ = notSupported >> return mempty-#endif---- | Get docs for package-hdocsPackage :: P.PackageConfig -> GhcM (Map Text (Map Text Text))-#ifndef NODOCS-hdocsPackage p = do-	ifaces <--		liftIO . hsdevLiftWith (ToolError "hdocs") .-		liftM concat . mapM ((`mplus` return []) . HDocs.readInstalledInterfaces) $-		P.haddockInterfaces p-	let-		idocs = HDocs.installedInterfacesDocs ifaces-		iexports = M.fromList $ map (HDocs.exportsDocs idocs) ifaces-		docs = M.map HDocs.formatDocs iexports-		tdocs = M.map (M.map fromString . M.mapKeys fromString) . M.mapKeys fromString $ docs-	return $!! tdocs-#else-hdocsPackage _ = notSupported >> return mempty-#endif---- | Get all docs-hdocsCabal :: PackageDbStack -> [String] -> GhcM [(ModulePackage, (Map Text (Map Text Text)))]-#ifndef NODOCS-hdocsCabal pdbs opts = do-	haddockSession pdbs opts-	pkgs <- packageConfigs-	forM pkgs $ \pkg -> do-		pkgDocs' <- hdocsPackage pkg-		return (readPackage pkg, pkgDocs')-#else-hdocsCabal _ _ = notSupported >> return mempty-#endif---- | Set docs for module-setSymbolDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Symbol -> m Symbol-setSymbolDocs tbl d sym = do-	symDocs <- cacheInTableM tbl (symName, symMod) (return $ M.lookup symName d)-	return $ set symbolDocs symDocs sym-	where-		symName = view (symbolId . symbolName) sym-		symMod = view (symbolId . symbolModule . moduleName) sym---- | Set docs for module symbols-setDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Module -> m Module-setDocs tbl d = mapMOf (moduleExports . each) setDoc >=> mapMOf (moduleScope . each . each) setDoc where-	setDoc = setSymbolDocs tbl d---- | Set docs for modules-setModuleDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text (Map Text Text) -> Module -> m Module-setModuleDocs tbl docs m = maybe return (setDocs tbl) (M.lookup (view (moduleId . moduleName) m) docs) $ m--hdocsProcess :: String -> [String] -> IO (Maybe (Map String String))-#ifndef NODOCS-hdocsProcess mname opts = liftM (decode . L.pack . last . lines) $ runTool_ "hdocs" opts' where-	opts' = mname : concat [["-g", opt] | opt <- opts]-#else-hdocsProcess _ _ = return mempty-#endif---- | Read docs for one module-readDocs :: Text -> [String] -> Path -> GhcM (Maybe (Map String String))-#ifndef NODOCS-readDocs mname opts fpath = do-	docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts [view path fpath]-	return $ fmap HDocs.formatDocs $ lookup (T.unpack mname) docs-#else-readDocs _ _ _ = notSupported >> return mempty-#endif---- | Read docs for one module-readModuleDocs :: [String] -> Module -> GhcM (Maybe (Map String String))-#ifndef NODOCS-readModuleDocs opts m = case view (moduleId . moduleLocation) m of-	FileModule fpath _ -> withCurrentDirectory (sourceRoot_ (m ^. moduleId) ^. path) $ do-		readDocs (m ^. moduleId . moduleName) opts fpath-	_ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m)-#else-readModuleDocs _ _ = notSupported >> return mempty-#endif--readProjectTargetDocs :: [String] -> Project -> [Path] -> GhcM (Map String (Map String String))-#ifndef NODOCS-readProjectTargetDocs opts proj fpaths = withCurrentDirectory (proj ^. projectPath . path) $ do-	docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts (fpaths ^.. each . path)-	return $ M.map HDocs.formatDocs $ M.fromList docs-#else-readProjectTargetDocs _ _ _ = notSupported >> return mempty-#endif--#ifdef NODOCS-notSupported :: Log.MonadLog m => m ()-notSupported = Log.sendLog Log.Warning "compiled without hdocs support"-#endif--hdocsSupported :: Bool-#ifndef NODOCS-hdocsSupported = True-#else-hdocsSupported = False-#endif+{-# LANGUAGE CPP, OverloadedStrings #-}
+
+module HsDev.Tools.HDocs (
+	hdocsy, hdocs, hdocsPackage, hdocsCabal,
+	setSymbolDocs, setDocs, setModuleDocs,
+
+	hdocsProcess,
+
+	readDocs, readModuleDocs, readProjectTargetDocs,
+
+	hdocsSupported,
+
+	module Control.Monad.Except
+	) where
+
+import Control.Lens
+import Control.Monad ()
+import Control.Monad.Except
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+#ifdef NODOCS
+import qualified System.Log.Simple as Log
+#endif
+
+#ifndef NODOCS
+import Control.DeepSeq
+import Data.Aeson (decode)
+import qualified Data.ByteString.Lazy.Char8 as L (pack)
+import Data.String (fromString)
+import qualified Data.Text as T
+
+import qualified HDocs.Module as HDocs
+import qualified HDocs.Haddock as HDocs
+
+import qualified GHC
+#endif
+
+import qualified PackageConfig as P
+
+import Data.LookupTable
+#ifndef NODOCS
+import HsDev.Error
+import HsDev.Scan.Browse (packageConfigs, readPackage)
+import HsDev.Tools.Base
+#endif
+import HsDev.Symbols
+import HsDev.Tools.Ghc.Worker
+import System.Directory.Paths
+
+-- | Get docs for modules
+hdocsy :: PackageDbStack -> [ModuleLocation] -> [String] -> GhcM [Map String String]
+#ifndef NODOCS
+hdocsy pdbs mlocs opts = (map $ force . HDocs.formatDocs) <$> docs' mlocs where
+	docs' :: [ModuleLocation] -> GhcM [HDocs.ModuleDocMap]
+	docs' ms = do
+		haddockSession pdbs opts
+		liftGhc $ hsdevLiftWith (ToolError "hdocs") $
+			liftM (map snd) $ HDocs.readSourcesGhc opts $ map (view (moduleFile . path)) ms
+#else
+hdocsy _ _ _ = notSupported >> return mempty
+#endif
+
+-- | Get docs for module
+hdocs :: PackageDbStack -> ModuleLocation -> [String] -> GhcM (Map String String)
+#ifndef NODOCS
+hdocs pdbs mloc opts = (force . HDocs.formatDocs) <$> docs' mloc where
+	docs' :: ModuleLocation -> GhcM HDocs.ModuleDocMap
+	docs' mloc' = do
+		haddockSession pdbs opts
+		liftGhc $ case mloc' of
+			(FileModule fpath _) -> hsdevLiftWith (ToolError "hdocs") $ liftM snd $ HDocs.readSourceGhc opts (view path fpath)
+			(InstalledModule _ _ mname _) -> do
+				df <- GHC.getSessionDynFlags
+				liftIO $ hsdevLiftWith (ToolError "hdocs") $ HDocs.moduleDocsF df (T.unpack mname)
+			_ -> hsdevError $ ToolError "hdocs" $ "Can't get docs for: " ++ show mloc'
+#else
+hdocs _ _ _ = notSupported >> return mempty
+#endif
+
+-- | Get docs for package
+hdocsPackage :: P.PackageConfig -> GhcM (Map Text (Map Text Text))
+#ifndef NODOCS
+hdocsPackage p = do
+	ifaces <-
+		liftIO . hsdevLiftWith (ToolError "hdocs") .
+		liftM concat . mapM ((`mplus` return []) . HDocs.readInstalledInterfaces) $
+		P.haddockInterfaces p
+	let
+		idocs = HDocs.installedInterfacesDocs ifaces
+		iexports = M.fromList $ map (HDocs.exportsDocs idocs) ifaces
+		docs = M.map HDocs.formatDocs iexports
+		tdocs = M.map (M.map fromString . M.mapKeys fromString) . M.mapKeys fromString $ docs
+	return $!! tdocs
+#else
+hdocsPackage _ = notSupported >> return mempty
+#endif
+
+-- | Get all docs
+hdocsCabal :: PackageDbStack -> [String] -> GhcM [(ModulePackage, (Map Text (Map Text Text)))]
+#ifndef NODOCS
+hdocsCabal pdbs opts = do
+	haddockSession pdbs opts
+	pkgs <- packageConfigs
+	forM pkgs $ \pkg -> do
+		pkgDocs' <- hdocsPackage pkg
+		return (readPackage pkg, pkgDocs')
+#else
+hdocsCabal _ _ = notSupported >> return mempty
+#endif
+
+-- | Set docs for module
+setSymbolDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Symbol -> m Symbol
+setSymbolDocs tbl d sym = do
+	symDocs <- cacheInTableM tbl (symName, symMod) (return $ M.lookup symName d)
+	return $ set symbolDocs symDocs sym
+	where
+		symName = view (symbolId . symbolName) sym
+		symMod = view (symbolId . symbolModule . moduleName) sym
+
+-- | Set docs for module symbols
+setDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Module -> m Module
+setDocs tbl d = mapMOf (moduleExports . each) setDoc >=> mapMOf (moduleScope . each . each) setDoc where
+	setDoc = setSymbolDocs tbl d
+
+-- | Set docs for modules
+setModuleDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text (Map Text Text) -> Module -> m Module
+setModuleDocs tbl docs m = maybe return (setDocs tbl) (M.lookup (view (moduleId . moduleName) m) docs) $ m
+
+hdocsProcess :: String -> [String] -> IO (Maybe (Map String String))
+#ifndef NODOCS
+hdocsProcess mname opts = liftM (decode . L.pack . last . lines) $ runTool_ "hdocs" opts' where
+	opts' = mname : concat [["-g", opt] | opt <- opts]
+#else
+hdocsProcess _ _ = return mempty
+#endif
+
+-- | Read docs for one module
+readDocs :: Text -> [String] -> Path -> GhcM (Maybe (Map String String))
+#ifndef NODOCS
+readDocs mname opts fpath = do
+	docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts [view path fpath]
+	return $ fmap HDocs.formatDocs $ lookup (T.unpack mname) docs
+#else
+readDocs _ _ _ = notSupported >> return mempty
+#endif
+
+-- | Read docs for one module
+readModuleDocs :: [String] -> Module -> GhcM (Maybe (Map String String))
+#ifndef NODOCS
+readModuleDocs opts m = case view (moduleId . moduleLocation) m of
+	FileModule fpath _ -> withCurrentDirectory (sourceRoot_ (m ^. moduleId) ^. path) $ do
+		readDocs (m ^. moduleId . moduleName) opts fpath
+	_ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m)
+#else
+readModuleDocs _ _ = notSupported >> return mempty
+#endif
+
+readProjectTargetDocs :: [String] -> Project -> [Path] -> GhcM (Map String (Map String String))
+#ifndef NODOCS
+readProjectTargetDocs opts proj fpaths = withCurrentDirectory (proj ^. projectPath . path) $ do
+	docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts (fpaths ^.. each . path)
+	return $ M.map HDocs.formatDocs $ M.fromList docs
+#else
+readProjectTargetDocs _ _ _ = notSupported >> return mempty
+#endif
+
+#ifdef NODOCS
+notSupported :: Log.MonadLog m => m ()
+notSupported = Log.sendLog Log.Warning "compiled without hdocs support"
+#endif
+
+hdocsSupported :: Bool
+#ifndef NODOCS
+hdocsSupported = True
+#else
+hdocsSupported = False
+#endif
src/HsDev/Tools/HLint.hs view
@@ -1,99 +1,99 @@-module HsDev.Tools.HLint (-	hlint,--	module Control.Monad.Except-	) where--import Control.Arrow-import Control.Lens (over, view, _Just)-import Control.Monad.Except-import Data.Char-import Data.List-import Data.Maybe (mapMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Ord-import Data.String (fromString)-import Language.Haskell.HLint3 (argsSettings, parseModuleEx, applyHints, Idea(..), parseErrorMessage, ParseFlags(..), CppFlags(..))-import Language.Haskell.Exts.SrcLoc-import qualified Language.Haskell.HLint3 as HL (Severity(..))--import System.Directory.Paths-import HsDev.Symbols.Location-import HsDev.Tools.Base-import HsDev.Util (readFileUtf8)--hlint :: [String] -> FilePath -> Maybe Text -> ExceptT String IO [Note OutputMessage]-hlint opts file msrc = do-	file' <- liftIO $ canonicalize file-	cts <- maybe (liftIO $ readFileUtf8 file') return msrc-	(flags, classify, hint) <- liftIO $ argsSettings opts-	p <- liftIO $ parseModuleEx (flags { cppFlags = CppSimple }) file' (Just $ T.unpack cts)-	m <- either (throwError . parseErrorMessage) return p-	return $ map (recalcTabs cts 8 . indentIdea cts . fromIdea) $-		filter (not . ignoreIdea) $-		applyHints classify hint [m]--ignoreIdea :: Idea -> Bool-ignoreIdea idea = ideaSeverity idea == HL.Ignore--fromIdea :: Idea -> Note OutputMessage-fromIdea idea = Note {-	_noteSource = FileModule (fromFilePath $ srcSpanFilename src) Nothing,-	_noteRegion = Region (Position (srcSpanStartLine src) (srcSpanStartColumn src)) (Position (srcSpanEndLine src) (srcSpanEndColumn src)),-	_noteLevel = Just $ case ideaSeverity idea of-		HL.Warning -> Warning-		HL.Error -> Error-		_ -> Hint,-	_note = OutputMessage {-		_message = fromString $ ideaHint idea,-		_messageSuggestion = fmap fromString $ ideaTo idea } }-	where-		src = ideaSpan idea--indentIdea :: Text -> Note OutputMessage -> Note OutputMessage-indentIdea cts idea = case analyzeIndent cts of-	Nothing -> idea-	Just i -> over (note . messageSuggestion . _Just) (indent' i) idea-	where-		indent' i' = T.intercalate (fromString "\n") . indentTail . map (uncurry T.append . first ((`T.replicate` i') . (`div` 2) . T.length) . T.span isSpace) . T.split (== '\n')-		indentTail [] = []-		indentTail (h : hs) = h : map (firstIndent `T.append`) hs-		firstIndent = T.takeWhile isSpace firstLine-		firstLine = regionStr (Position firstLineNum 1 `region` Position (succ firstLineNum) 1) cts-		firstLineNum = view (noteRegion . regionFrom . positionLine) idea---- | Indent in source-data Indent = Spaces Int | Tabs deriving (Eq, Ord)--instance Show Indent where-	show (Spaces n) = replicate n ' '-	show Tabs = "\t"---- | Analyze source indentation to convert suggestion to same indentation--- Returns one indent-analyzeIndent :: Text -> Maybe Text-analyzeIndent =-	fmap (fromString . show) . selectIndent . map fst . dropUnusual .-	sortBy (comparing $ negate . snd) .-	map (head &&& length) .-	group . sort .-	mapMaybe (guessIndent . T.takeWhile isSpace) . T.lines-	where-		selectIndent :: [Indent] -> Maybe Indent-		selectIndent [] = Nothing-		selectIndent (Tabs : _) = Just Tabs-		selectIndent indents = Just $ Spaces $ foldr1 gcd $ mapMaybe spaces indents where-			spaces :: Indent -> Maybe Int-			spaces Tabs = Nothing-			spaces (Spaces n) = Just n-		dropUnusual :: [(Indent, Int)] -> [(Indent, Int)]-		dropUnusual [] = []-		dropUnusual is@((_, freq):_) = takeWhile ((> freq `div` 5) . snd) is---- | Guess indent of one line-guessIndent :: Text -> Maybe Indent-guessIndent s-	| T.all (== ' ') s = Just $ Spaces $ T.length s-	| T.all (== '\t') s = Just Tabs-	| otherwise = Nothing+module HsDev.Tools.HLint (
+	hlint,
+
+	module Control.Monad.Except
+	) where
+
+import Control.Arrow
+import Control.Lens (over, view, _Just)
+import Control.Monad.Except
+import Data.Char
+import Data.List
+import Data.Maybe (mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Ord
+import Data.String (fromString)
+import Language.Haskell.HLint3 (argsSettings, parseModuleEx, applyHints, Idea(..), parseErrorMessage, ParseFlags(..), CppFlags(..))
+import Language.Haskell.Exts.SrcLoc
+import qualified Language.Haskell.HLint3 as HL (Severity(..))
+
+import System.Directory.Paths
+import HsDev.Symbols.Location
+import HsDev.Tools.Base
+import HsDev.Util (readFileUtf8)
+
+hlint :: [String] -> FilePath -> Maybe Text -> ExceptT String IO [Note OutputMessage]
+hlint opts file msrc = do
+	file' <- liftIO $ canonicalize file
+	cts <- maybe (liftIO $ readFileUtf8 file') return msrc
+	(flags, classify, hint) <- liftIO $ argsSettings opts
+	p <- liftIO $ parseModuleEx (flags { cppFlags = CppSimple }) file' (Just $ T.unpack cts)
+	m <- either (throwError . parseErrorMessage) return p
+	return $ map (recalcTabs cts 8 . indentIdea cts . fromIdea) $
+		filter (not . ignoreIdea) $
+		applyHints classify hint [m]
+
+ignoreIdea :: Idea -> Bool
+ignoreIdea idea = ideaSeverity idea == HL.Ignore
+
+fromIdea :: Idea -> Note OutputMessage
+fromIdea idea = Note {
+	_noteSource = FileModule (fromFilePath $ srcSpanFilename src) Nothing,
+	_noteRegion = Region (Position (srcSpanStartLine src) (srcSpanStartColumn src)) (Position (srcSpanEndLine src) (srcSpanEndColumn src)),
+	_noteLevel = Just $ case ideaSeverity idea of
+		HL.Warning -> Warning
+		HL.Error -> Error
+		_ -> Hint,
+	_note = OutputMessage {
+		_message = fromString $ ideaHint idea,
+		_messageSuggestion = fmap fromString $ ideaTo idea } }
+	where
+		src = ideaSpan idea
+
+indentIdea :: Text -> Note OutputMessage -> Note OutputMessage
+indentIdea cts idea = case analyzeIndent cts of
+	Nothing -> idea
+	Just i -> over (note . messageSuggestion . _Just) (indent' i) idea
+	where
+		indent' i' = T.intercalate (fromString "\n") . indentTail . map (uncurry T.append . first ((`T.replicate` i') . (`div` 2) . T.length) . T.span isSpace) . T.split (== '\n')
+		indentTail [] = []
+		indentTail (h : hs) = h : map (firstIndent `T.append`) hs
+		firstIndent = T.takeWhile isSpace firstLine
+		firstLine = regionStr (Position firstLineNum 1 `region` Position (succ firstLineNum) 1) cts
+		firstLineNum = view (noteRegion . regionFrom . positionLine) idea
+
+-- | Indent in source
+data Indent = Spaces Int | Tabs deriving (Eq, Ord)
+
+instance Show Indent where
+	show (Spaces n) = replicate n ' '
+	show Tabs = "\t"
+
+-- | Analyze source indentation to convert suggestion to same indentation
+-- Returns one indent
+analyzeIndent :: Text -> Maybe Text
+analyzeIndent =
+	fmap (fromString . show) . selectIndent . map fst . dropUnusual .
+	sortBy (comparing $ negate . snd) .
+	map (head &&& length) .
+	group . sort .
+	mapMaybe (guessIndent . T.takeWhile isSpace) . T.lines
+	where
+		selectIndent :: [Indent] -> Maybe Indent
+		selectIndent [] = Nothing
+		selectIndent (Tabs : _) = Just Tabs
+		selectIndent indents = Just $ Spaces $ foldr1 gcd $ mapMaybe spaces indents where
+			spaces :: Indent -> Maybe Int
+			spaces Tabs = Nothing
+			spaces (Spaces n) = Just n
+		dropUnusual :: [(Indent, Int)] -> [(Indent, Int)]
+		dropUnusual [] = []
+		dropUnusual is@((_, freq):_) = takeWhile ((> freq `div` 5) . snd) is
+
+-- | Guess indent of one line
+guessIndent :: Text -> Maybe Indent
+guessIndent s
+	| T.all (== ' ') s = Just $ Spaces $ T.length s
+	| T.all (== '\t') s = Just Tabs
+	| otherwise = Nothing
src/HsDev/Tools/Hayoo.hs view
@@ -1,139 +1,139 @@-{-# LANGUAGE OverloadedStrings #-}--module HsDev.Tools.Hayoo (-	-- * Types-	HayooResult(..), HayooSymbol(..),-	hayooAsSymbol,-	-- * Search help online-	hayoo,-	-- * Utils-	untagDescription,--	-- * Reexportss-	module Control.Monad.Except-	) where--import Control.Arrow-import Control.Applicative-import Control.Lens (lens)-import Control.Monad.Except--import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Either-import Data.Maybe (listToMaybe, fromJust)-import Network.HTTP-import Data.String (fromString)-import qualified Data.Text as T (unpack, unlines)--import HsDev.Symbols-import HsDev.Tools.Base (replaceRx)-import HsDev.Util---- | Hayoo response-data HayooResult = HayooResult {-	resultMax :: Int,-	resultOffset :: Int,-	resultCount :: Int,-	resultResult :: [HayooSymbol] }-		deriving (Eq, Ord, Read, Show)---- | Hayoo symbol-data HayooSymbol = HayooSymbol {-	resultUri :: String,-	tag :: String,-	hayooPackage :: String,-	hayooName :: String,-	hayooSource :: String,-	hayooDescription :: String,-	hayooSignature :: String,-	hayooModules :: [String],-	hayooScore :: Double,-	hayooType :: String }-		deriving (Eq, Ord, Read, Show)--newtype HayooValue = HayooValue { hayooValue :: Either Value HayooSymbol }--instance FromJSON HayooResult where-	parseJSON = withObject "hayoo response" $ \v -> HayooResult <$>-		(v .:: "max") <*>-		(v .:: "offset") <*>-		(v .:: "count") <*>-		((rights . map hayooValue) <$> (v .:: "result"))--instance Sourced HayooSymbol where-	sourcedName = lens g' s' where-		g' = fromString . hayooName-		s' sym n = sym { hayooName = T.unpack n }-	sourcedModule = lens g' s' where-		g' h = ModuleId nm (OtherLocation $ fromString $ resultUri h) where-			nm = maybe mempty fromString $ listToMaybe $ hayooModules h-		s' h _ = h-	sourcedDocs f h = (\d' -> h { hayooDescription = T.unpack d' }) <$> f (fromString $ hayooDescription h)--instance Documented HayooSymbol where-	brief f-		| hayooType f == "function" = fromString $ hayooName f ++ " :: " ++ hayooSignature f-		| otherwise = fromString $ hayooType f ++ " " ++ hayooName f-	detailed f = T.unlines $ defaultDetailed f ++ map fromString online where-		online = [-			"", "Hayoo online documentation", "",-			"Package: " ++ hayooPackage f,-			"Hackage URL: " ++ resultUri f]--instance FromJSON HayooSymbol where-	parseJSON = withObject "symbol" $ \v -> HayooSymbol <$>-		(v .:: "resultUri") <*>-		(v .:: "tag") <*>-		(v .:: "resultPackage") <*>-		(v .:: "resultName") <*>-		(v .:: "resultSource") <*>-		(v .:: "resultDescription") <*>-		(v .:: "resultSignature") <*>-		(v .:: "resultModules") <*>-		(v .:: "resultScore") <*>-		(v .:: "resultType")--instance FromJSON HayooValue where-	parseJSON v = HayooValue <$> ((Right <$> parseJSON v) <|> pure (Left v))---- | 'HayooFunction' as 'Symbol'-hayooAsSymbol :: HayooSymbol -> Maybe Symbol-hayooAsSymbol f-	| hayooType f `elem` ["function", "type", "newtype", "data", "class"] = Just Symbol {-		_symbolId = SymbolId {-			_symbolName = fromString $ hayooName f,-			_symbolModule = ModuleId {-				_moduleName = fromString $ head $ hayooModules f,-				_moduleLocation = OtherLocation (fromString $ resultUri f) } },-		_symbolDocs = Just (fromString $ addOnline $ untagDescription $ hayooDescription f),-		_symbolPosition = Nothing,-		_symbolInfo = info }-	| otherwise = Nothing-	where-		-- Add other info-		addOnline d = unlines [-			d, "",-			"Hayoo online documentation",-			"",-			"Package: " ++ hayooPackage f,-			"Hackage URL: " ++ resultUri f]--		info-			| hayooType f == "function" = Function (Just $ fromString $ hayooSignature f)-			| hayooType f `elem` ["type", "newtype", "data", "class"] = (fromJust $ lookup (hayooType f) ctors) [] []-			| otherwise = error "Impossible"-		ctors = [("type", Type), ("newtype", NewType), ("data", Data), ("class", Class)]---- | Search hayoo-hayoo :: String -> Maybe Int -> ExceptT String IO HayooResult-hayoo q page = do-	resp <- ExceptT $ (show +++ rspBody) <$> simpleHTTP (getRequest $ maybe id addPage page $ "http://hayoo.fh-wedel.de/json/?query=" ++ urlEncode q)-	ExceptT $ return $ eitherDecode $ L.pack resp-	where-		addPage :: Int -> String -> String-		addPage p s = s ++ "&page=" ++ show p---- | Remove tags in description-untagDescription :: String -> String-untagDescription = replaceRx "</?\\w+[^>]*>" ""+{-# LANGUAGE OverloadedStrings #-}
+
+module HsDev.Tools.Hayoo (
+	-- * Types
+	HayooResult(..), HayooSymbol(..),
+	hayooAsSymbol,
+	-- * Search help online
+	hayoo,
+	-- * Utils
+	untagDescription,
+
+	-- * Reexportss
+	module Control.Monad.Except
+	) where
+
+import Control.Arrow
+import Control.Applicative
+import Control.Lens (lens)
+import Control.Monad.Except
+
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Either
+import Data.Maybe (listToMaybe, fromJust)
+import Network.HTTP
+import Data.String (fromString)
+import qualified Data.Text as T (unpack, unlines)
+
+import HsDev.Symbols
+import HsDev.Tools.Base (replaceRx)
+import HsDev.Util
+
+-- | Hayoo response
+data HayooResult = HayooResult {
+	resultMax :: Int,
+	resultOffset :: Int,
+	resultCount :: Int,
+	resultResult :: [HayooSymbol] }
+		deriving (Eq, Ord, Read, Show)
+
+-- | Hayoo symbol
+data HayooSymbol = HayooSymbol {
+	resultUri :: String,
+	tag :: String,
+	hayooPackage :: String,
+	hayooName :: String,
+	hayooSource :: String,
+	hayooDescription :: String,
+	hayooSignature :: String,
+	hayooModules :: [String],
+	hayooScore :: Double,
+	hayooType :: String }
+		deriving (Eq, Ord, Read, Show)
+
+newtype HayooValue = HayooValue { hayooValue :: Either Value HayooSymbol }
+
+instance FromJSON HayooResult where
+	parseJSON = withObject "hayoo response" $ \v -> HayooResult <$>
+		(v .:: "max") <*>
+		(v .:: "offset") <*>
+		(v .:: "count") <*>
+		((rights . map hayooValue) <$> (v .:: "result"))
+
+instance Sourced HayooSymbol where
+	sourcedName = lens g' s' where
+		g' = fromString . hayooName
+		s' sym n = sym { hayooName = T.unpack n }
+	sourcedModule = lens g' s' where
+		g' h = ModuleId nm (OtherLocation $ fromString $ resultUri h) where
+			nm = maybe mempty fromString $ listToMaybe $ hayooModules h
+		s' h _ = h
+	sourcedDocs f h = (\d' -> h { hayooDescription = T.unpack d' }) <$> f (fromString $ hayooDescription h)
+
+instance Documented HayooSymbol where
+	brief f
+		| hayooType f == "function" = fromString $ hayooName f ++ " :: " ++ hayooSignature f
+		| otherwise = fromString $ hayooType f ++ " " ++ hayooName f
+	detailed f = T.unlines $ defaultDetailed f ++ map fromString online where
+		online = [
+			"", "Hayoo online documentation", "",
+			"Package: " ++ hayooPackage f,
+			"Hackage URL: " ++ resultUri f]
+
+instance FromJSON HayooSymbol where
+	parseJSON = withObject "symbol" $ \v -> HayooSymbol <$>
+		(v .:: "resultUri") <*>
+		(v .:: "tag") <*>
+		(v .:: "resultPackage") <*>
+		(v .:: "resultName") <*>
+		(v .:: "resultSource") <*>
+		(v .:: "resultDescription") <*>
+		(v .:: "resultSignature") <*>
+		(v .:: "resultModules") <*>
+		(v .:: "resultScore") <*>
+		(v .:: "resultType")
+
+instance FromJSON HayooValue where
+	parseJSON v = HayooValue <$> ((Right <$> parseJSON v) <|> pure (Left v))
+
+-- | 'HayooFunction' as 'Symbol'
+hayooAsSymbol :: HayooSymbol -> Maybe Symbol
+hayooAsSymbol f
+	| hayooType f `elem` ["function", "type", "newtype", "data", "class"] = Just Symbol {
+		_symbolId = SymbolId {
+			_symbolName = fromString $ hayooName f,
+			_symbolModule = ModuleId {
+				_moduleName = fromString $ head $ hayooModules f,
+				_moduleLocation = OtherLocation (fromString $ resultUri f) } },
+		_symbolDocs = Just (fromString $ addOnline $ untagDescription $ hayooDescription f),
+		_symbolPosition = Nothing,
+		_symbolInfo = info }
+	| otherwise = Nothing
+	where
+		-- Add other info
+		addOnline d = unlines [
+			d, "",
+			"Hayoo online documentation",
+			"",
+			"Package: " ++ hayooPackage f,
+			"Hackage URL: " ++ resultUri f]
+
+		info
+			| hayooType f == "function" = Function (Just $ fromString $ hayooSignature f)
+			| hayooType f `elem` ["type", "newtype", "data", "class"] = (fromJust $ lookup (hayooType f) ctors) [] []
+			| otherwise = error "Impossible"
+		ctors = [("type", Type), ("newtype", NewType), ("data", Data), ("class", Class)]
+
+-- | Search hayoo
+hayoo :: String -> Maybe Int -> ExceptT String IO HayooResult
+hayoo q page = do
+	resp <- ExceptT $ (show +++ rspBody) <$> simpleHTTP (getRequest $ maybe id addPage page $ "http://hayoo.fh-wedel.de/json/?query=" ++ urlEncode q)
+	ExceptT $ return $ eitherDecode $ L.pack resp
+	where
+		addPage :: Int -> String -> String
+		addPage p s = s ++ "&page=" ++ show p
+
+-- | Remove tags in description
+untagDescription :: String -> String
+untagDescription = replaceRx "</?\\w+[^>]*>" ""
src/HsDev/Tools/Refact.hs view
@@ -1,53 +1,53 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}--module HsDev.Tools.Refact (-	Refact(..), refactMessage, refactAction,-	refact, update,--	replace, cut, paste,--	fromRegion, fromPosition-	) where--import Control.Lens hiding ((.=))-import Data.Aeson-import Data.Text (Text)-import Data.Text.Region hiding (Region(..), update)-import qualified Data.Text.Region as R--import HsDev.Symbols.Location-import HsDev.Util--data Refact = Refact {-	_refactMessage :: Text,-	_refactAction :: Replace Text }-		deriving (Eq, Show)--instance ToJSON Refact where-	toJSON (Refact msg cor) = object [-		"message" .= msg,-		"action" .= cor]--instance FromJSON Refact where-	parseJSON = withObject "correction" $ \v -> Refact <$>-		v .:: "message" <*>-		v .:: "action"--makeLenses ''Refact--instance Regioned Refact where-	regions = refactAction . regions--refact :: [Refact] -> Text -> Text-refact rs = apply act where-	act = Edit (rs ^.. each . refactAction)--update :: Regioned a => [Refact] -> [a] -> [a]-update rs = map (R.update act) where-	act = Edit (rs ^.. each . refactAction)--fromRegion :: Region -> R.Region-fromRegion (Region f t) = fromPosition f `till` fromPosition t--fromPosition :: Position -> Point-fromPosition (Position l c) = pt (pred l) (pred c)+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module HsDev.Tools.Refact (
+	Refact(..), refactMessage, refactAction,
+	refact, update,
+
+	replace, cut, paste,
+
+	fromRegion, fromPosition
+	) where
+
+import Control.Lens hiding ((.=))
+import Data.Aeson
+import Data.Text (Text)
+import Data.Text.Region hiding (Region(..), update)
+import qualified Data.Text.Region as R
+
+import HsDev.Symbols.Location
+import HsDev.Util
+
+data Refact = Refact {
+	_refactMessage :: Text,
+	_refactAction :: Replace Text }
+		deriving (Eq, Show)
+
+instance ToJSON Refact where
+	toJSON (Refact msg cor) = object [
+		"message" .= msg,
+		"action" .= cor]
+
+instance FromJSON Refact where
+	parseJSON = withObject "correction" $ \v -> Refact <$>
+		v .:: "message" <*>
+		v .:: "action"
+
+makeLenses ''Refact
+
+instance Regioned Refact where
+	regions = refactAction . regions
+
+refact :: [Refact] -> Text -> Text
+refact rs = apply act where
+	act = Edit (rs ^.. each . refactAction)
+
+update :: Regioned a => [Refact] -> [a] -> [a]
+update rs = map (R.update act) where
+	act = Edit (rs ^.. each . refactAction)
+
+fromRegion :: Region -> R.Region
+fromRegion (Region f t) = fromPosition f `till` fromPosition t
+
+fromPosition :: Position -> Point
+fromPosition (Position l c) = pt (pred l) (pred c)
src/HsDev/Tools/Tabs.hs view
@@ -1,30 +1,30 @@-module HsDev.Tools.Tabs (-	recalcNotesTabs-	) where--import Control.Lens-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import Data.Text (Text)--import System.Directory.Paths-import HsDev.Symbols.Location-import HsDev.Tools.Types-import HsDev.Util---- | Some tools counts tab as 8 symbols and return such file positions; convert them (consider tab = one symbol)-recalcNotesTabs :: Map Path Text -> [Note a] -> IO [Note a]-recalcNotesTabs srcs notes = do-	ctsMap <- fmap M.fromList $ mapM loadFileContents files-	let-		recalc' n = fromMaybe n $ do-			fname <- preview (noteSource . moduleFile) n-			cts' <- M.lookup fname ctsMap-			return $ recalcTabs cts' 8 n-	return $ map recalc' notes-	where-		files = ordNub $ notes ^.. each . noteSource . moduleFile-		loadFileContents f = do-			cts <- maybe (readFileUtf8 $ view path f) return $ M.lookup f srcs-			return (f, cts)+module HsDev.Tools.Tabs (
+	recalcNotesTabs
+	) where
+
+import Control.Lens
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+
+import System.Directory.Paths
+import HsDev.Symbols.Location
+import HsDev.Tools.Types
+import HsDev.Util
+
+-- | Some tools counts tab as 8 symbols and return such file positions; convert them (consider tab = one symbol)
+recalcNotesTabs :: Map Path Text -> [Note a] -> IO [Note a]
+recalcNotesTabs srcs notes = do
+	ctsMap <- fmap M.fromList $ mapM loadFileContents files
+	let
+		recalc' n = fromMaybe n $ do
+			fname <- preview (noteSource . moduleFile) n
+			cts' <- M.lookup fname ctsMap
+			return $ recalcTabs cts' 8 n
+	return $ map recalc' notes
+	where
+		files = ordNub $ notes ^.. each . noteSource . moduleFile
+		loadFileContents f = do
+			cts <- maybe (readFileUtf8 $ view path f) return $ M.lookup f srcs
+			return (f, cts)
src/HsDev/Tools/Types.hs view
@@ -1,100 +1,100 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}--module HsDev.Tools.Types (-	Severity(..),-	Note(..), noteSource, noteRegion, noteLevel, note,-	OutputMessage(..), message, messageSuggestion, outputMessage-	) where--import Control.DeepSeq (NFData(..))-import Control.Lens (makeLenses)-import Control.Monad-import Data.Aeson hiding (Error)-import Data.Text (Text)--import System.Directory.Paths-import HsDev.Symbols.Location-import HsDev.Util ((.::), (.::?), noNulls)---- | Note severity-data Severity = Error | Warning | Hint deriving (Enum, Bounded, Eq, Ord, Read, Show)--instance NFData Severity where-	rnf Error = ()-	rnf Warning = ()-	rnf Hint = ()--instance ToJSON Severity where-	toJSON Error = toJSON ("error" :: String)-	toJSON Warning = toJSON ("warning" :: String)-	toJSON Hint = toJSON ("hint" :: String)--instance FromJSON Severity where-	parseJSON v = do-		s <- parseJSON v-		msum [-			guard (s == ("error" :: String)) >> return Error,-			guard (s == ("warning" :: String)) >> return Warning,-			guard (s == ("hint" :: String)) >> return Hint,-			fail $ "Unknown severity: " ++ s]---- | Note over some region-data Note a = Note {-	_noteSource :: ModuleLocation,-	_noteRegion :: Region,-	_noteLevel :: Maybe Severity,-	_note :: a }-		deriving (Eq, Show)--makeLenses ''Note--instance Functor Note where-	fmap f (Note s r l n) = Note s r l (f n)--instance NFData a => NFData (Note a) where-	rnf (Note s r l n) = rnf s `seq` rnf r `seq` rnf l `seq` rnf n--instance ToJSON a => ToJSON (Note a) where-	toJSON (Note s r l n) = object $ noNulls [-		"source" .= s,-		"region" .= r,-		"level" .= l,-		"note" .= n]--instance FromJSON a => FromJSON (Note a) where-	parseJSON = withObject "note" $ \v -> Note <$>-		v .:: "source" <*>-		v .:: "region" <*>-		v .::? "level" <*>-		v .:: "note"--instance RecalcTabs (Note a) where-	recalcTabs cts n' (Note s r l n) = Note s (recalcTabs cts n' r) l n-	calcTabs cts n' (Note s r l n) = Note s (calcTabs cts n' r) l n--instance Paths (Note a) where-	paths f (Note s r l n) = Note <$> paths f s <*> pure r <*> pure l <*> pure n---- | Output message from some tool (ghc, ghc-mod, hlint) with optional suggestion-data OutputMessage = OutputMessage {-	_message :: Text,-	_messageSuggestion :: Maybe Text }-		deriving (Eq, Ord, Read, Show)--instance NFData OutputMessage where-	rnf (OutputMessage m s) = rnf m `seq` rnf s--instance ToJSON OutputMessage where-	toJSON (OutputMessage m s) = object [-		"message" .= m,-		"suggestion" .= s]--instance FromJSON OutputMessage where-	parseJSON = withObject "output-message" $ \v -> OutputMessage <$>-		v .:: "message" <*>-		v .:: "suggestion"--outputMessage :: Text -> OutputMessage-outputMessage msg = OutputMessage msg Nothing--makeLenses ''OutputMessage+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module HsDev.Tools.Types (
+	Severity(..),
+	Note(..), noteSource, noteRegion, noteLevel, note,
+	OutputMessage(..), message, messageSuggestion, outputMessage
+	) where
+
+import Control.DeepSeq (NFData(..))
+import Control.Lens (makeLenses)
+import Control.Monad
+import Data.Aeson hiding (Error)
+import Data.Text (Text)
+
+import System.Directory.Paths
+import HsDev.Symbols.Location
+import HsDev.Util ((.::), (.::?), noNulls)
+
+-- | Note severity
+data Severity = Error | Warning | Hint deriving (Enum, Bounded, Eq, Ord, Read, Show)
+
+instance NFData Severity where
+	rnf Error = ()
+	rnf Warning = ()
+	rnf Hint = ()
+
+instance ToJSON Severity where
+	toJSON Error = toJSON ("error" :: String)
+	toJSON Warning = toJSON ("warning" :: String)
+	toJSON Hint = toJSON ("hint" :: String)
+
+instance FromJSON Severity where
+	parseJSON v = do
+		s <- parseJSON v
+		msum [
+			guard (s == ("error" :: String)) >> return Error,
+			guard (s == ("warning" :: String)) >> return Warning,
+			guard (s == ("hint" :: String)) >> return Hint,
+			fail $ "Unknown severity: " ++ s]
+
+-- | Note over some region
+data Note a = Note {
+	_noteSource :: ModuleLocation,
+	_noteRegion :: Region,
+	_noteLevel :: Maybe Severity,
+	_note :: a }
+		deriving (Eq, Show)
+
+makeLenses ''Note
+
+instance Functor Note where
+	fmap f (Note s r l n) = Note s r l (f n)
+
+instance NFData a => NFData (Note a) where
+	rnf (Note s r l n) = rnf s `seq` rnf r `seq` rnf l `seq` rnf n
+
+instance ToJSON a => ToJSON (Note a) where
+	toJSON (Note s r l n) = object $ noNulls [
+		"source" .= s,
+		"region" .= r,
+		"level" .= l,
+		"note" .= n]
+
+instance FromJSON a => FromJSON (Note a) where
+	parseJSON = withObject "note" $ \v -> Note <$>
+		v .:: "source" <*>
+		v .:: "region" <*>
+		v .::? "level" <*>
+		v .:: "note"
+
+instance RecalcTabs (Note a) where
+	recalcTabs cts n' (Note s r l n) = Note s (recalcTabs cts n' r) l n
+	calcTabs cts n' (Note s r l n) = Note s (calcTabs cts n' r) l n
+
+instance Paths (Note a) where
+	paths f (Note s r l n) = Note <$> paths f s <*> pure r <*> pure l <*> pure n
+
+-- | Output message from some tool (ghc, ghc-mod, hlint) with optional suggestion
+data OutputMessage = OutputMessage {
+	_message :: Text,
+	_messageSuggestion :: Maybe Text }
+		deriving (Eq, Ord, Read, Show)
+
+instance NFData OutputMessage where
+	rnf (OutputMessage m s) = rnf m `seq` rnf s
+
+instance ToJSON OutputMessage where
+	toJSON (OutputMessage m s) = object [
+		"message" .= m,
+		"suggestion" .= s]
+
+instance FromJSON OutputMessage where
+	parseJSON = withObject "output-message" $ \v -> OutputMessage <$>
+		v .:: "message" <*>
+		v .:: "suggestion"
+
+outputMessage :: Text -> OutputMessage
+outputMessage msg = OutputMessage msg Nothing
+
+makeLenses ''OutputMessage
src/HsDev/Types.hs view
@@ -1,133 +1,133 @@-{-# LANGUAGE OverloadedStrings #-}--module HsDev.Types (-	HsDevError(..)-	) where--import Control.Exception-import Control.DeepSeq (NFData(..))-import Data.Aeson-import Data.Aeson.Types (Pair, Parser)-import Data.Typeable-import Data.Text (Text)-import Text.Format--import HsDev.Symbols.Location-import System.Directory.Paths---- | hsdev exception type-data HsDevError =-	HsDevFailure |-	ModuleNotSource ModuleLocation |-	BrowseNoModuleInfo String |-	FileNotFound Path |-	ToolNotFound String |-	ProjectNotFound Text |-	PackageNotFound Text |-	ToolError String String |-	NotInspected ModuleLocation |-	InspectError String |-	InspectCabalError FilePath String |-	IOFailed String |-	GhcError String |-	RequestError String String |-	ResponseError String String |-	SQLiteError String |-	OtherError String |-	UnhandledError String-		deriving (Typeable)--instance NFData HsDevError where-	rnf HsDevFailure = ()-	rnf (ModuleNotSource mloc) = rnf mloc-	rnf (BrowseNoModuleInfo m) = rnf m-	rnf (FileNotFound f) = rnf f-	rnf (ToolNotFound t) = rnf t-	rnf (ProjectNotFound p) = rnf p-	rnf (PackageNotFound p) = rnf p-	rnf (ToolError t e) = rnf t `seq` rnf e-	rnf (NotInspected mloc) = rnf mloc-	rnf (InspectError e) = rnf e-	rnf (InspectCabalError c e) = rnf c `seq` rnf e-	rnf (IOFailed e) = rnf e-	rnf (GhcError e) = rnf e-	rnf (RequestError e r) = rnf e `seq` rnf r-	rnf (ResponseError e r) = rnf e `seq` rnf r-	rnf (SQLiteError e) = rnf e-	rnf (OtherError e) = rnf e-	rnf (UnhandledError e) = rnf e--instance Show HsDevError where-	show HsDevFailure = format "failure"-	show (ModuleNotSource mloc) = format "module is not source: {}" ~~ show mloc-	show (BrowseNoModuleInfo m) = format "can't find module info for {}" ~~ m-	show (FileNotFound f) = format "file '{}' not found" ~~ f-	show (ToolNotFound t) = format "tool '{}' not found" ~~ t-	show (ProjectNotFound p) = format "project '{}' not found" ~~ p-	show (PackageNotFound p) = format "package '{}' not found" ~~ p-	show (ToolError t e) = format "tool '{}' failed: {}" ~~ t ~~ e-	show (NotInspected mloc) = "module not inspected: {}" ~~ show mloc-	show (InspectError e) = format "failed to inspect: {}" ~~ e-	show (InspectCabalError c e) = format "failed to inspect cabal {}: {}" ~~ c ~~ e-	show (IOFailed e) = format "io exception: {}" ~~ e-	show (GhcError e) = format "ghc exception: {}" ~~ e-	show (RequestError e r) = format "request error: {}, request: {}" ~~ e ~~ r-	show (ResponseError e r) = format "response error: {}, response: {}" ~~ e ~~ r-	show (SQLiteError e) = format "sqlite error: {}" ~~ e-	show (OtherError e) = e-	show (UnhandledError e) = e--instance Monoid HsDevError where-	mempty = HsDevFailure-	mappend _ r = r--instance Formattable HsDevError where--jsonErr :: String -> [Pair] -> Value-jsonErr e = object . (("error" .= e) :)--instance ToJSON HsDevError where-	toJSON HsDevFailure = jsonErr "failure" []-	toJSON (ModuleNotSource mloc) = jsonErr "module is not source" ["module" .= mloc]-	toJSON (BrowseNoModuleInfo m) = jsonErr "no module info" ["module" .= m]-	toJSON (FileNotFound f) = jsonErr "file not found" ["file" .= f]-	toJSON (ToolNotFound t) = jsonErr "tool not found" ["tool" .= t]-	toJSON (ProjectNotFound p) = jsonErr "project not found" ["project" .= p]-	toJSON (PackageNotFound p) = jsonErr "package not found" ["package" .= p]-	toJSON (ToolError t e) = jsonErr "tool error" ["tool" .= t, "msg" .= e]-	toJSON (NotInspected mloc) = jsonErr "module not inspected" ["module" .= mloc]-	toJSON (InspectError e) = jsonErr "inspect error" ["msg" .= e]-	toJSON (InspectCabalError c e) = jsonErr "inspect cabal error" ["cabal" .= c, "msg" .= e]-	toJSON (IOFailed e) = jsonErr "io error" ["msg" .= e]-	toJSON (GhcError e) = jsonErr "ghc error" ["msg" .= e]-	toJSON (RequestError e r) = jsonErr "request error" ["msg" .= e, "request" .= r]-	toJSON (ResponseError e r) = jsonErr "response error" ["msg" .= e, "response" .= r]-	toJSON (SQLiteError e) = jsonErr "sqlite error" ["msg" .= e]-	toJSON (OtherError e) = jsonErr "other error" ["msg" .= e]-	toJSON (UnhandledError e) = jsonErr "unhandled error" ["msg" .= e]--instance FromJSON HsDevError where-	parseJSON = withObject "hsdev-error" $ \v -> do-		err <- v .: "error" :: Parser String-		case err of-			"failure" -> pure HsDevFailure-			"module is not source" -> ModuleNotSource <$> v .: "module"-			"no module info" -> BrowseNoModuleInfo <$> v .: "module"-			"file not found" -> FileNotFound <$> v .: "file"-			"tool not found" -> ToolNotFound <$> v .: "tool"-			"project not found" -> ProjectNotFound <$> v .: "project"-			"package not found" -> PackageNotFound <$> v .: "package"-			"tool error" -> ToolError <$> v .: "tool" <*> v .: "msg"-			"module not inspected" -> NotInspected <$> v .: "module"-			"inspect error" -> InspectError <$> v .: "msg"-			"inspect cabal error" -> InspectCabalError <$> v .: "cabal" <*> v .: "msg"-			"io error" -> IOFailed <$> v .: "msg"-			"ghc error" -> GhcError <$> v .: "msg"-			"request error" -> RequestError <$> v .: "msg" <*> v .: "request"-			"response error" -> ResponseError <$> v .: "msg" <*> v .: "response"-			"sqlite error" -> SQLiteError <$> v .: "msg"-			"other error" -> OtherError <$> v .: "msg"-			"unhandled error" -> UnhandledError <$> v .: "msg"-			_ -> fail "invalid error"--instance Exception HsDevError+{-# LANGUAGE OverloadedStrings #-}
+
+module HsDev.Types (
+	HsDevError(..)
+	) where
+
+import Control.Exception
+import Control.DeepSeq (NFData(..))
+import Data.Aeson
+import Data.Aeson.Types (Pair, Parser)
+import Data.Typeable
+import Data.Text (Text)
+import Text.Format
+
+import HsDev.Symbols.Location
+import System.Directory.Paths
+
+-- | hsdev exception type
+data HsDevError =
+	HsDevFailure |
+	ModuleNotSource ModuleLocation |
+	BrowseNoModuleInfo String |
+	FileNotFound Path |
+	ToolNotFound String |
+	ProjectNotFound Text |
+	PackageNotFound Text |
+	ToolError String String |
+	NotInspected ModuleLocation |
+	InspectError String |
+	InspectCabalError FilePath String |
+	IOFailed String |
+	GhcError String |
+	RequestError String String |
+	ResponseError String String |
+	SQLiteError String |
+	OtherError String |
+	UnhandledError String
+		deriving (Typeable)
+
+instance NFData HsDevError where
+	rnf HsDevFailure = ()
+	rnf (ModuleNotSource mloc) = rnf mloc
+	rnf (BrowseNoModuleInfo m) = rnf m
+	rnf (FileNotFound f) = rnf f
+	rnf (ToolNotFound t) = rnf t
+	rnf (ProjectNotFound p) = rnf p
+	rnf (PackageNotFound p) = rnf p
+	rnf (ToolError t e) = rnf t `seq` rnf e
+	rnf (NotInspected mloc) = rnf mloc
+	rnf (InspectError e) = rnf e
+	rnf (InspectCabalError c e) = rnf c `seq` rnf e
+	rnf (IOFailed e) = rnf e
+	rnf (GhcError e) = rnf e
+	rnf (RequestError e r) = rnf e `seq` rnf r
+	rnf (ResponseError e r) = rnf e `seq` rnf r
+	rnf (SQLiteError e) = rnf e
+	rnf (OtherError e) = rnf e
+	rnf (UnhandledError e) = rnf e
+
+instance Show HsDevError where
+	show HsDevFailure = format "failure"
+	show (ModuleNotSource mloc) = format "module is not source: {}" ~~ show mloc
+	show (BrowseNoModuleInfo m) = format "can't find module info for {}" ~~ m
+	show (FileNotFound f) = format "file '{}' not found" ~~ f
+	show (ToolNotFound t) = format "tool '{}' not found" ~~ t
+	show (ProjectNotFound p) = format "project '{}' not found" ~~ p
+	show (PackageNotFound p) = format "package '{}' not found" ~~ p
+	show (ToolError t e) = format "tool '{}' failed: {}" ~~ t ~~ e
+	show (NotInspected mloc) = "module not inspected: {}" ~~ show mloc
+	show (InspectError e) = format "failed to inspect: {}" ~~ e
+	show (InspectCabalError c e) = format "failed to inspect cabal {}: {}" ~~ c ~~ e
+	show (IOFailed e) = format "io exception: {}" ~~ e
+	show (GhcError e) = format "ghc exception: {}" ~~ e
+	show (RequestError e r) = format "request error: {}, request: {}" ~~ e ~~ r
+	show (ResponseError e r) = format "response error: {}, response: {}" ~~ e ~~ r
+	show (SQLiteError e) = format "sqlite error: {}" ~~ e
+	show (OtherError e) = e
+	show (UnhandledError e) = e
+
+instance Monoid HsDevError where
+	mempty = HsDevFailure
+	mappend _ r = r
+
+instance Formattable HsDevError where
+
+jsonErr :: String -> [Pair] -> Value
+jsonErr e = object . (("error" .= e) :)
+
+instance ToJSON HsDevError where
+	toJSON HsDevFailure = jsonErr "failure" []
+	toJSON (ModuleNotSource mloc) = jsonErr "module is not source" ["module" .= mloc]
+	toJSON (BrowseNoModuleInfo m) = jsonErr "no module info" ["module" .= m]
+	toJSON (FileNotFound f) = jsonErr "file not found" ["file" .= f]
+	toJSON (ToolNotFound t) = jsonErr "tool not found" ["tool" .= t]
+	toJSON (ProjectNotFound p) = jsonErr "project not found" ["project" .= p]
+	toJSON (PackageNotFound p) = jsonErr "package not found" ["package" .= p]
+	toJSON (ToolError t e) = jsonErr "tool error" ["tool" .= t, "msg" .= e]
+	toJSON (NotInspected mloc) = jsonErr "module not inspected" ["module" .= mloc]
+	toJSON (InspectError e) = jsonErr "inspect error" ["msg" .= e]
+	toJSON (InspectCabalError c e) = jsonErr "inspect cabal error" ["cabal" .= c, "msg" .= e]
+	toJSON (IOFailed e) = jsonErr "io error" ["msg" .= e]
+	toJSON (GhcError e) = jsonErr "ghc error" ["msg" .= e]
+	toJSON (RequestError e r) = jsonErr "request error" ["msg" .= e, "request" .= r]
+	toJSON (ResponseError e r) = jsonErr "response error" ["msg" .= e, "response" .= r]
+	toJSON (SQLiteError e) = jsonErr "sqlite error" ["msg" .= e]
+	toJSON (OtherError e) = jsonErr "other error" ["msg" .= e]
+	toJSON (UnhandledError e) = jsonErr "unhandled error" ["msg" .= e]
+
+instance FromJSON HsDevError where
+	parseJSON = withObject "hsdev-error" $ \v -> do
+		err <- v .: "error" :: Parser String
+		case err of
+			"failure" -> pure HsDevFailure
+			"module is not source" -> ModuleNotSource <$> v .: "module"
+			"no module info" -> BrowseNoModuleInfo <$> v .: "module"
+			"file not found" -> FileNotFound <$> v .: "file"
+			"tool not found" -> ToolNotFound <$> v .: "tool"
+			"project not found" -> ProjectNotFound <$> v .: "project"
+			"package not found" -> PackageNotFound <$> v .: "package"
+			"tool error" -> ToolError <$> v .: "tool" <*> v .: "msg"
+			"module not inspected" -> NotInspected <$> v .: "module"
+			"inspect error" -> InspectError <$> v .: "msg"
+			"inspect cabal error" -> InspectCabalError <$> v .: "cabal" <*> v .: "msg"
+			"io error" -> IOFailed <$> v .: "msg"
+			"ghc error" -> GhcError <$> v .: "msg"
+			"request error" -> RequestError <$> v .: "msg" <*> v .: "request"
+			"response error" -> ResponseError <$> v .: "msg" <*> v .: "response"
+			"sqlite error" -> SQLiteError <$> v .: "msg"
+			"other error" -> OtherError <$> v .: "msg"
+			"unhandled error" -> UnhandledError <$> v .: "msg"
+			_ -> fail "invalid error"
+
+instance Exception HsDevError
src/HsDev/Util.hs view
@@ -1,322 +1,317 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings, TemplateHaskell, CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Util (-	withCurrentDirectory,-	directoryContents,-	traverseDirectory, searchPath,-	haskellSource,-	cabalFile,-	-- * String utils-	tab,-	trim, split,-	-- * Other utils-	ordNub, uniqueBy, mapBy,-	-- * Helper-	(.::), (.::?), (.::?!), objectUnion, noNulls, fromJSON',-	-- * Exceptions-	liftException, liftE, tries, triesMap, liftExceptionM, liftIOErrors,-	logAll,-	-- * UTF-8-	fromUtf8, toUtf8, readFileUtf8, writeFileUtf8,-	-- * IO-	hGetLineBS, logIO, ignoreIO, logAsync,-	-- * Command line-	FromCmd(..),-	cmdJson, guardCmd,-	withHelp, cmd, parseArgs,-	-- * Version stuff-	version,-	-- * Parse-	parseDT,--	-- * Log utils-	timer,--	-- * Reexportss-	module Control.Monad.Except,-	MonadIO(..)-	) where--import Control.Arrow (second, left, (&&&))-import Control.Exception-import Control.DeepSeq-import Control.Monad-import Control.Monad.Except-import qualified Control.Monad.Catch as C-import Data.Aeson hiding (Result(..), Error)-import qualified Data.Aeson.Types as A-import Data.Char (isSpace)-import Data.List (unfoldr)-import qualified Data.Map.Strict as M-import Data.Maybe (catMaybes, fromMaybe)-import Data.Monoid ((<>))-import qualified Data.Set as Set-import qualified Data.HashMap.Strict as HM (HashMap, toList, union)-import qualified Data.ByteString.Char8 as B-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Text (Text)-import qualified Data.Text.IO as ST-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as T-import Data.Time.Clock.POSIX-import Distribution.Text (simpleParse)-import qualified Distribution.Text (Text)-import Options.Applicative-import qualified System.Directory as Dir-import System.FilePath-import System.Log.Simple-import System.IO-import Text.Format-import Text.Read (readMaybe)--#if !MIN_VERSION_directory(1,2,6)-#if mingw32_HOST_OS-import qualified System.Win32 as Win32-import Data.Bits ((.&.))-#else-import qualified System.Posix as Posix-#endif-#endif--import HsDev.Version---- | Run action with current directory set-withCurrentDirectory :: (MonadIO m, C.MonadMask m) => FilePath -> m a -> m a-withCurrentDirectory cur act = C.bracket (liftIO Dir.getCurrentDirectory) (liftIO . Dir.setCurrentDirectory) $-	const (liftIO (Dir.setCurrentDirectory cur) >> act)---- | Is directory symbolic link-dirIsSymLink :: FilePath -> IO Bool-#if MIN_VERSION_directory(1,3,0)-dirIsSymLink = Dir.pathIsSymbolicLink-#elif MIN_VERSION_directory(1,2,6)-dirIsSymLink = Dir.isSymbolicLink-#else-dirIsSymLink path = do-#if mingw32_HOST_OS-	isReparsePoint <$> Win32.getFileAttributes path-	where-		fILE_ATTRIBUTE_REPARSE_POINT = 0x400-		isReparsePoint attr = attr .&. fILE_ATTRIBUTE_REPARSE_POINT /= 0-#else-	Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path-#endif-#endif---- | Get directory contents safely: no fail, ignoring symbolic links, also prepends paths with dir name-directoryContents :: FilePath -> IO [FilePath]-directoryContents p = handle ignore $ do-	b <- Dir.doesDirectoryExist p-	isLink <- dirIsSymLink p-	if b && (not isLink)-		then liftM (map (p </>) . filter (`notElem` [".", ".."])) (Dir.getDirectoryContents p)-		else return []-	where-		ignore :: SomeException -> IO [FilePath]-		ignore _ = return []---- | Collect all file names in directory recursively-traverseDirectory :: FilePath -> IO [FilePath]-traverseDirectory p = handle onError $ do-	cts <- directoryContents p-	liftM concat $ forM cts $ \c -> do-		isDir <- Dir.doesDirectoryExist c-		if isDir-			then (c :) <$> traverseDirectory c-			else return [c]-	where-		onError :: IOException -> IO [FilePath]-		onError _ = return []---- | Search something up-searchPath :: (MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m a) -> m a-searchPath p f = do-	p' <- liftIO $ Dir.canonicalizePath p-	isDir <- liftIO $ Dir.doesDirectoryExist p'-	search' (if isDir then p' else takeDirectory p')-	where-		search' dir-			| isDrive dir = f dir-			| otherwise = f dir `mplus` search' (takeDirectory dir)---- | Is haskell source?-haskellSource :: FilePath -> Bool-haskellSource f = takeExtension f `elem` [".hs", ".lhs"]---- | Is cabal file?-cabalFile :: FilePath -> Bool-cabalFile f = takeExtension f == ".cabal"---- | Add N tabs to line-tab :: Int -> String -> String-tab n s = replicate n '\t' ++ s---- | Trim string-trim :: String -> String-trim = p . p where-	p = reverse . dropWhile isSpace---- | Split list-split :: (a -> Bool) -> [a] -> [[a]]-split p = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break p)---- | nub is quadratic, https://github.com/nh2/haskell-ordnub/#ordnub-ordNub :: Ord a => [a] -> [a]-ordNub = go Set.empty where-	go _ [] = []-	go s (x:xs)-		| x `Set.member` s = go s xs-		| otherwise = x : go (Set.insert x s) xs--uniqueBy :: Ord b => (a -> b) -> [a] -> [a]-uniqueBy f = M.elems . mapBy f--mapBy :: Ord b => (a -> b) -> [a] -> M.Map b a-mapBy f = M.fromList . map (f &&& id)---- | Workaround, sometimes we get HM.lookup "foo" v == Nothing, but lookup "foo" (HM.toList v) == Just smth-(.::) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser a-v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v---- | Returns @Nothing@ when key doesn't exist or value is @Null@-(.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser (Maybe a)-v .::? name = fmap join $ traverse parseJSON $ lookup name $ HM.toList v---- | Same as @.::?@ for list, returns empty list for non-existant key or @Null@ value-(.::?!) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser [a]-v .::?! name = fromMaybe [] <$> (v .::? name)---- | Union two JSON objects-objectUnion :: Value -> Value -> Value-objectUnion (Object l) (Object r) = Object $ HM.union l r-objectUnion (Object l) _ = Object l-objectUnion _ (Object r) = Object r-objectUnion _ _ = Null---- | No Nulls in JSON object-noNulls :: [A.Pair] -> [A.Pair]-noNulls = filter (not . isNull . snd) where-	isNull Null = True-	isNull v = v == A.emptyArray || v == A.emptyObject || v == A.String ""---- | Try convert json to value-fromJSON' :: FromJSON a => Value -> Maybe a-fromJSON' v = case fromJSON v of-	A.Success r -> Just r-	_ -> Nothing---- | Lift IO exception to ExceptT-liftException :: C.MonadCatch m => m a -> ExceptT String m a-liftException = ExceptT . liftM (left $ \(SomeException e) -> displayException e) . C.try---- | Same as @liftException@-liftE :: C.MonadCatch m => m a -> ExceptT String m a-liftE = liftException---- | Run actions ignoring errors-tries :: MonadPlus m => [m a] -> m [a]-tries acts = liftM catMaybes $ sequence [liftM Just act `mplus` return Nothing | act <- acts]--triesMap :: MonadPlus m => (a -> m b) -> [a] -> m [b]-triesMap f = tries . map f---- | Lift IO exception to MonadError-liftExceptionM :: (C.MonadCatch m, MonadError String m) => m a -> m a-liftExceptionM act = C.catch act onError where-	onError = throwError . (\(SomeException e) -> displayException e)---- | Lift IO exceptions to ExceptT-liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a-liftIOErrors act = liftException (runExceptT act) >>= either throwError return---- | Log exceptions and ignore-logAll :: (MonadLog m, C.MonadCatch m) => m () -> m ()-logAll = C.handleAll logExc' where-	logExc' e = sendLog Warning $ "exception: {}" ~~ displayException e--fromUtf8 :: ByteString -> String-fromUtf8 = T.unpack . T.decodeUtf8--toUtf8 :: String -> ByteString-toUtf8 = T.encodeUtf8 . T.pack---- | Read file in UTF8-readFileUtf8 :: FilePath -> IO Text-readFileUtf8 f = withFile f ReadMode $ \h -> do-	hSetEncoding h utf8-	cts <- ST.hGetContents h-	cts `deepseq` return cts--writeFileUtf8 :: FilePath -> Text -> IO ()-writeFileUtf8 f cts = withFile f WriteMode $ \h -> do-	hSetEncoding h utf8-	ST.hPutStr h cts--hGetLineBS :: Handle -> IO ByteString-hGetLineBS = fmap L.fromStrict . B.hGetLine--logIO :: C.MonadCatch m => String -> (String -> m ()) -> m () -> m ()-logIO pre out = flip C.catch (onIO out) where-	onIO :: (String -> a) -> IOException -> a-	onIO out' e = out' $ pre ++ displayException e--logAsync :: (MonadIO m, C.MonadCatch m) => (String -> m ()) -> m () -> m ()-logAsync out = flip C.catch (onAsync out) where-	onAsync :: (MonadIO m, C.MonadThrow m) => (String -> m ()) -> AsyncException -> m ()-	onAsync out' e = out' (displayException e) >> C.throwM e--ignoreIO :: C.MonadCatch m => m () -> m ()-ignoreIO = C.handle ignore' where-	ignore' :: Monad m => IOException -> m ()-	ignore' _ = return ()--class FromCmd a where-	cmdP :: Parser a--cmdJson :: String -> [A.Pair] -> Value-cmdJson nm ps = object $ ("command" .= nm) : ps--guardCmd :: String -> Object -> A.Parser ()-guardCmd nm obj = do-	cmdName <- obj .:: "command"-	guard (nm == cmdName)---- | Add help command to parser-withHelp :: Parser a -> Parser a-withHelp = (helper' <*>) where-	helper' = abortOption ShowHelpText $ long "help" <> short '?' <> help "show help" <> hidden---- | Subcommand-cmd :: String -> String -> Parser a -> Mod CommandFields a-cmd n d p = command n (info (withHelp p) (progDesc d))---- | Parse arguments or return help-parseArgs :: String -> ParserInfo a -> [String] -> Either String a-parseArgs nm p = handle' . execParserPure (prefs mempty) (p { infoParser = withHelp (infoParser p) }) where-	handle' :: ParserResult a -> Either String a-	handle' (Success r) = Right r-	handle' (Failure f) = Left $ fst $ renderFailure f nm-	handle' _ = Left "error: completion invoked result"---- instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where--- 	askLog = lift Log.askLog---- | Get hsdev version as list of integers-version :: Maybe [Int]-version = mapM readMaybe $ split (== '.') $cabalVersion---- | Parse Distribution.Text-parseDT :: (Monad m, Distribution.Text.Text a) => String -> String -> m a-parseDT typeName v = maybe err return (simpleParse v) where-	err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v---- | Measure time of action-timer :: MonadLog m => Text -> m a -> m a-timer msg act = do-	s <- liftIO getPOSIXTime-	r <- act-	e <- liftIO getPOSIXTime-	sendLog Trace $ "{}: {}" ~~ msg ~~ show (e - s)-	return r+{-# LANGUAGE FlexibleContexts, OverloadedStrings, TemplateHaskell, CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Util (
+	withCurrentDirectory,
+	directoryContents,
+	traverseDirectory, searchPath,
+	haskellSource,
+	cabalFile,
+	-- * String utils
+	tab,
+	trim, split,
+	-- * Other utils
+	ordNub, uniqueBy, mapBy,
+	-- * Helper
+	(.::), (.::?), (.::?!), objectUnion, noNulls, fromJSON',
+	-- * Exceptions
+	liftException, liftE, tries, triesMap, liftIOErrors,
+	logAll,
+	-- * UTF-8
+	fromUtf8, toUtf8, readFileUtf8, writeFileUtf8,
+	-- * IO
+	hGetLineBS, logIO, ignoreIO, logAsync,
+	-- * Command line
+	FromCmd(..),
+	cmdJson, guardCmd,
+	withHelp, cmd, parseArgs,
+	-- * Version stuff
+	version,
+	-- * Parse
+	parseDT,
+
+	-- * Log utils
+	timer,
+
+	-- * Reexportss
+	module Control.Monad.Except,
+	MonadIO(..)
+	) where
+
+import Control.Arrow (second, left, (&&&))
+import Control.Exception
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.Except
+import qualified Control.Monad.Catch as C
+import Data.Aeson hiding (Result(..), Error)
+import qualified Data.Aeson.Types as A
+import Data.Char (isSpace)
+import Data.List (unfoldr)
+import qualified Data.Map.Strict as M
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid ((<>))
+import qualified Data.Set as Set
+import qualified Data.HashMap.Strict as HM (HashMap, toList, union)
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Text (Text)
+import qualified Data.Text.IO as ST
+import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.Encoding as T
+import Data.Time.Clock.POSIX
+import Distribution.Text (simpleParse)
+import qualified Distribution.Text (Text)
+import Options.Applicative
+import qualified System.Directory as Dir
+import System.FilePath
+import System.Log.Simple
+import System.IO
+import Text.Format
+import Text.Read (readMaybe)
+
+#if !MIN_VERSION_directory(1,2,6)
+#if mingw32_HOST_OS
+import qualified System.Win32 as Win32
+import Data.Bits ((.&.))
+#else
+import qualified System.Posix as Posix
+#endif
+#endif
+
+import HsDev.Version
+
+-- | Run action with current directory set
+withCurrentDirectory :: (MonadIO m, C.MonadMask m) => FilePath -> m a -> m a
+withCurrentDirectory cur act = C.bracket (liftIO Dir.getCurrentDirectory) (liftIO . Dir.setCurrentDirectory) $
+	const (liftIO (Dir.setCurrentDirectory cur) >> act)
+
+-- | Is directory symbolic link
+dirIsSymLink :: FilePath -> IO Bool
+#if MIN_VERSION_directory(1,3,0)
+dirIsSymLink = Dir.pathIsSymbolicLink
+#elif MIN_VERSION_directory(1,2,6)
+dirIsSymLink = Dir.isSymbolicLink
+#else
+dirIsSymLink path = do
+#if mingw32_HOST_OS
+	isReparsePoint <$> Win32.getFileAttributes path
+	where
+		fILE_ATTRIBUTE_REPARSE_POINT = 0x400
+		isReparsePoint attr = attr .&. fILE_ATTRIBUTE_REPARSE_POINT /= 0
+#else
+	Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path
+#endif
+#endif
+
+-- | Get directory contents safely: no fail, ignoring symbolic links, also prepends paths with dir name
+directoryContents :: FilePath -> IO [FilePath]
+directoryContents p = handle ignore $ do
+	b <- Dir.doesDirectoryExist p
+	isLink <- dirIsSymLink p
+	if b && (not isLink)
+		then liftM (map (p </>) . filter (`notElem` [".", ".."])) (Dir.getDirectoryContents p)
+		else return []
+	where
+		ignore :: SomeException -> IO [FilePath]
+		ignore _ = return []
+
+-- | Collect all file names in directory recursively
+traverseDirectory :: FilePath -> IO [FilePath]
+traverseDirectory p = handle onError $ do
+	cts <- directoryContents p
+	liftM concat $ forM cts $ \c -> do
+		isDir <- Dir.doesDirectoryExist c
+		if isDir
+			then (c :) <$> traverseDirectory c
+			else return [c]
+	where
+		onError :: IOException -> IO [FilePath]
+		onError _ = return []
+
+-- | Search something up
+searchPath :: (MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m a) -> m a
+searchPath p f = do
+	p' <- liftIO $ Dir.canonicalizePath p
+	isDir <- liftIO $ Dir.doesDirectoryExist p'
+	search' (if isDir then p' else takeDirectory p')
+	where
+		search' dir
+			| isDrive dir = f dir
+			| otherwise = f dir `mplus` search' (takeDirectory dir)
+
+-- | Is haskell source?
+haskellSource :: FilePath -> Bool
+haskellSource f = takeExtension f `elem` [".hs", ".lhs"]
+
+-- | Is cabal file?
+cabalFile :: FilePath -> Bool
+cabalFile f = takeExtension f == ".cabal"
+
+-- | Add N tabs to line
+tab :: Int -> String -> String
+tab n s = replicate n '\t' ++ s
+
+-- | Trim string
+trim :: String -> String
+trim = p . p where
+	p = reverse . dropWhile isSpace
+
+-- | Split list
+split :: (a -> Bool) -> [a] -> [[a]]
+split p = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break p)
+
+-- | nub is quadratic, https://github.com/nh2/haskell-ordnub/#ordnub
+ordNub :: Ord a => [a] -> [a]
+ordNub = go Set.empty where
+	go _ [] = []
+	go s (x:xs)
+		| x `Set.member` s = go s xs
+		| otherwise = x : go (Set.insert x s) xs
+
+uniqueBy :: Ord b => (a -> b) -> [a] -> [a]
+uniqueBy f = M.elems . mapBy f
+
+mapBy :: Ord b => (a -> b) -> [a] -> M.Map b a
+mapBy f = M.fromList . map (f &&& id)
+
+-- | Workaround, sometimes we get HM.lookup "foo" v == Nothing, but lookup "foo" (HM.toList v) == Just smth
+(.::) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser a
+v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v
+
+-- | Returns @Nothing@ when key doesn't exist or value is @Null@
+(.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser (Maybe a)
+v .::? name = fmap join $ traverse parseJSON $ lookup name $ HM.toList v
+
+-- | Same as @.::?@ for list, returns empty list for non-existant key or @Null@ value
+(.::?!) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser [a]
+v .::?! name = fromMaybe [] <$> (v .::? name)
+
+-- | Union two JSON objects
+objectUnion :: Value -> Value -> Value
+objectUnion (Object l) (Object r) = Object $ HM.union l r
+objectUnion (Object l) _ = Object l
+objectUnion _ (Object r) = Object r
+objectUnion _ _ = Null
+
+-- | No Nulls in JSON object
+noNulls :: [A.Pair] -> [A.Pair]
+noNulls = filter (not . isNull . snd) where
+	isNull Null = True
+	isNull v = v == A.emptyArray || v == A.emptyObject || v == A.String ""
+
+-- | Try convert json to value
+fromJSON' :: FromJSON a => Value -> Maybe a
+fromJSON' v = case fromJSON v of
+	A.Success r -> Just r
+	_ -> Nothing
+
+-- | Lift IO exception to ExceptT
+liftException :: C.MonadCatch m => m a -> ExceptT String m a
+liftException = ExceptT . liftM (left $ \(SomeException e) -> displayException e) . C.try
+
+-- | Same as @liftException@
+liftE :: C.MonadCatch m => m a -> ExceptT String m a
+liftE = liftException
+
+-- | Run actions ignoring errors
+tries :: MonadPlus m => [m a] -> m [a]
+tries acts = liftM catMaybes $ sequence [liftM Just act `mplus` return Nothing | act <- acts]
+
+triesMap :: MonadPlus m => (a -> m b) -> [a] -> m [b]
+triesMap f = tries . map f
+
+-- | Lift IO exceptions to ExceptT
+liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a
+liftIOErrors act = liftException (runExceptT act) >>= either throwError return
+
+-- | Log exceptions and ignore
+logAll :: (MonadLog m, C.MonadCatch m) => m () -> m ()
+logAll = C.handleAll logExc' where
+	logExc' e = sendLog Warning $ "exception: {}" ~~ displayException e
+
+fromUtf8 :: ByteString -> String
+fromUtf8 = T.unpack . T.decodeUtf8
+
+toUtf8 :: String -> ByteString
+toUtf8 = T.encodeUtf8 . T.pack
+
+-- | Read file in UTF8
+readFileUtf8 :: FilePath -> IO Text
+readFileUtf8 f = withFile f ReadMode $ \h -> do
+	hSetEncoding h utf8
+	cts <- ST.hGetContents h
+	cts `deepseq` return cts
+
+writeFileUtf8 :: FilePath -> Text -> IO ()
+writeFileUtf8 f cts = withFile f WriteMode $ \h -> do
+	hSetEncoding h utf8
+	ST.hPutStr h cts
+
+hGetLineBS :: Handle -> IO ByteString
+hGetLineBS = fmap L.fromStrict . B.hGetLine
+
+logIO :: C.MonadCatch m => String -> (String -> m ()) -> m () -> m ()
+logIO pre out = flip C.catch (onIO out) where
+	onIO :: (String -> a) -> IOException -> a
+	onIO out' e = out' $ pre ++ displayException e
+
+logAsync :: (MonadIO m, C.MonadCatch m) => (String -> m ()) -> m () -> m ()
+logAsync out = flip C.catch (onAsync out) where
+	onAsync :: (MonadIO m, C.MonadThrow m) => (String -> m ()) -> AsyncException -> m ()
+	onAsync out' e = out' (displayException e) >> C.throwM e
+
+ignoreIO :: C.MonadCatch m => m () -> m ()
+ignoreIO = C.handle ignore' where
+	ignore' :: Monad m => IOException -> m ()
+	ignore' _ = return ()
+
+class FromCmd a where
+	cmdP :: Parser a
+
+cmdJson :: String -> [A.Pair] -> Value
+cmdJson nm ps = object $ ("command" .= nm) : ps
+
+guardCmd :: String -> Object -> A.Parser ()
+guardCmd nm obj = do
+	cmdName <- obj .:: "command"
+	guard (nm == cmdName)
+
+-- | Add help command to parser
+withHelp :: Parser a -> Parser a
+withHelp = (helper' <*>) where
+	helper' = abortOption ShowHelpText $ long "help" <> short '?' <> help "show help" <> hidden
+
+-- | Subcommand
+cmd :: String -> String -> Parser a -> Mod CommandFields a
+cmd n d p = command n (info (withHelp p) (progDesc d))
+
+-- | Parse arguments or return help
+parseArgs :: String -> ParserInfo a -> [String] -> Either String a
+parseArgs nm p = handle' . execParserPure (prefs mempty) (p { infoParser = withHelp (infoParser p) }) where
+	handle' :: ParserResult a -> Either String a
+	handle' (Success r) = Right r
+	handle' (Failure f) = Left $ fst $ renderFailure f nm
+	handle' _ = Left "error: completion invoked result"
+
+-- instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where
+-- 	askLog = lift Log.askLog
+
+-- | Get hsdev version as list of integers
+version :: Maybe [Int]
+version = mapM readMaybe $ split (== '.') $cabalVersion
+
+-- | Parse Distribution.Text
+parseDT :: (Monad m, Distribution.Text.Text a) => String -> String -> m a
+parseDT typeName v = maybe err return (simpleParse v) where
+	err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v
+
+-- | Measure time of action
+timer :: MonadLog m => Text -> m a -> m a
+timer msg act = do
+	s <- liftIO getPOSIXTime
+	r <- act
+	e <- liftIO getPOSIXTime
+	sendLog Trace $ "{}: {}" ~~ msg ~~ show (e - s)
+	return r
src/HsDev/Watcher.hs view
@@ -1,73 +1,73 @@-module HsDev.Watcher (-	watchProject, watchModule, watchPackageDb, watchPackageDbStack,-	unwatchProject, unwatchModule, unwatchPackageDb,-	isSource, isCabal, isConf,--	module System.Directory.Watcher,-	module HsDev.Watcher.Types-	) where--import Control.Lens (view)-import System.FilePath (takeDirectory, takeExtension, (</>))--import System.Directory.Watcher hiding (Watcher)-import System.Directory.Paths-import HsDev.Project-import HsDev.Symbols-import HsDev.Watcher.Types-import HsDev.Util---- | Watch for project sources changes-watchProject :: Watcher -> Project -> [String] -> IO ()-watchProject w proj opts = do-	mapM_ (\dir -> watchTree w dir isSource (WatchedProject proj opts)) dirs-	watchDir w projDir isCabal (WatchedProject proj opts)-	where-		dirs = map ((projDir </>) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj-		projDir = view (projectPath . path) proj---- | Watch for standalone source-watchModule :: Watcher -> ModuleLocation -> IO ()-watchModule w (FileModule f Nothing) = watchDir w (takeDirectory $ view path f) isSource WatchedModule-watchModule w (FileModule _ (Just proj)) = watchProject w proj []-watchModule _ _ = return ()---- | Watch for top of package-db stack-watchPackageDb :: Watcher -> PackageDbStack -> [String] -> IO ()-watchPackageDb w pdbs opts = case topPackageDb pdbs of-	GlobalDb -> return () -- TODO: Watch for global package-db-	UserDb -> return () -- TODO: Watch for user package-db-	(PackageDb pdb) -> watchTree w (view path pdb) isConf (WatchedPackageDb pdbs opts)---- | Watch for package-db stack-watchPackageDbStack :: Watcher -> PackageDbStack -> [String] -> IO ()-watchPackageDbStack w pdbs opts = mapM_ (\pdbs' -> watchPackageDb w pdbs' opts) $ packageDbStacks pdbs--unwatchProject :: Watcher -> Project -> IO ()-unwatchProject w proj = do-	mapM_ (unwatchTree w) dirs-	void $ unwatchDir w projDir-	where-		dirs = map ((projDir </>) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj-		projDir = view (projectPath . path) proj--unwatchModule :: Watcher -> ModuleLocation -> IO ()-unwatchModule w (FileModule f Nothing) = void $ unwatchDir w (takeDirectory $ view path f)-unwatchModule _ (FileModule _ (Just _)) = return ()-unwatchModule _ InstalledModule{} = return ()-unwatchModule _ _ = return ()---- | Unwatch package-db-unwatchPackageDb :: Watcher -> PackageDb -> IO ()-unwatchPackageDb _ GlobalDb = return () -- TODO: Unwatch global package-db-unwatchPackageDb _ UserDb = return () -- TODO: Unwatch user package-db-unwatchPackageDb w (PackageDb pdb) = void $ unwatchTree w (view path pdb)--isSource :: Event -> Bool-isSource = haskellSource . view eventPath--isCabal :: Event -> Bool-isCabal = cabalFile . view eventPath--isConf :: Event -> Bool-isConf (Event _ f _) = takeExtension f == ".conf"+module HsDev.Watcher (
+	watchProject, watchModule, watchPackageDb, watchPackageDbStack,
+	unwatchProject, unwatchModule, unwatchPackageDb,
+	isSource, isCabal, isConf,
+
+	module System.Directory.Watcher,
+	module HsDev.Watcher.Types
+	) where
+
+import Control.Lens (view)
+import System.FilePath (takeDirectory, takeExtension, (</>))
+
+import System.Directory.Watcher hiding (Watcher)
+import System.Directory.Paths
+import HsDev.Project
+import HsDev.Symbols
+import HsDev.Watcher.Types
+import HsDev.Util
+
+-- | Watch for project sources changes
+watchProject :: Watcher -> Project -> [String] -> IO ()
+watchProject w proj opts = do
+	mapM_ (\dir -> watchTree w dir isSource (WatchedProject proj opts)) dirs
+	watchDir w projDir isCabal (WatchedProject proj opts)
+	where
+		dirs = map ((projDir </>) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj
+		projDir = view (projectPath . path) proj
+
+-- | Watch for standalone source
+watchModule :: Watcher -> ModuleLocation -> IO ()
+watchModule w (FileModule f Nothing) = watchDir w (takeDirectory $ view path f) isSource WatchedModule
+watchModule w (FileModule _ (Just proj)) = watchProject w proj []
+watchModule _ _ = return ()
+
+-- | Watch for top of package-db stack
+watchPackageDb :: Watcher -> PackageDbStack -> [String] -> IO ()
+watchPackageDb w pdbs opts = case topPackageDb pdbs of
+	GlobalDb -> return () -- TODO: Watch for global package-db
+	UserDb -> return () -- TODO: Watch for user package-db
+	(PackageDb pdb) -> watchTree w (view path pdb) isConf (WatchedPackageDb pdbs opts)
+
+-- | Watch for package-db stack
+watchPackageDbStack :: Watcher -> PackageDbStack -> [String] -> IO ()
+watchPackageDbStack w pdbs opts = mapM_ (\pdbs' -> watchPackageDb w pdbs' opts) $ packageDbStacks pdbs
+
+unwatchProject :: Watcher -> Project -> IO ()
+unwatchProject w proj = do
+	mapM_ (unwatchTree w) dirs
+	void $ unwatchDir w projDir
+	where
+		dirs = map ((projDir </>) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj
+		projDir = view (projectPath . path) proj
+
+unwatchModule :: Watcher -> ModuleLocation -> IO ()
+unwatchModule w (FileModule f Nothing) = void $ unwatchDir w (takeDirectory $ view path f)
+unwatchModule _ (FileModule _ (Just _)) = return ()
+unwatchModule _ InstalledModule{} = return ()
+unwatchModule _ _ = return ()
+
+-- | Unwatch package-db
+unwatchPackageDb :: Watcher -> PackageDb -> IO ()
+unwatchPackageDb _ GlobalDb = return () -- TODO: Unwatch global package-db
+unwatchPackageDb _ UserDb = return () -- TODO: Unwatch user package-db
+unwatchPackageDb w (PackageDb pdb) = void $ unwatchTree w (view path pdb)
+
+isSource :: Event -> Bool
+isSource = haskellSource . view eventPath
+
+isCabal :: Event -> Bool
+isCabal = cabalFile . view eventPath
+
+isConf :: Event -> Bool
+isConf (Event _ f _) = takeExtension f == ".conf"
src/System/Directory/Paths.hs view
@@ -1,85 +1,85 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--module System.Directory.Paths (-	Path, path, fromFilePath, joinPaths, splitPaths,-	normPath, subPath, relPathTo,-	dirExists, fileExists, takeDir,-	isParent,-	Paths(..),-	canonicalize,-	absolutise,-	relativise-	) where--import Control.Lens-import Data.List-import Data.Text (Text, pack)-import Data.Text.Lens (unpacked)-import System.Directory-import System.FilePath---- | Takes much less memory than 'FilePath'-type Path = Text--path :: Lens' Path FilePath-path = unpacked--fromFilePath :: FilePath -> Path-fromFilePath = pack--joinPaths :: [Path] -> Path-joinPaths = fromFilePath . joinPath . map (view path)--splitPaths :: Path -> [Path]-splitPaths = map fromFilePath . splitDirectories . view path--normPath :: Path -> Path-normPath = over path normalise--subPath :: Path -> Path -> Path-subPath p ch = fromFilePath (view path p </> view path ch)---- | Make path relative-relPathTo :: Path -> Path -> Path-relPathTo base p = fromFilePath $ makeRelative (view path base) (view path p)--dirExists :: Path -> IO Bool-dirExists = doesDirectoryExist . view path--fileExists :: Path -> IO Bool-fileExists = doesFileExist . view path--takeDir :: Path -> Path-takeDir = over path takeDirectory---- | Is one path parent of another-isParent :: Path -> Path -> Bool-isParent dir file = norm dir `isPrefixOf` norm file where-	norm = dropDot . splitDirectories . normalise . view path-	dropDot ("." : chs) = chs-	dropDot chs = chs---- | Something with paths inside-class Paths a where-	paths :: Traversal' a FilePath--instance Paths FilePath where-	paths = id--instance Paths Path where-	paths = unpacked---- | Canonicalize all paths-canonicalize :: Paths a => a -> IO a-canonicalize = paths canonicalizePath---- | Absolutise paths-absolutise :: Paths a => Path -> a -> a-absolutise parent = over paths addRoot where-	addRoot p-		| isRelative p = (parent ^. path) </> p-		| otherwise = p---- | Relativise paths-relativise :: Paths a => Path -> a -> a-relativise parent = over paths (makeRelative (parent ^. path))+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
+module System.Directory.Paths (
+	Path, path, fromFilePath, joinPaths, splitPaths,
+	normPath, subPath, relPathTo,
+	dirExists, fileExists, takeDir,
+	isParent,
+	Paths(..),
+	canonicalize,
+	absolutise,
+	relativise
+	) where
+
+import Control.Lens
+import Data.List
+import Data.Text (Text, pack)
+import Data.Text.Lens (unpacked)
+import System.Directory
+import System.FilePath
+
+-- | Takes much less memory than 'FilePath'
+type Path = Text
+
+path :: Lens' Path FilePath
+path = unpacked
+
+fromFilePath :: FilePath -> Path
+fromFilePath = pack
+
+joinPaths :: [Path] -> Path
+joinPaths = fromFilePath . joinPath . map (view path)
+
+splitPaths :: Path -> [Path]
+splitPaths = map fromFilePath . splitDirectories . view path
+
+normPath :: Path -> Path
+normPath = over path normalise
+
+subPath :: Path -> Path -> Path
+subPath p ch = fromFilePath (view path p </> view path ch)
+
+-- | Make path relative
+relPathTo :: Path -> Path -> Path
+relPathTo base p = fromFilePath $ makeRelative (view path base) (view path p)
+
+dirExists :: Path -> IO Bool
+dirExists = doesDirectoryExist . view path
+
+fileExists :: Path -> IO Bool
+fileExists = doesFileExist . view path
+
+takeDir :: Path -> Path
+takeDir = over path takeDirectory
+
+-- | Is one path parent of another
+isParent :: Path -> Path -> Bool
+isParent dir file = norm dir `isPrefixOf` norm file where
+	norm = dropDot . splitDirectories . normalise . view path
+	dropDot ("." : chs) = chs
+	dropDot chs = chs
+
+-- | Something with paths inside
+class Paths a where
+	paths :: Traversal' a FilePath
+
+instance Paths FilePath where
+	paths = id
+
+instance Paths Path where
+	paths = unpacked
+
+-- | Canonicalize all paths
+canonicalize :: Paths a => a -> IO a
+canonicalize = paths canonicalizePath
+
+-- | Absolutise paths
+absolutise :: Paths a => Path -> a -> a
+absolutise parent = over paths addRoot where
+	addRoot p
+		| isRelative p = (parent ^. path) </> p
+		| otherwise = p
+
+-- | Relativise paths
+relativise :: Paths a => Path -> a -> a
+relativise parent = over paths (makeRelative (parent ^. path))
src/System/Directory/Watcher.hs view
@@ -1,174 +1,174 @@-{-# LANGUAGE PatternGuards, TemplateHaskell #-}--module System.Directory.Watcher (-	EventType(..), Event(..), eventType, eventPath, eventTime,-	Watcher(..),-	withWatcher,-	watchDir, watchDir_, unwatchDir, isWatchingDir,-	watchTree, watchTree_, unwatchTree, isWatchingTree,-	-- * Working with events-	readEvent, eventGroup, onEvents, onEvents_-	) where--import Control.Lens (makeLenses)-import Control.Arrow-import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.Monad-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe (isJust)-import Data.Ratio ((%))-import Data.String (fromString)-import Data.Time.Clock (NominalDiffTime)-import Data.Time.Clock.POSIX-import System.FilePath (takeDirectory, isDrive)-import System.Directory-import qualified System.FSNotify as FS--import HsDev.Util (uniqueBy)---- | Event type-data EventType = Added | Modified | Removed deriving (Eq, Ord, Enum, Bounded, Read, Show)---- | Event-data Event = Event {-	_eventType :: EventType,-	_eventPath :: FilePath,-	_eventTime :: POSIXTime }-		deriving (Eq, Ord, Show)--makeLenses ''Event---- | Directories watcher-data Watcher a = Watcher {-	-- | Map from directory to watch stopper-	watcherDirs :: MVar (Map FilePath (Bool, IO ())),-	watcherMan :: FS.WatchManager,-	watcherChan :: Chan (a, Event) }---- | Create watcher-withWatcher :: (Watcher a -> IO b) -> IO b-withWatcher act = FS.withManager $ \man -> do-	ch <- newChan-	dirs <- newMVar M.empty-	act $ Watcher dirs man ch---- | Watch directory-watchDir :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO ()-watchDir w f p v = do-	e <- doesDirectoryExist f-	when e $ do-		f' <- canonicalizePath f-		watching <- isWatchingDir w f'-		unless watching $ do-			stop <- FS.watchDir-				(watcherMan w)-				(fromString f')-				(p . fromEvent)-				(writeChan (watcherChan w) . (,) v . fromEvent)-			modifyMVar_ (watcherDirs w) $ return . M.insert f' (False, stop)--watchDir_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO ()-watchDir_ w f p = watchDir w f p ()---- | Unwatch directory, return @False@, if not watched-unwatchDir :: Watcher a -> FilePath -> IO Bool-unwatchDir w f = do-	f' <- canonicalizePath f-	stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f')-	maybe (return ()) snd stop-	return $ isJust stop---- | Check if we are watching dir-isWatchingDir :: Watcher a -> FilePath -> IO Bool-isWatchingDir w f = do-	f' <- canonicalizePath f-	dirs <- readMVar (watcherDirs w)-	return $ isWatchingDir' dirs f'---- | Watch directory tree-watchTree :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO ()-watchTree w f p v = do-	e <- doesDirectoryExist f-	when e $ do-		f' <- canonicalizePath f-		watching <- isWatchingTree w f'-		unless watching $ do-			stop <- FS.watchTree-				(watcherMan w)-				(fromString f')-				(p . fromEvent)-				(writeChan (watcherChan w) . (,) v . fromEvent)-			modifyMVar_ (watcherDirs w) $ return . M.insert f' (True, stop)--watchTree_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO ()-watchTree_ w f p = watchTree w f p ()---- | Unwatch directory tree-unwatchTree :: Watcher a -> FilePath -> IO Bool-unwatchTree w f = do-	f' <- canonicalizePath f-	stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f')-	maybe (return ()) snd stop-	return $ isJust stop---- | Check if we are watching tree-isWatchingTree :: Watcher a -> FilePath -> IO Bool-isWatchingTree w f = do-	f' <- canonicalizePath f-	dirs <- readMVar (watcherDirs w)-	return $ isWatchingTree' dirs f'---- | Read next event-readEvent :: Watcher a -> IO (a, Event)-readEvent = readChan . watcherChan---- | Get event group-eventGroup :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO ()-eventGroup w tm onGroup = do-	groupVar <- newTMVarIO []-	syncVar <- newEmptyTMVarIO-	_ <- async $ forever $ do-		ev <- readChan (watcherChan w)-		_ <- atomically $ tryPutTMVar syncVar ()-		atomically $ do-			evs <- takeTMVar groupVar-			putTMVar groupVar (ev : evs)-	forever $ do-		_ <- atomically $ takeTMVar syncVar-		threadDelay $ floor (tm * 1e6)-		evs' <- atomically $ do-			evs <- takeTMVar groupVar-			putTMVar groupVar []-			_ <- tryTakeTMVar syncVar-			return $ reverse evs-		onGroup $ uniqueBy (\(_, ev') -> (_eventType ev', _eventPath ev')) evs'---- | Process all events-onEvents :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO ()-onEvents = eventGroup---- | Process all events-onEvents_ :: Watcher a -> ([(a, Event)] -> IO ()) -> IO ()-onEvents_ w = onEvents w (fromRational (1 % 5))--fromEvent :: FS.Event -> Event-fromEvent e = Event t (FS.eventPath e) (utcTimeToPOSIXSeconds $ FS.eventTime e) where-	t = case e of-		FS.Added _ _ -> Added-		FS.Modified _ _ -> Modified-		FS.Removed _ _ -> Removed--isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool-isWatchingDir' m dir-	| Just (_, _) <- M.lookup dir m = True-	| isDrive dir = False-	| otherwise = isWatchingTree' m (takeDirectory dir)--isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool-isWatchingTree' m dir-	| Just (True, _) <- M.lookup dir m = True-	| isDrive dir = False-	| otherwise = isWatchingTree' m (takeDirectory dir)+{-# LANGUAGE PatternGuards, TemplateHaskell #-}
+
+module System.Directory.Watcher (
+	EventType(..), Event(..), eventType, eventPath, eventTime,
+	Watcher(..),
+	withWatcher,
+	watchDir, watchDir_, unwatchDir, isWatchingDir,
+	watchTree, watchTree_, unwatchTree, isWatchingTree,
+	-- * Working with events
+	readEvent, eventGroup, onEvents, onEvents_
+	) where
+
+import Control.Lens (makeLenses)
+import Control.Arrow
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe (isJust)
+import Data.Ratio ((%))
+import Data.String (fromString)
+import Data.Time.Clock (NominalDiffTime)
+import Data.Time.Clock.POSIX
+import System.FilePath (takeDirectory, isDrive)
+import System.Directory
+import qualified System.FSNotify as FS
+
+import HsDev.Util (uniqueBy)
+
+-- | Event type
+data EventType = Added | Modified | Removed deriving (Eq, Ord, Enum, Bounded, Read, Show)
+
+-- | Event
+data Event = Event {
+	_eventType :: EventType,
+	_eventPath :: FilePath,
+	_eventTime :: POSIXTime }
+		deriving (Eq, Ord, Show)
+
+makeLenses ''Event
+
+-- | Directories watcher
+data Watcher a = Watcher {
+	-- | Map from directory to watch stopper
+	watcherDirs :: MVar (Map FilePath (Bool, IO ())),
+	watcherMan :: FS.WatchManager,
+	watcherChan :: Chan (a, Event) }
+
+-- | Create watcher
+withWatcher :: (Watcher a -> IO b) -> IO b
+withWatcher act = FS.withManager $ \man -> do
+	ch <- newChan
+	dirs <- newMVar M.empty
+	act $ Watcher dirs man ch
+
+-- | Watch directory
+watchDir :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO ()
+watchDir w f p v = do
+	e <- doesDirectoryExist f
+	when e $ do
+		f' <- canonicalizePath f
+		watching <- isWatchingDir w f'
+		unless watching $ do
+			stop <- FS.watchDir
+				(watcherMan w)
+				(fromString f')
+				(p . fromEvent)
+				(writeChan (watcherChan w) . (,) v . fromEvent)
+			modifyMVar_ (watcherDirs w) $ return . M.insert f' (False, stop)
+
+watchDir_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO ()
+watchDir_ w f p = watchDir w f p ()
+
+-- | Unwatch directory, return @False@, if not watched
+unwatchDir :: Watcher a -> FilePath -> IO Bool
+unwatchDir w f = do
+	f' <- canonicalizePath f
+	stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f')
+	maybe (return ()) snd stop
+	return $ isJust stop
+
+-- | Check if we are watching dir
+isWatchingDir :: Watcher a -> FilePath -> IO Bool
+isWatchingDir w f = do
+	f' <- canonicalizePath f
+	dirs <- readMVar (watcherDirs w)
+	return $ isWatchingDir' dirs f'
+
+-- | Watch directory tree
+watchTree :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO ()
+watchTree w f p v = do
+	e <- doesDirectoryExist f
+	when e $ do
+		f' <- canonicalizePath f
+		watching <- isWatchingTree w f'
+		unless watching $ do
+			stop <- FS.watchTree
+				(watcherMan w)
+				(fromString f')
+				(p . fromEvent)
+				(writeChan (watcherChan w) . (,) v . fromEvent)
+			modifyMVar_ (watcherDirs w) $ return . M.insert f' (True, stop)
+
+watchTree_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO ()
+watchTree_ w f p = watchTree w f p ()
+
+-- | Unwatch directory tree
+unwatchTree :: Watcher a -> FilePath -> IO Bool
+unwatchTree w f = do
+	f' <- canonicalizePath f
+	stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f')
+	maybe (return ()) snd stop
+	return $ isJust stop
+
+-- | Check if we are watching tree
+isWatchingTree :: Watcher a -> FilePath -> IO Bool
+isWatchingTree w f = do
+	f' <- canonicalizePath f
+	dirs <- readMVar (watcherDirs w)
+	return $ isWatchingTree' dirs f'
+
+-- | Read next event
+readEvent :: Watcher a -> IO (a, Event)
+readEvent = readChan . watcherChan
+
+-- | Get event group
+eventGroup :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO ()
+eventGroup w tm onGroup = do
+	groupVar <- newTMVarIO []
+	syncVar <- newEmptyTMVarIO
+	_ <- async $ forever $ do
+		ev <- readChan (watcherChan w)
+		_ <- atomically $ tryPutTMVar syncVar ()
+		atomically $ do
+			evs <- takeTMVar groupVar
+			putTMVar groupVar (ev : evs)
+	forever $ do
+		_ <- atomically $ takeTMVar syncVar
+		threadDelay $ floor (tm * 1e6)
+		evs' <- atomically $ do
+			evs <- takeTMVar groupVar
+			putTMVar groupVar []
+			_ <- tryTakeTMVar syncVar
+			return $ reverse evs
+		onGroup $ uniqueBy (\(_, ev') -> (_eventType ev', _eventPath ev')) evs'
+
+-- | Process all events
+onEvents :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO ()
+onEvents = eventGroup
+
+-- | Process all events
+onEvents_ :: Watcher a -> ([(a, Event)] -> IO ()) -> IO ()
+onEvents_ w = onEvents w (fromRational (1 % 5))
+
+fromEvent :: FS.Event -> Event
+fromEvent e = Event t (FS.eventPath e) (utcTimeToPOSIXSeconds $ FS.eventTime e) where
+	t = case e of
+		FS.Added _ _ -> Added
+		FS.Modified _ _ -> Modified
+		FS.Removed _ _ -> Removed
+
+isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
+isWatchingDir' m dir
+	| Just (_, _) <- M.lookup dir m = True
+	| isDrive dir = False
+	| otherwise = isWatchingTree' m (takeDirectory dir)
+
+isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
+isWatchingTree' m dir
+	| Just (True, _) <- M.lookup dir m = True
+	| isDrive dir = False
+	| otherwise = isWatchingTree' m (takeDirectory dir)
src/System/Win32/FileMapping/NamePool.hs view
@@ -1,33 +1,33 @@-{-# LANGUAGE LambdaCase #-}--module System.Win32.FileMapping.NamePool (-	Pool(..),-	createPool, withName-	) where--import Control.Concurrent-import Control.Exception (bracket)-import Control.Monad (liftM, liftM2)-import System.Win32.FileMapping.Memory ()---- | Pool of names for memory mapped files-data Pool = Pool {-	poolFreeNames :: MVar [String],-	poolNewName :: IO String }---- | Create pool of numbered names by base name-createPool :: String -> IO Pool-createPool baseName = liftM2 Pool (newMVar []) mkNewName where-	mkNewName :: IO (IO String)-	mkNewName = do-		num <- newMVar (0 :: Integer)-		return $ modifyMVar num $ \n -> do-			return (succ n, baseName ++ show n)---- | Use free name from pool-withName :: Pool -> (String -> IO a) -> IO a-withName p = bracket getName freeName where-	getName = modifyMVar (poolFreeNames p) $ \case-		[] -> liftM ((,) []) $ poolNewName p-		(n : ns) -> return (ns, n)-	freeName name = modifyMVar_ (poolFreeNames p) (return . (name:))+{-# LANGUAGE LambdaCase #-}
+
+module System.Win32.FileMapping.NamePool (
+	Pool(..),
+	createPool, withName
+	) where
+
+import Control.Concurrent
+import Control.Exception (bracket)
+import Control.Monad (liftM, liftM2)
+import System.Win32.FileMapping.Memory ()
+
+-- | Pool of names for memory mapped files
+data Pool = Pool {
+	poolFreeNames :: MVar [String],
+	poolNewName :: IO String }
+
+-- | Create pool of numbered names by base name
+createPool :: String -> IO Pool
+createPool baseName = liftM2 Pool (newMVar []) mkNewName where
+	mkNewName :: IO (IO String)
+	mkNewName = do
+		num <- newMVar (0 :: Integer)
+		return $ modifyMVar num $ \n -> do
+			return (succ n, baseName ++ show n)
+
+-- | Use free name from pool
+withName :: Pool -> (String -> IO a) -> IO a
+withName p = bracket getName freeName where
+	getName = modifyMVar (poolFreeNames p) $ \case
+		[] -> liftM ((,) []) $ poolNewName p
+		(n : ns) -> return (ns, n)
+	freeName name = modifyMVar_ (poolFreeNames p) (return . (name:))
src/System/Win32/PowerShell.hs view
@@ -1,36 +1,36 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, LambdaCase #-}--module System.Win32.PowerShell (-	-- * Escape functions-	translate, translateArg,-	quote, quoteDouble,-	escape-	) where--import Data.Char (isAlphaNum)--translate :: String -> String-translate s-	| all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s-	| otherwise = '"' : snd (foldr escape' (True, "\"") s)-	where-		escape' '"' (_, s') = (True, '\\' : '"' : s')-		escape' '\\' (True, s') = (True, '\\' : '\\' : s')-		escape' '\\' (False, s') = (False, '\\' : s')-		escape' c (_, s') = (False, c : s')--translateArg :: String -> String-translateArg s-	| all isAlphaNum s = s-	| otherwise = "'" ++ translate s ++ "'"--quote :: String -> String-quote s = "'" ++ concatMap (\case { '\'' -> "''"; ch -> [ch] }) s ++ "'"--quoteDouble :: String -> String-quoteDouble s = "\"" ++ concatMap (\case { '"' -> "\"\""; ch -> [ch] }) s ++ "\""--escape :: (String -> String) -> String -> String-escape fn s-	| all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s-	| otherwise = fn s+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, LambdaCase #-}
+
+module System.Win32.PowerShell (
+	-- * Escape functions
+	translate, translateArg,
+	quote, quoteDouble,
+	escape
+	) where
+
+import Data.Char (isAlphaNum)
+
+translate :: String -> String
+translate s
+	| all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s
+	| otherwise = '"' : snd (foldr escape' (True, "\"") s)
+	where
+		escape' '"' (_, s') = (True, '\\' : '"' : s')
+		escape' '\\' (True, s') = (True, '\\' : '\\' : s')
+		escape' '\\' (False, s') = (False, '\\' : s')
+		escape' c (_, s') = (False, c : s')
+
+translateArg :: String -> String
+translateArg s
+	| all isAlphaNum s = s
+	| otherwise = "'" ++ translate s ++ "'"
+
+quote :: String -> String
+quote s = "'" ++ concatMap (\case { '\'' -> "''"; ch -> [ch] }) s ++ "'"
+
+quoteDouble :: String -> String
+quoteDouble s = "\"" ++ concatMap (\case { '"' -> "\"\""; ch -> [ch] }) s ++ "\""
+
+escape :: (String -> String) -> String -> String
+escape fn s
+	| all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s
+	| otherwise = fn s
tests/Test.hs view
@@ -1,193 +1,193 @@-{-# LANGUAGE OverloadedStrings, TypeApplications #-}--module Main (-	main-	) where--import Control.Lens-import Control.Exception (displayException)-import Data.Aeson hiding (Error)-import Data.Aeson.Lens-import Data.Default-import Data.List-import Data.Maybe-import Data.String (fromString)-import qualified Data.Set as S-import Data.Text (unpack)-import System.FilePath-import System.Directory-import Test.Hspec--import HsDev-import HsDev.Database.SQLite--send :: Server -> [String] -> IO (Maybe Value)-send srv args = do-	r <- sendServer_ srv args-	case r of-		Result v -> return $ Just v-		Error e -> do-			expectationFailure $ "command result error: " ++ displayException e-			return Nothing--exports :: Maybe Value -> S.Set String-exports v = mkSet (v ^.. traverseArray . key "exports" . traverseArray . key "id" . key "name" . _Just)--imports :: Maybe Value -> S.Set Import-imports v = mkSet $ do-	is <- v ^.. traverseArray . key "imports" . traverseArray-	maybeToList $ Import <$> pos (is ^. key "pos") <*> (is ^. key "name") <*> (is ^. key "qualified") <*> (is ^. key "as")--rgn :: Maybe Value -> Maybe Region-rgn v = Region <$> pos (v ^. key "from") <*> pos (v ^. key "to")--pos :: Maybe Value -> Maybe Position-pos v = Position <$> (v ^. key "line") <*> (v ^. key "column")--mkSet :: Ord a => [a] -> S.Set a-mkSet = S.fromList---main :: IO ()-main = hspec $ do-	describe "scan project" $ do-		dir <- runIO getCurrentDirectory-		s <- runIO $ startServer_ (def { serverSilent = True })--		it "should load data" $ do-			inserts <- fmap lines $ readFile (dir </> "tests/data/base.sql")-			inServer s $ mapM_ (execute_ . fromString) inserts--		it "should scan project" $ do-			void $ send s ["scan", "--project", dir </> "tests/test-package"]--		it "should resolve export list" $ do-			one <- send s ["module", "ModuleOne", "--exact"]-			exports one `shouldBe` mkSet ["Ctor", "ctor", "test", "newChan", "untypedFoo"]-			two <- send s ["module", "ModuleTwo", "--exact"]-			exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings"]--		it "should return cached warnings on sequential checks without file modifications" $ do-			firstCheck <- send s ["check", "--file", dir </> "tests/test-package/ModuleOne.hs"]-			secondCheck <- send s ["check", "--file", dir </> "tests/test-package/ModuleOne.hs"]-			firstCheck `shouldNotSatisfy` null-			firstCheck `shouldBe` secondCheck--		it "should not lose warnings that comes while loading module for inferring types" $ do-			void $ send s ["infer", "--file", dir </> "tests/test-package/ModuleThree.hs"]-			checks <- send s ["check", "--file", dir </> "tests/test-package/ModuleThree.hs"]-			checks `shouldNotSatisfy` null--		it "should return module imports" $ do-			three <- send s ["module", "ModuleThree", "--exact"]-			imports three `shouldBe` mkSet [-				Import (Position 8 1) "Control.Concurrent.Chan" False Nothing,-				Import (Position 10 1) "ModuleOne" False Nothing,-				Import (Position 11 1) "ModuleTwo" False (Just "T")]--		it "should pass extensions when checks" $ do-			checks <- send s ["check", "--file", dir </> "tests/test-package/ModuleTwo.hs"]-			(checks ^.. traverseArray . key "level" . _Just) `shouldSatisfy` (("error" :: String) `notElem`)--		it "should return types and docs" $ do-			test' <- send s ["whois", "test", "--file", dir </> "tests/test-package/ModuleOne.hs"]-			let-				testType :: Maybe String-				testType = test' ^. traverseArray . key "info" . key "type"-			testType `shouldBe` Just "IO ()"--		it "should infer types" $ do-			ts <- send s ["types", "--file", dir </> "tests/test-package/ModuleOne.hs"]-			let-				untypedFooRgn = Region (Position 15 1) (Position 15 11)-				exprs :: [(Region, String)]-				exprs = do-					note' <- ts ^.. traverseArray-					rgn' <- maybeToList $ rgn (note' ^. key "region")-					return (rgn', note' ^. key "note" . key "type" . _Just)-			lookup untypedFooRgn exprs `shouldBe` Just "a -> a -> a" -- FIXME: Where's Num constraint?--		it "should return symbol under location" $ do-			_ <- send s ["infer", "--file", dir </> "tests/test-package/ModuleTwo.hs"]-			who' <- send s ["whoat", "13", "15", "--file", dir </> "tests/test-package/ModuleTwo.hs"]-			let-				whoName :: Maybe String-				whoName = who' ^. traverseArray . key "id" . key "name"-				whoType :: Maybe String-				whoType = who' ^. traverseArray . key "info" . key "type"-			whoName `shouldBe` Just "f"-			whoType `shouldBe` Just "a -> a"--		it "should distinguish between constructor and data" $ do-			whoData <- send s ["whoat", "20", "9", "--file", dir </> "tests/test-package/ModuleOne.hs"]-			whoCtor <- send s ["whoat", "21", "8", "--file", dir </> "tests/test-package/ModuleOne.hs"]-			(whoData ^. traverseArray . key "info" . key "what" :: Maybe String) `shouldBe` Just "data"-			(whoCtor ^. traverseArray . key "info" . key "what" :: Maybe String) `shouldBe` Just "ctor"--		it "should use modified file contents" $ do-			modifiedContents <- fmap unpack $ readFileUtf8 $ dir </> "tests/data/ModuleTwo.modified.hs"-			void $ send s ["set-file-contents", "--file", dir </> "tests/test-package/ModuleTwo.hs", "--contents", modifiedContents]-			-- Call scan to wait until file updated-			void $ send s ["scan", "--file", dir </> "tests/test-package/ModuleTwo.hs"]--		it "should rescan module with modified contents" $ do-			two <- send s ["module", "ModuleTwo", "--exact"]-			exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"]--		it "should use modified source in `check` command" $ do-			checks <- send s ["check", "--file", dir </> "tests/test-package/ModuleTwo.hs"]-			(checks ^.. traverseArray . key "note" . key "message" . _Just) `shouldSatisfy` (any ("Defined but not used" `isPrefixOf`))--		it "should get usages of symbol" $ do-			-- Note, that source was modified-			us <- send s ["usages", "2", "2", "--file", dir </> "tests/test-package/ModuleTwo.hs"]-			let-				locs :: [(String, Region)]-				locs = do-					n <- us ^.. traverseArray-					nm <- maybeToList $ n ^. key "in" . key "name"-					p <- maybeToList $ rgn (n ^. key "at")-					return (nm, p)-			S.fromList locs `shouldBe` S.fromList [-				("ModuleOne", Position 4 2 `region` Position 4 12),-				("ModuleOne", Position 15 1 `region` Position 15 11),-				("ModuleTwo", Position 2 2 `region` Position 2 12),-				("ModuleTwo", Position 8 19 `region` Position 8 29),-				("ModuleTwo", Position 25 21 `region` Position 25 31),-				("ModuleTwo", Position 25 35 `region` Position 25 45)]--		it "should get usages of local symbols" $ do-			us <- send s ["usages", "14", "15", "--file", dir </> "tests/test-package/ModuleTwo.hs"]-			let-				locs :: [Region]-				locs = do-					n <- us ^.. traverseArray-					maybeToList $ rgn (n ^. key "at")-			S.fromList locs `shouldBe` S.fromList [-				Position 14 7 `region` Position 14 8,-				Position 14 11 `region` Position 14 12,-				Position 14 15 `region` Position 14 16]--		it "should evaluate expression in context of module" $ do-			vals <- send s ["ghc", "eval", "smth [1,2,3]", "--file", dir </> "tests/test-package/ModuleThree.hs"]-			vals ^.. traverseArray . key @String "ok" . _Just `shouldBe` ["[3,4]"]--		it "should return type of expression in context of module" $ do-			tys <- send s ["ghc", "type", "twice twice", "--file", dir </> "tests/test-package/ModuleTwo.hs"]-			tys ^.. traverseArray . key @String "ok" . _Just `shouldBe` ["(a -> a) -> a -> a"]--		it "shouldn't lose module info if unsaved source is broken" $ do-			brokenContents <- fmap unpack $ readFileUtf8 $ dir </> "tests/data/ModuleTwo.broken.hs"-			void $ send s ["set-file-contents", "--file", dir </> "tests/test-package/ModuleTwo.hs", "--contents", brokenContents]-			-- Call scan to wait until file updated-			void $ send s ["scan", "--file", dir </> "tests/test-package/ModuleTwo.hs"]--			two <- send s ["module", "ModuleTwo", "--exact"]-			exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"]--		it "should complete qualified names" $ do-			comps <- send s ["complete", "T.o", "--file", dir </> "tests/test-package/ModuleThree.hs"]-			comps ^.. traverseArray . key "id" . key @String "name" . _Just `shouldBe` ["overloadedStrings"]--		_ <- runIO $ send s ["exit"]-		return ()+{-# LANGUAGE OverloadedStrings, TypeApplications #-}
+
+module Main (
+	main
+	) where
+
+import Control.Lens
+import Control.Exception (displayException)
+import Data.Aeson hiding (Error)
+import Data.Aeson.Lens
+import Data.Default
+import Data.List
+import Data.Maybe
+import Data.String (fromString)
+import qualified Data.Set as S
+import Data.Text (unpack)
+import System.FilePath
+import System.Directory
+import Test.Hspec
+
+import HsDev
+import HsDev.Database.SQLite
+
+send :: Server -> [String] -> IO (Maybe Value)
+send srv args = do
+	r <- sendServer_ srv args
+	case r of
+		Result v -> return $ Just v
+		Error e -> do
+			expectationFailure $ "command result error: " ++ displayException e
+			return Nothing
+
+exports :: Maybe Value -> S.Set String
+exports v = mkSet (v ^.. traverseArray . key "exports" . traverseArray . key "id" . key "name" . _Just)
+
+imports :: Maybe Value -> S.Set Import
+imports v = mkSet $ do
+	is <- v ^.. traverseArray . key "imports" . traverseArray
+	maybeToList $ Import <$> pos (is ^. key "pos") <*> (is ^. key "name") <*> (is ^. key "qualified") <*> (is ^. key "as")
+
+rgn :: Maybe Value -> Maybe Region
+rgn v = Region <$> pos (v ^. key "from") <*> pos (v ^. key "to")
+
+pos :: Maybe Value -> Maybe Position
+pos v = Position <$> (v ^. key "line") <*> (v ^. key "column")
+
+mkSet :: Ord a => [a] -> S.Set a
+mkSet = S.fromList
+
+
+main :: IO ()
+main = hspec $ do
+	describe "scan project" $ do
+		dir <- runIO getCurrentDirectory
+		s <- runIO $ startServer_ (def { serverSilent = True })
+
+		it "should load data" $ do
+			inserts <- fmap lines $ readFile (dir </> "tests/data/base.sql")
+			inServer s $ mapM_ (execute_ . fromString) inserts
+
+		it "should scan project" $ do
+			void $ send s ["scan", "--project", dir </> "tests/test-package"]
+
+		it "should resolve export list" $ do
+			one <- send s ["module", "ModuleOne", "--exact"]
+			exports one `shouldBe` mkSet ["Ctor", "ctor", "test", "newChan", "untypedFoo"]
+			two <- send s ["module", "ModuleTwo", "--exact"]
+			exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings"]
+
+		it "should return cached warnings on sequential checks without file modifications" $ do
+			firstCheck <- send s ["check", "--file", dir </> "tests/test-package/ModuleOne.hs"]
+			secondCheck <- send s ["check", "--file", dir </> "tests/test-package/ModuleOne.hs"]
+			firstCheck `shouldNotSatisfy` null
+			firstCheck `shouldBe` secondCheck
+
+		it "should not lose warnings that comes while loading module for inferring types" $ do
+			void $ send s ["infer", "--file", dir </> "tests/test-package/ModuleThree.hs"]
+			checks <- send s ["check", "--file", dir </> "tests/test-package/ModuleThree.hs"]
+			checks `shouldNotSatisfy` null
+
+		it "should return module imports" $ do
+			three <- send s ["module", "ModuleThree", "--exact"]
+			imports three `shouldBe` mkSet [
+				Import (Position 8 1) "Control.Concurrent.Chan" False Nothing,
+				Import (Position 10 1) "ModuleOne" False Nothing,
+				Import (Position 11 1) "ModuleTwo" False (Just "T")]
+
+		it "should pass extensions when checks" $ do
+			checks <- send s ["check", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+			(checks ^.. traverseArray . key "level" . _Just) `shouldSatisfy` (("error" :: String) `notElem`)
+
+		it "should return types and docs" $ do
+			test' <- send s ["whois", "test", "--file", dir </> "tests/test-package/ModuleOne.hs"]
+			let
+				testType :: Maybe String
+				testType = test' ^. traverseArray . key "info" . key "type"
+			testType `shouldBe` Just "IO ()"
+
+		it "should infer types" $ do
+			ts <- send s ["types", "--file", dir </> "tests/test-package/ModuleOne.hs"]
+			let
+				untypedFooRgn = Region (Position 15 1) (Position 15 11)
+				exprs :: [(Region, String)]
+				exprs = do
+					note' <- ts ^.. traverseArray
+					rgn' <- maybeToList $ rgn (note' ^. key "region")
+					return (rgn', note' ^. key "note" . key "type" . _Just)
+			lookup untypedFooRgn exprs `shouldBe` Just "a -> a -> a" -- FIXME: Where's Num constraint?
+
+		it "should return symbol under location" $ do
+			_ <- send s ["infer", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+			who' <- send s ["whoat", "13", "15", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+			let
+				whoName :: Maybe String
+				whoName = who' ^. traverseArray . key "id" . key "name"
+				whoType :: Maybe String
+				whoType = who' ^. traverseArray . key "info" . key "type"
+			whoName `shouldBe` Just "f"
+			whoType `shouldBe` Just "a -> a"
+
+		it "should distinguish between constructor and data" $ do
+			whoData <- send s ["whoat", "20", "9", "--file", dir </> "tests/test-package/ModuleOne.hs"]
+			whoCtor <- send s ["whoat", "21", "8", "--file", dir </> "tests/test-package/ModuleOne.hs"]
+			(whoData ^. traverseArray . key "info" . key "what" :: Maybe String) `shouldBe` Just "data"
+			(whoCtor ^. traverseArray . key "info" . key "what" :: Maybe String) `shouldBe` Just "ctor"
+
+		it "should use modified file contents" $ do
+			modifiedContents <- fmap unpack $ readFileUtf8 $ dir </> "tests/data/ModuleTwo.modified.hs"
+			void $ send s ["set-file-contents", "--file", dir </> "tests/test-package/ModuleTwo.hs", "--contents", modifiedContents]
+			-- Call scan to wait until file updated
+			void $ send s ["scan", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+
+		it "should rescan module with modified contents" $ do
+			two <- send s ["module", "ModuleTwo", "--exact"]
+			exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"]
+
+		it "should use modified source in `check` command" $ do
+			checks <- send s ["check", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+			(checks ^.. traverseArray . key "note" . key "message" . _Just) `shouldSatisfy` (any ("Defined but not used" `isPrefixOf`))
+
+		it "should get usages of symbol" $ do
+			-- Note, that source was modified
+			us <- send s ["usages", "2", "2", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+			let
+				locs :: [(String, Region)]
+				locs = do
+					n <- us ^.. traverseArray
+					nm <- maybeToList $ n ^. key "in" . key "name"
+					p <- maybeToList $ rgn (n ^. key "at")
+					return (nm, p)
+			S.fromList locs `shouldBe` S.fromList [
+				("ModuleOne", Position 4 2 `region` Position 4 12),
+				("ModuleOne", Position 15 1 `region` Position 15 11),
+				("ModuleTwo", Position 2 2 `region` Position 2 12),
+				("ModuleTwo", Position 8 19 `region` Position 8 29),
+				("ModuleTwo", Position 25 21 `region` Position 25 31),
+				("ModuleTwo", Position 25 35 `region` Position 25 45)]
+
+		it "should get usages of local symbols" $ do
+			us <- send s ["usages", "14", "15", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+			let
+				locs :: [Region]
+				locs = do
+					n <- us ^.. traverseArray
+					maybeToList $ rgn (n ^. key "at")
+			S.fromList locs `shouldBe` S.fromList [
+				Position 14 7 `region` Position 14 8,
+				Position 14 11 `region` Position 14 12,
+				Position 14 15 `region` Position 14 16]
+
+		it "should evaluate expression in context of module" $ do
+			vals <- send s ["ghc", "eval", "smth [1,2,3]", "--file", dir </> "tests/test-package/ModuleThree.hs"]
+			vals ^.. traverseArray . key @String "ok" . _Just `shouldBe` ["[3,4]"]
+
+		it "should return type of expression in context of module" $ do
+			tys <- send s ["ghc", "type", "twice twice", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+			tys ^.. traverseArray . key @String "ok" . _Just `shouldBe` ["(a -> a) -> a -> a"]
+
+		it "shouldn't lose module info if unsaved source is broken" $ do
+			brokenContents <- fmap unpack $ readFileUtf8 $ dir </> "tests/data/ModuleTwo.broken.hs"
+			void $ send s ["set-file-contents", "--file", dir </> "tests/test-package/ModuleTwo.hs", "--contents", brokenContents]
+			-- Call scan to wait until file updated
+			void $ send s ["scan", "--file", dir </> "tests/test-package/ModuleTwo.hs"]
+
+			two <- send s ["module", "ModuleTwo", "--exact"]
+			exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"]
+
+		it "should complete qualified names" $ do
+			comps <- send s ["complete", "T.o", "--file", dir </> "tests/test-package/ModuleThree.hs"]
+			comps ^.. traverseArray . key "id" . key @String "name" . _Just `shouldBe` ["overloadedStrings"]
+
+		_ <- runIO $ send s ["exit"]
+		return ()
tests/data/ModuleTwo.broken.hs view
@@ -1,29 +1,29 @@-module ModuleTwo (-	untypedFoo,-	twice,-	overloadedStrings,-	useUntypedFoo-	) where--import ModuleOne (untypedFoo)--import Data.String--broken :: IO ()-broken = do-	s <----- | Apply function twice-twice :: (a -> a) -> a -> a-twice f = f . f--data MyString = MyString String--instance IsString MyString where-	fromString = MyString--overloadedStrings :: MyString-overloadedStrings = "Hello"--useUntypedFoo :: Int -> Int -> Int-useUntypedFoo x y = untypedFoo x (untypedFoo x x)+module ModuleTwo (
+	untypedFoo,
+	twice,
+	overloadedStrings,
+	useUntypedFoo
+	) where
+
+import ModuleOne (untypedFoo)
+
+import Data.String
+
+broken :: IO ()
+broken = do
+	s <-
+
+-- | Apply function twice
+twice :: (a -> a) -> a -> a
+twice f = f . f
+
+data MyString = MyString String
+
+instance IsString MyString where
+	fromString = MyString
+
+overloadedStrings :: MyString
+overloadedStrings = "Hello"
+
+useUntypedFoo :: Int -> Int -> Int
+useUntypedFoo x y = untypedFoo x (untypedFoo x x)
tests/data/ModuleTwo.modified.hs view
@@ -1,25 +1,25 @@-module ModuleTwo (-	untypedFoo,-	twice,-	overloadedStrings,-	useUntypedFoo-	) where--import ModuleOne (untypedFoo)--import Data.String---- | Apply function twice-twice :: (a -> a) -> a -> a-twice f = f . f--data MyString = MyString String--instance IsString MyString where-	fromString = MyString--overloadedStrings :: MyString-overloadedStrings = "Hello"--useUntypedFoo :: Int -> Int -> Int-useUntypedFoo x y = untypedFoo x (untypedFoo x x)+module ModuleTwo (
+	untypedFoo,
+	twice,
+	overloadedStrings,
+	useUntypedFoo
+	) where
+
+import ModuleOne (untypedFoo)
+
+import Data.String
+
+-- | Apply function twice
+twice :: (a -> a) -> a -> a
+twice f = f . f
+
+data MyString = MyString String
+
+instance IsString MyString where
+	fromString = MyString
+
+overloadedStrings :: MyString
+overloadedStrings = "Hello"
+
+useUntypedFoo :: Int -> Int -> Int
+useUntypedFoo x y = untypedFoo x (untypedFoo x x)
tests/data/base.sql view
@@ -1,4 +1,4 @@-insert into package_dbs values ('global-db', 'base', '4.9.0.0');-insert into modules values (1, null, null, json('[]'), 'base', '4.9.0.0', 'Control.Concurrent.Chan', 1, null, 'Control.Concurrent.Chan', null, json('[]'), json('{}'), null, null, json('[]'));-insert into symbols values (1, 'newChan', 1, null, null, null, 'function', 'IO (Chan a)', null, null, null, null, null, null, null);-insert into exports values (1, 1);+insert into package_dbs values ('global-db', 'base', '4.9.0.0');
+insert into modules values (1, null, null, json('[]'), 'base', '4.9.0.0', 'Control.Concurrent.Chan', 1, null, 'Control.Concurrent.Chan', null, json('[]'), json('{}'), null, null, json('[]'));
+insert into symbols values (1, 'newChan', 1, null, null, null, 'function', 'IO (Chan a)', null, null, null, null, null, null, null);
+insert into exports values (1, 1);
tests/test-package/ModuleOne.hs view
@@ -1,21 +1,21 @@-module ModuleOne (-	test,-	newChan,-	untypedFoo,-	Ctor(..), ctor,-	) where--import Control.Concurrent.Chan (newChan)---- | Some test function-test :: IO ()-test = return ()---- | Some function without type-untypedFoo x y = x + y---- | Same name of type and ctor-data Ctor a = Ctor a--ctor :: Ctor Int-ctor = Ctor 10+module ModuleOne (
+	test,
+	newChan,
+	untypedFoo,
+	Ctor(..), ctor,
+	) where
+
+import Control.Concurrent.Chan (newChan)
+
+-- | Some test function
+test :: IO ()
+test = return ()
+
+-- | Some function without type
+untypedFoo x y = x + y
+
+-- | Same name of type and ctor
+data Ctor a = Ctor a
+
+ctor :: Ctor Int
+ctor = Ctor 10
tests/test-package/ModuleThree.hs view
@@ -1,15 +1,15 @@-module ModuleThree (-	smth,--	module ModuleOne,-	module T-	) where--import Control.Concurrent.Chan--import ModuleOne (test)-import ModuleTwo as T hiding (twice)--smth :: [Int] -> [Int]-smth [] = [1]-smth (x:xs) = map (+x) xs+module ModuleThree (
+	smth,
+
+	module ModuleOne,
+	module T
+	) where
+
+import Control.Concurrent.Chan
+
+import ModuleOne (test)
+import ModuleTwo as T hiding (twice)
+
+smth :: [Int] -> [Int]
+smth [] = [1]
+smth (x:xs) = map (+x) xs
tests/test-package/test-package.cabal view
@@ -1,25 +1,25 @@-name:                test-package-version:             0.1.0.0-synopsis:            hsdev test package--- description:         --- license:             -author:              voidex-maintainer:          voidex@live.com--- copyright:           --- category:            -build-type:          Simple--- extra-source-files:  -cabal-version:       >=1.10--library-  exposed-modules:-    ModuleOne-    ModuleTwo-    ModuleThree-  -- other-modules:       -  -- other-extensions:    -  build-depends:       base >=4.8-  hs-source-dirs:      .-  default-language:    Haskell2010-  ghc-options: -Wall -fno-warn-tabs-  default-extensions: OverloadedStrings+name:                test-package
+version:             0.1.0.0
+synopsis:            hsdev test package
+-- description:         
+-- license:             
+author:              voidex
+maintainer:          voidex@live.com
+-- copyright:           
+-- category:            
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+library
+  exposed-modules:
+    ModuleOne
+    ModuleTwo
+    ModuleThree
+  -- other-modules:       
+  -- other-extensions:    
+  build-depends:       base >=4.8
+  hs-source-dirs:      .
+  default-language:    Haskell2010
+  ghc-options: -Wall -fno-warn-tabs
+  default-extensions: OverloadedStrings