packages feed

hsdev 0.3.1.4 → 0.3.2.0

raw patch · 84 files changed

+13213/−12914 lines, 84 filesdep +lens-aesondep −aeson-lensdep −ghc-syb-utilsdep ~Cabaldep ~aesondep ~containers

Dependencies added: lens-aeson

Dependencies removed: aeson-lens, ghc-syb-utils

Dependency ranges changed: Cabal, aeson, containers, exceptions, fsnotify, ghc, ghc-boot, haddock-library, lens, network, stm, template-haskell

Files

data/hsdev.sql view
@@ -1,350 +1,360 @@--- system table for various options, for now only version
-create table hsdev (
-	option text,
-	value json
-);
-
--- packages per package-db
-create table package_dbs (
-	package_db text not null, -- global, user or path
-	package_name text not null,
-	package_version text not null
-);
-
-create index package_names_index on package_dbs (package_db, package_name);
-
--- same as `package_dbs`, but only latest version of package left
-create view latest_packages (
-	package_db,
-	package_name,
-	package_version
-) as
-select package_db, package_name, max(package_version)
-from package_dbs
-group by package_db, package_name;
-
--- 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;++-- sandboxes+create table sandboxes (+	type text not null, -- cabal/stack+	path text not null, -- sandbox path, should include `.cabal-sandbox`/`.stack-work`+	package_db_stack json -- list of package-db of sandbox+);++create unique index sandboxes_path_index on sandboxes (path);++-- source projects+create table projects (+	id integer primary key autoincrement,+	name text not null,+	cabal text not null, -- path to `.cabal` file+	version text,+	build_tool text not null, -- cabal/stack+	package_db_stack json -- list of package-db+);++create unique index projects_id_index on projects (id);+create unique index projects_cabal_index on projects (cabal);++-- project's library targets+create table libraries (+	project_id integer not null,+	modules json not null, -- list of modules+	build_info_id integer not null+);++create unique index libraries_ids_index on libraries (project_id, build_info_id);++-- project's executables targets+create table executables (+	project_id integer not null,+	name text not null,+	path text not null,+	build_info_id integer not null+);++create unique index executables_ids_index on executables (project_id, build_info_id);++-- project's tests targets+create table tests (+	project_id integer not null,+	name text not null,+	enabled integer not null,+	main text,+	build_info_id integer not null+);++create unique index tests_ids_index on tests (project_id, build_info_id);++-- map from project to build-info for all targets+create view targets (+	project_id,+	build_info_id+) as+select project_id, build_info_id from libraries+union+select project_id, build_info_id from executables+union+select project_id, build_info_id from tests;++-- target build-info+create table build_infos(+	id integer primary key autoincrement,+	depends json not null, -- list of dependencies+	language text,+	extensions json not null, -- list of extensions+	ghc_options json not null, -- list of ghc-options+	source_dirs json not null, -- list of source directories+	other_modules json not null -- list of other modules+);++create unique index build_infos_id_index on build_infos (id);++-- project dependent packages+create view projects_deps (+	cabal,+	package_db,+	package_name,+	package_version+) as+select distinct p.cabal, ps.package_db, ps.package_name, ps.package_version+from projects as p, json_each(p.package_db_stack) as pdb_stack, build_infos as b, json_each(b.depends) as deps, targets as t, latest_packages as ps+where+	(p.id == t.project_id) and+	(b.id == t.build_info_id) and+	(deps.value <> p.name) and+	(ps.package_name == deps.value) and+	(ps.package_db == pdb_stack.value);++-- packages in scope of project+-- `cabal` may be null for standalone files, in this case all 'user-db' is in scope+create view projects_modules_scope (+	cabal,+	module_id+) as+select pdbs.cabal, m.id+from projects_deps as pdbs, modules as m+where+	(m.package_name == pdbs.package_name) and+	(m.package_version == pdbs.package_version) and+	m.exposed+union+select p.cabal, m.id+from projects as p, modules as m+where (m.cabal == p.cabal)+union+select null, m.id+from modules as m, latest_packages as ps+where+	(m.package_name == ps.package_name) and+	(m.package_version == ps.package_version) and+	m.exposed and+	(ps.package_db in ('user-db', 'global-db'));++-- symbols+create table symbols (+	id integer primary key autoincrement,+	name text not null,+	module_id integer not null, -- definition module+	docs text,+	line integer, -- line of definition+	column integer, -- column of definition+	what text not null, -- kind of symbol: function, method, ...+	type text, -- type of function/method/...+	parent text, -- parent of selector/method/...+	constructors json, -- list of constructors for selector+	args json, -- list of arguments for types+	context json, -- list of contexts for types+	associate text, -- associates for families+	pat_type text,+	pat_constructor text+);++create unique index symbols_id_index on symbols (id);+create unique index symbols_index on symbols (module_id, name, what);++-- modules+create table modules (+	id integer primary key autoincrement,+	-- source module location+	file text, -- source file+	cabal text, -- related project's `.cabal`+	-- installed module location+	install_dirs json, -- list of paths+	package_name text, -- package name of module+	package_version text, -- package version+	installed_name text, -- if not null, should be equal to name+	exposed integer, -- is module exposed or hidden+	-- some other location+	other_location text, -- anything++	name text,+	docs text,+	fixities json, -- list of fixities+	tags json, -- dict of tags, value not used, tag is set if present; used by hsdev to mark if types was inferred or docs scanned+	inspection_error text,+	inspection_time real,+	inspection_opts json -- list of flags+);++create unique index modules_id_index on modules (id);+create index modules_name_index on modules (name);+create unique index modules_file_index on modules (file) where file is not null;+create unique index modules_installed_index on modules (package_name, package_version, installed_name) where+	package_name is not null and+	package_version is not null and+	installed_name is not null;+create unique index modules_other_locations_index on modules (other_location) where other_location is not null;++-- module import statements+create table imports (+	module_id integer not null,+	line integer not null, -- line number of import+	column integer not null, -- column of impoty+	module_name text not null, -- import module name+	qualified integer not null, -- is import qualified+	alias text, -- imported with `as`+	hiding integer, -- is list hiding+	import_list json, -- list of import specs, null if not specified+	import_module_id -- `id` of imported module+);++create unique index imports_position_index on imports (module_id, line, column);++-- symbols bringed into scope by import, with qualifier+create view imported_scopes as+select i.*, q.value as qualifier, s.name as name, s.id as symbol_id+from imports as i, json_each(case when i.qualified then json_array(ifnull(i.alias, i.module_name)) else json_array(ifnull(i.alias, i.module_name), null) end) as q, symbols as s, exports as e+where+	e.module_id == i.import_module_id and+	e.symbol_id == s.id and+	(i.import_list is null or (s.name in (select json_extract(import_list_item.value, '$.name') from json_each(i.import_list) as import_list_item) == not i.hiding));++-- module exports+create table exports (+	module_id integer not null,+	symbol_id integer not null+);++create index exports_module_id_index on exports (module_id);++-- source file module's symbols in scope+create table scopes (+	module_id integer not null,+	qualifier text,+	name text not null,+	symbol_id integer not null+);++create index scopes_name_index on scopes (module_id, name);++-- like `scopes`, but with column `completion` with fully qualified name+create view completions (+	module_id,+	completion,+	qualifier,+	symbol_id+) as+select id, (case when sc.qualifier is null then sc.name else sc.qualifier || '.' || sc.name end) as full_name, sc.qualifier, sc.symbol_id+from modules as m, scopes as sc+where (m.id == sc.module_id);++-- resolved names in module+create table names (+	module_id integer not null,+	qualifier text, -- name qualifier+	name text not null, -- name+	line integer not null, -- line of name+	column integer not null, -- column of name+	line_to integer not null, -- line of name end+	column_to integer not null, -- column of name end+	def_line integer, -- name definition line, for local names+	def_column integer, -- name definition column, for local names+	inferred_type text, -- inferred name type, set by hsdev+	resolved_module text, -- resolved module name, for global and top-level names+	resolved_name text, -- resolved name, for global and top-level names+	resolved_what text, -- resolved symbol kind+	resolve_error text,+	symbol_id integer -- resolved symbol id+);++create unique index names_position_index on names (module_id, line, column, line_to, column_to);+create index names_name_index on names (module_id, name);++-- like `names`, but with definition position set for both local and global names+create view definitions (+	module_id,+	name,+	line,+	column,+	line_to,+	column_to,+	def_module_id,+	def_line,+	def_column,+	local+) as+select module_id, name, line, column, line_to, column_to, module_id, def_line, def_column, 1+from names+where def_line is not null and def_column is not null+union+select n.module_id, n.resolved_name, n.line, n.column, n.line_to, n.column_to, s.module_id, s.line, s.column, 0+from names as n, modules as srcm, modules as m, symbols as s+where+	(n.module_id == srcm.id) and+	(n.symbol_id == s.id) and+	(m.name == n.resolved_module) and+	(s.module_id == m.id) and+	(s.name == n.resolved_name);++-- sources dependencies relations+create view sources_depends (+	module_id,+	module_file,+	depends_id,+	depends_file+) as+select m.id, m.file, im.id, im.file+from modules as im, imports as i, modules as m, projects_modules_scope as ps+where+	(m.cabal is ps.cabal) and+	(ps.module_id == im.id) and+	(i.module_id == m.id) and+	(im.name == i.module_name) and+	(m.file is not null) and+	(im.file is not null);++-- expressions types+create table types (+	module_id integer not null,+	line integer not null, -- line of expression+	column integer not null, -- column of expression+	line_to integer not null, --  line of expression end+	column_to integer not null, -- column of expression end+	expr text not null, -- expression contents+	type text not null -- expression type+);++create unique index types_position_index on types (module_id, line, column, line_to, column_to);++-- modified file contents, hsdev will use it in commands whenever it is newer than file+create table file_contents (+	file text not null, -- file path+	contents text not null, -- file contents+	mtime real not null -- posix modification time+);++create unique index file_contents_index on file_contents (file);++-- table with last time of loading module+create table load_times (+	module_id integer not null, -- module affected+	load_time real not null -- timestamp+);++create unique index load_times_module_id_index on load_times (module_id);++-- table with ghc warnings on file+-- sequential call to load module won't actually reload file and won't produce warnings+-- but we want to see them again+create table messages (+	module_id integer not null,+	line integer not null,+	column integer not null,+	line_to integer not null,+	column_to integer not null,+	severity text,+	message text not null,+	suggestion text+);++create index messages_module_id_index on messages (module_id);
hsdev.cabal view
@@ -1,246 +1,261 @@-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
+name:                hsdev+version:             0.3.2.0+synopsis:            Haskell development library+description:+  Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.+homepage:            https://github.com/mvoidex/hsdev+license:             BSD3+license-file:        LICENSE+author:              Alexandr `Voidex` Ruchkin+maintainer:          voidex@live.com+-- copyright:+category:            Development+build-type:          Simple+cabal-version:       >=1.8+extra-source-files:+  tests/test-package/*.hs+  tests/test-package/test-package.cabal+  tests/data/base.sql+  tests/data/ModuleTwo.modified.hs+  tests/data/ModuleTwo.broken.hs+  data/hsdev.sql++source-repository head+  type: git+  location: git://github.com/mvoidex/hsdev.git++flag docs+  description: build with haddock/hdocs to support scanning docs+  default: True++flag hlint+  description: build with hlint to support linting+  default: True++library+  hs-source-dirs: src+  ghc-options: -Wall -fno-warn-tabs++  if !flag(docs)+    cpp-options: -DNODOCS++  if !flag(hlint)+    cpp-options: -DNOHLINT++  exposed-modules:+    Control.Apply.Util+    Control.Concurrent.FiniteChan+    Control.Concurrent.Worker+    Control.Concurrent.Util+    Data.Deps+    Data.Help+    Data.Lisp+    Data.Maybe.JustIf+    Data.LookupTable+    HsDev+    HsDev.Client.Commands+    HsDev.Database.SQLite+    HsDev.Database.SQLite.Instances+    HsDev.Database.SQLite.Schema+    HsDev.Database.SQLite.Schema.TH+    HsDev.Database.SQLite.Select+    HsDev.Database.SQLite.Transaction+    HsDev.Database.Update+    HsDev.Database.Update.Types+    HsDev.Display+    HsDev.Error+    HsDev.Inspect+    HsDev.Inspect.Definitions+    HsDev.Inspect.Order+    HsDev.Inspect.Resolve+    HsDev.Inspect.Types+    HsDev.PackageDb+    HsDev.PackageDb.Types+    HsDev.Project+    HsDev.Project.Compat+    HsDev.Project.Types+    HsDev.Scan+    HsDev.Scan.Browse+    HsDev.Server.Base+    HsDev.Server.Commands+    HsDev.Server.Message+    HsDev.Server.Message.Lisp+    HsDev.Server.Types+    HsDev.Sandbox+    HsDev.Stack+    HsDev.Symbols+    HsDev.Symbols.Name+    HsDev.Symbols.Class+    HsDev.Symbols.HaskellNames+    HsDev.Symbols.Location+    HsDev.Symbols.Documented+    HsDev.Symbols.Resolve+    HsDev.Symbols.Parsed+    HsDev.Symbols.Types+    HsDev.Tools.AutoFix+    HsDev.Tools.Base+    HsDev.Tools.Cabal+    HsDev.Tools.ClearImports+    HsDev.Tools.Ghc.Base+    HsDev.Tools.Ghc.Check+    HsDev.Tools.Ghc.Compat+    HsDev.Tools.Ghc.MGhc+    HsDev.Tools.Ghc.Prelude+    HsDev.Tools.Ghc.Repl+    HsDev.Tools.Ghc.Session+    HsDev.Tools.Ghc.System+    HsDev.Tools.Ghc.Types+    HsDev.Tools.Ghc.Worker+    HsDev.Tools.Hayoo+    HsDev.Tools.HDocs+    HsDev.Tools.HLint+    HsDev.Tools.Refact+    HsDev.Tools.Tabs+    HsDev.Tools.Types+    HsDev.Types+    HsDev.Util+    HsDev.Version+    HsDev.Watcher+    HsDev.Watcher.Types+    System.Directory.Paths+    System.Directory.Watcher++  if os(windows)+    build-depends:+      Win32 >= 2.3.0+    exposed-modules:+      System.Win32.PowerShell+      System.Win32.FileMapping.NamePool+      System.Win32.FileMapping.Memory+  else+    build-depends:+      unix                              >= 2.7.2.0 && < 2.8++  if impl(ghc >= 8.6) && impl(ghc < 8.7)+    build-depends:+      ghc   == 8.6.*,+      Cabal == 2.4.*++  if impl(ghc >= 8.4) && impl(ghc < 8.5)+    build-depends:+      ghc   == 8.4.*,+      Cabal == 2.2.0.1++  if impl(ghc >= 8.2) && impl(ghc < 8.3)+    build-depends:+      ghc   == 8.2.*,+      Cabal == 2.0.1.1++  if impl(ghc >= 8.0) && impl(ghc < 8.2)+    build-depends:+      ghc >= 8.0.0 && < 8.1.0,+      Cabal >= 1.24.2.0 && < 2.0++  if flag(docs)+    build-depends:+      hdocs >= 0.5.2,+      haddock-api >= 2.17.4,+      haddock-library >= 1.4.3 && < 1.7++  if flag(hlint)+    build-depends:+      hlint >= 2.0.11 && < 2.2++  -- 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.5,+    aeson-pretty                      >= 0.8.2 && < 0.9,+    array                             >= 0.5.1.1 && < 0.6,+    async                             >= 2.1.1.1 && < 2.3,+    attoparsec                        >= 0.13.1.0 && < 0.14,+    bytestring                        >= 0.10.8.1 && < 0.11,+    containers                        >= 0.5.7.1 && < 0.7,+    cpphs                             >= 1.20.5 && < 1.21,+    data-default                      >= 0.7.1.1 && < 0.8,+    deepseq                           >= 1.4.2.0 && < 1.5,+    direct-sqlite                     >= 2.3.19 && < 2.4,+    directory                         >= 1.2.6.2 && < 1.4,+    exceptions                        >= 0.8.3 && < 0.11,+    filepath                          >= 1.4.1.0 && < 1.5,+    fsnotify                          >= 0.2.1 && < 0.4,+    ghc-boot                          >= 8.0.1 && < 8.7,+    ghc-paths                         >= 0.1.0.9 && < 0.2,+    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.18,+    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.9,+    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 && < 2.6,+    syb                               >= 0.6 && < 0.8,+    template-haskell                  >= 2.11.0 && < 2.15,+    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.5,+    aeson-pretty                      >= 0.8.2 && < 0.9,+    bytestring                        >= 0.10.8.1 && < 0.11,+    containers                        >= 0.5.7.1 && < 0.7,+    deepseq                           >= 1.4.2.0 && < 1.5,+    directory                         >= 1.2.6.2 && < 1.4,+    exceptions                        >= 0.8.3 && < 0.11,+    filepath                          >= 1.4.1.0 && < 1.5,+    monad-loops                       >= 0.4.3 && < 0.5,+    mtl                               >= 2.2.1 && < 2.3,+    network                           >= 2.6.3.1 && < 2.9,+    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.5,+    lens-aeson                        >= 1.0 && < 1.1,+    async                             >= 2.1.1.1 && < 2.3,+    containers                        >= 0.5.7.1 && < 0.7,+    data-default                      >= 0.7.1.1 && < 0.8,+    deepseq                           >= 1.4.2.0 && < 1.5,+    directory                         >= 1.2.6.2 && < 1.4,+    filepath                          >= 1.4.1.0 && < 1.5,+    hformat                           >= 0.1.0.1 && < 0.4,+    hspec                             >= 2.2.4,+    lens                              >= 4.14 && < 4.18,+    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` onErr+		onErr :: MonadIO m => SomeException -> m ()+		onErr = liftIO . putMVar var . Left+		f = do+			p <- sendChan (workerChan w) (void async', void act')+			unless p $ putMVar var (Left $ SomeException WorkerStopped)+			r <- takeMVar var+			either throwM return r+	async f++-- | Close worker channel+stopWorker :: Worker m -> IO ()+stopWorker = closeChan . workerChan++-- | Stop worker and wait for it+joinWorker :: Worker m -> IO ()+joinWorker w = do+	stopWorker w+	async' <- readMVar $ workerTask w+	void $ waitCatch async'++-- | Send empty task and wait until worker run it+syncTask :: (MonadCatch m, MonadIO m) => Worker m -> IO ()+syncTask w = sendTask w (return ()) >>= void . wait++-- | Run action in worker and wait for result+inWorkerWith :: (MonadIO m, MonadCatch m, MonadIO n) => (SomeException -> n a) -> Worker m -> m a -> n a+inWorkerWith err w act = liftIO (sendTask w act) >>= (liftIO . waitCatch >=> either err return)++-- | Run action in worker and wait for result+inWorker :: (MonadIO m, MonadCatch m) => Worker m -> m a -> IO a+inWorker w act = sendTask w act >>= liftIO . wait
src/Data/Deps.hs view
@@ -1,101 +1,105 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
-
-module Data.Deps (
-	Deps(..), depsMap,
-	mapDeps,
-	dep, deps,
-	inverse,
-	DepsError(..), flatten,
-	selfDepend,
-	linearize
-	) where
-
-import Control.Lens
-import Control.Monad.State
-import Control.Monad.Except
-import Data.List (nub, intercalate)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.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.Semigroup+import Data.Maybe (fromMaybe)++-- | Dependency map+newtype Deps a = Deps {+	_depsMap :: Map a [a] }++depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b])+depsMap = lens _depsMap (const Deps)++instance Ord a => Semigroup (Deps a) where+	Deps l <> Deps r = Deps $ M.unionWith nubConcat l r++instance Ord a => Monoid (Deps a) where+	mempty = Deps mempty+	mappend (Deps l) (Deps r) = Deps $ M.unionWith nubConcat l r++instance Show a => Show (Deps a) where+	show (Deps ds) = unlines [show d ++ " -> " ++ intercalate ", " (map show s) | (d, s) <- M.toList ds]++type instance Index (Deps a) = a+type instance IxValue (Deps a) = [a]++instance Ord a => Ixed (Deps a) where+	ix k = depsMap . ix k++instance Ord a => At (Deps a) where+	at k = depsMap . at k++mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b+mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap++-- | Make single dependency+dep :: a -> a -> Deps a+dep x y = deps x [y]++-- | Make dependency for one target, note that order of dependencies is matter+deps :: a -> [a] -> Deps a+deps x ys = Deps $ M.singleton x ys++-- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it+inverse :: Ord a => Deps a -> Deps a+inverse = mconcat . map (uncurry dep) . concatMap inverse' . M.toList . _depsMap where+	inverse' :: (a, [a]) -> [(a, a)]+	inverse' (m, ds) = zip ds (repeat m)++newtype DepsError a =+	CyclicDeps [a]+	-- ^ Dependency cycle, list is cycle, where last item depends on first+		deriving (Eq, Ord, Read)++instance Show a => Show (DepsError a) where+	show (CyclicDeps c) = "dependencies forms a cycle: " ++ concat [show d ++ " -> " | d <- c] ++ "..."++-- | Flatten dependencies so that there will be no indirect dependencies+flatten :: Ord a => Deps a -> Either (DepsError a) (Deps a)+flatten s@(Deps ds) = fmap snd . flip execStateT mempty . mapM_ (flatten' s) . M.keys $ ds where+	flatten' :: Ord a => Deps a -> a -> StateT ([a], Deps a) (Either (DepsError a)) [a]+	flatten' s' n = do+		path <- gets (view _1)+		when (preview (reversed . each) path == Just n) $ throwError (CyclicDeps $ reverse path)+		d <- gets (preview $ _2 . ix n)+		case d of+			Just d' -> return d'+			Nothing -> pushPath n $ do+				d'' <- (nub . concat . (++ [deps'])) <$> mapM (flatten' s') deps'+				modify (over _2 $ mappend (deps n d''))+				return d''+				where+					deps' = fromMaybe [] $ preview (ix n) s'+	pushPath :: MonadState ([a], Deps a) m => a -> m b -> m b+	pushPath p act = do+		modify (over _1 (p:))+		r <- act+		modify (over _1 tail)+		return r++selfDepend :: Deps a -> Deps a+selfDepend = Deps . M.mapWithKey (\s d -> d ++ [s]) . _depsMap++-- | Linearize dependencies so that all items can be processed in this order,+-- i.e. for each item all its dependencies goes before+linearize :: Ord a => Deps a -> Either (DepsError a) [a]+linearize = fmap (nub . concat . toListOf (depsMap . each) . selfDepend) . flatten++nubConcat :: Ord a => [a] -> [a] -> [a]+nubConcat xs ys = nub $ xs ++ ys
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,19 @@-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,+	whenJust, whenJustM+	) where++import Control.Monad++-- | Return @Just@ if True+justIf :: a -> Bool -> Maybe a+x `justIf` True = Just x+_ `justIf` False = Nothing++-- | Calls function when value is @Just@+whenJust :: Applicative m => Maybe a -> (a -> m b) -> m ()+whenJust v fn = maybe (pure ()) (void . fn) v++-- | Calls function when monad returns @Just@+whenJustM :: Monad m => m (Maybe a) -> (a -> m b) -> m ()+whenJustM mv fn = mv >>= (`whenJust` fn)
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,706 @@-{-# 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)
+{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeOperators, TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module HsDev.Client.Commands (+	runClient, runCommand+	) where++import Control.Arrow (second)+import Control.Concurrent.MVar+import Control.Exception (displayException)+import Control.Lens hiding ((.=), (<.>))+import Control.Monad+import Control.Monad.Morph+import Control.Monad.Except+import Control.Monad.Reader+import qualified Control.Monad.State as State+import Control.Monad.Catch (try, catch, bracket, SomeException(..))+import Data.Aeson hiding (Result, Error)+import Data.List+import Data.Maybe+import qualified Data.Map.Strict as M+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T (append, null)+import System.Directory+import System.FilePath+import qualified System.Log.Simple as Log+import qualified System.Log.Simple.Base as Log+import Text.Read (readMaybe)++import Data.Maybe.JustIf+import qualified System.Directory.Watcher as W+import System.Directory.Paths+import Text.Format+import HsDev.Error+import HsDev.Database.SQLite as SQLite+import HsDev.Inspect (preload, asModule)+import HsDev.Scan (upToDate, getFileContents)+import HsDev.Server.Message as M+import HsDev.Server.Types+import HsDev.Sandbox hiding (findSandbox)+import qualified HsDev.Sandbox as S (findSandbox)+import HsDev.Symbols+import qualified HsDev.Tools.AutoFix as AutoFix+import qualified HsDev.Tools.Cabal as Cabal+import HsDev.Tools.Ghc.Session+import HsDev.Tools.Ghc.Worker (clearTargets)+import qualified HsDev.Tools.Ghc.Compat as Compat+import qualified HsDev.Tools.Ghc.Check as Check+import qualified HsDev.Tools.Ghc.Types as Types+import qualified HsDev.Tools.Hayoo as Hayoo+import qualified HsDev.Tools.HDocs as HDocs+import qualified HsDev.Tools.HLint as HLint+import qualified HsDev.Tools.Types as Tools+import HsDev.Util+import HsDev.Watcher++import qualified HsDev.Database.Update as Update++runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result+runClient copts = mapServerM toResult . runClientM where+	toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result+	toResult act = liftM errorToResult $ runReaderT (try (try act)) copts+	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b+	mapServerM f = ServerM . mapReaderT f . runServerM+	errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result+	errorToResult = either (Error . UnhandledError . displayException) (either Error (Result . toJSON))++toValue :: (ToJSON a, Monad m) => m a -> m Value+toValue = fmap toJSON++runCommand :: ServerMonadBase m => Command -> ClientM m Value+runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]+runCommand (Listen (Just l)) = case Log.level (pack l) of+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l+	Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)+runCommand (Listen Nothing) = toValue $ do+	serverListen >>= mapM_ (commandNotify . Notification . toJSON)+runCommand (SetLogLevel l) = case Log.level (pack l) of+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l+	Just lev -> toValue $ do+		lev' <- serverSetLogLevel lev+		Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev+		Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev+runCommand (Scan projs cabal sboxes fs paths' btool ghcs' docs' infer') = toValue $ do+	sboxes' <- getSandboxes sboxes+	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [+		[Update.scanCabal ghcs' | cabal],+		map (Update.scanSandbox ghcs') sboxes',+		[Update.scanFiles (zip fs (repeat ghcs'))],+		map (Update.scanProject ghcs' btool) projs,+		map (Update.scanDirectory ghcs') paths']+runCommand (ScanProject proj tool deps) = toValue $ updateProcess def [+	(if deps then Update.scanProjectStack else Update.scanProject) [] tool proj]+runCommand (ScanFile fpath tool scanProj deps) = toValue $ updateProcess def [+	Update.scanFile [] fpath tool scanProj deps]+runCommand (ScanPackageDbs pdbs) = toValue $ updateProcess def [+	Update.scanPackageDbStack [] pdbs]+runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts+runCommand (RefineDocs projs fs)+	| HDocs.hdocsSupported = toValue $ 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+			can <- canRemove pdbs+			when can $ do+				State.modify (delete pdbs)+				ms <- liftM (map fromOnly) $ query_+					"select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;"+				removePackageDb (topPackageDb pdbs)+				mapM_ SQLite.removeModule ms+				whenJustM (askSession sessionWatcher) $ \w ->+					liftIO $ unwatchPackageDb w $ topPackageDb pdbs+		-- Remove package-db stack when possible+		removePackageDbStack = mapM_ removePackageDb' . packageDbStacks+	projects <- traverse findProject projs+	sboxes' <- getSandboxes sboxes+	forM_ projects $ \proj -> do+		ms <- liftM (map fromOnly) $ query "select id from modules where cabal == ?;" (Only $ proj ^. projectCabal)+		SQLite.removeProject proj+		mapM_ SQLite.removeModule ms+		whenJustM (askSession sessionWatcher) $ \w ->+			liftIO $ unwatchProject w proj++	allPdbs <- liftM (map fromOnly) $ query_ @(Only PackageDb) "select package_db from package_dbs;"+	dbPDbs <- inSessionGhc $ mapM restorePackageDbStack allPdbs+	flip State.evalStateT dbPDbs $ do+		when cabal $ removePackageDbStack userDb+		forM_ sboxes' $ \sbox -> do+			pdbs <- lift $ inSessionGhc $ sandboxPackageDbStack sbox+			removePackageDbStack pdbs++	forM_ files $ \file -> do+		ms <- query @_ @(ModuleId :. Only Int)+			(toQuery $ mconcat [+				qModuleId,+				select_ ["mu.id"],+				where_ ["mu.file == ?"]])+			(Only file)+		forM_ ms $ \(m :. Only i) -> do+			SQLite.removeModule i+			whenJustM (askSession sessionWatcher) $ \w ->+				liftIO . unwatchModule w $ (m ^. moduleLocation)+runCommand RemoveAll = toValue $ do+	SQLite.purge+	whenJustM (askSession sessionWatcher) $ \w -> do+		wdirs <- liftIO $ readMVar (W.watcherDirs w)+		liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir+runCommand InfoPackages = toValue $+	query_ @ModulePackage "select package_name, package_version from package_dbs;"+runCommand InfoProjects = toValue $ do+	ps <- query_ @(Only Path) "select cabal from projects;"+	mapM (SQLite.loadProject . fromOnly) ps+runCommand InfoSandboxes = toValue $ do+	rs <- query_ @(Only PackageDb) "select distinct package_db from package_dbs;"+	return [pdb | Only pdb <- rs]+runCommand (InfoSymbol sq filters True _) = toValue $ do+	let+		(conds, params) = targetFilters "m" (Just "s") filters+	queryNamed @SymbolId+		(toQuery $ mconcat [+			qSymbolId,+			where_ ["s.name like :pattern escape '\\'"],+			where_ conds])+		([":pattern" := likePattern sq] ++ params)+runCommand (InfoSymbol sq filters False _) = toValue $ do+	let+		(conds, params) = targetFilters "m" (Just "s") filters+	queryNamed @Symbol+		(toQuery $ mconcat [+			qSymbol,+			where_ ["s.name like :pattern escape '\\'"],+			where_ conds])+		([":pattern" := likePattern sq] ++ params)+runCommand (InfoModule sq filters h _) = toValue $ do+	let+		(conds, params) = targetFilters "mu" Nothing filters+	rs <- queryNamed @(Only Int :. ModuleId)+		(toQuery $ mconcat [+			select_ ["mu.id"],+			qModuleId,+			where_ ["mu.name like :pattern escape '\\'"],+			where_ conds])+		([":pattern" := likePattern sq] ++ params)+	if h+		then return (toJSON $ map (\(_ :. m) -> m) rs)+		else liftM toJSON $ forM rs $ \(Only mid :. mheader) -> do+			[(docs, fixities)] <- query @_ @(Maybe Text, Maybe Value) "select m.docs, m.fixities from modules as m where (m.id == ?);"+				(Only mid)+			let+				fixities' = fromMaybe [] (fixities >>= fromJSON')+			imports' <- query @_ @Import (toQuery $ mconcat [+				qImport "i",+				where_ ["i.module_id = ?"]])+				(Only mid)+			exports' <- query @_ @Symbol (toQuery $ mconcat [+				qSymbol,+				from_ ["exports as e"],+				where_ ["e.module_id == ?", "e.symbol_id == s.id"]])+				(Only mid)+			return $ Module mheader docs imports' exports' fixities' mempty Nothing+runCommand (InfoProject (Left projName)) = toValue $ findProject projName+runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject (view path projPath)+runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandboxes sandbox'+runCommand (Lookup nm fpath) = toValue $+	fmap (map (\(s :. m) -> ImportedSymbol s m)) $ query @_ @(Symbol :. ModuleId) (toQuery $ mconcat [+		qSymbol,+		qModuleId,+		from_ ["projects_modules_scope as pms", "modules as srcm", "exports as e"],+		where_ [+			"pms.cabal is srcm.cabal",+			"srcm.file = ?",+			"pms.module_id = e.module_id",+			"m.id = s.module_id",+			"s.id = e.symbol_id",+			"e.module_id = mu.id",+			"s.name = ?"]])+		(fpath ^. path, nm)+runCommand (Whois nm fpath) = toValue $ do+	let+		q = nameModule $ toName nm+		ident = nameIdent $ toName nm+	query @_ @Symbol (toQuery $ mconcat [+		qSymbol,+		from_ ["modules as srcm", "scopes as sc"],+		where_ [+			"srcm.id == sc.module_id",+			"s.id == sc.symbol_id",+			"srcm.file == ?",+			"sc.qualifier is ?",+			"sc.name == ?"]])+		(fpath ^. path, q, ident)+runCommand (Whoat l c fpath) = toValue $ do+	rs <- query @_ @Symbol (toQuery $ mconcat [+		qSymbol,+		from_ ["names as n", "modules as srcm"],+		where_ [+			"srcm.id == n.module_id",+			"m.name == n.resolved_module",+			"s.name == n.resolved_name",+			"s.what == n.resolved_what",+			"s.id == n.symbol_id",+			"srcm.file == ?",+			"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])+		(fpath ^. path, l, c)+	locals <- do+		defs <- query @_ @(ModuleId :. (Text, Int, Int, Maybe Text)) (toQuery $ mconcat [+			qModuleId,+			select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type"],+			from_ ["names as n"],+			where_ [+				"mu.id == n.module_id",+				"n.def_line is not null",+				"n.def_column is not null",+				"mu.file == ?",+				"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])+			(fpath ^. path, l, c)+		return [+			Symbol {+				_symbolId = SymbolId nm mid,+				_symbolDocs = Nothing,+				_symbolPosition = Just (Position defLine defColumn),+				_symbolInfo = Function ftype+			} | (mid :. (nm, defLine, defColumn, ftype)) <- defs]+	return $ rs ++ locals+runCommand (ResolveScopeModules sq fpath) = toValue $ do+	pids <- query @_ @(Only (Maybe Path)) "select m.cabal from modules as m where (m.file == ?);"+		(Only $ fpath ^. path)+	case pids of+		[] -> hsdevError $ OtherError $ "module at {} not found" ~~ fpath+		[Only proj] -> query @_ @ModuleId (toQuery $ mconcat [+			qModuleId,+			from_ ["projects_modules_scope as msc"],+			where_ [+				"msc.module_id == mu.id",+				"msc.cabal is ?",+				"mu.name like ? escape '\\'"]])+			(proj, likePattern sq)+		_ -> fail "Impossible happened: several projects for one module"+runCommand (ResolveScope sq fpath) = toValue $+	query @_ @(Scoped SymbolId) (toQuery $ mconcat [+		qSymbolId,+		select_ ["sc.qualifier"],+		from_ ["scopes as sc", "modules as srcm"],+		where_ [+			"srcm.id == sc.module_id",+			"sc.symbol_id == s.id",+			"srcm.file == ?",+			"s.name like ? escape '\\'"]])+		(fpath ^. path, likePattern sq)+runCommand (FindUsages l c fpath) = toValue $ do+	us <- do+		sids <- query @_ @(Only (Maybe Int)) (toQuery $ mconcat [+			select_ ["n.symbol_id"],+			from_ ["names as n", "modules as srcm"],+			where_ [+				"n.module_id == srcm.id",+				"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)",+				"srcm.file = ?"]])+			(l, c, fpath)+		when (length sids > 1) $ Log.sendLog Log.Warning $ "multiple symbols found at location {0}:{1}:{2}" ~~ fpath ~~ l ~~ c+		let+			msid = join $ fmap fromOnly $ listToMaybe sids+		query @_ @SymbolUsage (toQuery $ mconcat [+			qSymbol,+			select_ ["n.qualifier"],+			qModuleId,+			select_ ["n.line", "n.column", "n.line_to", "n.column_to"],+			from_ ["names as n"],+			where_ [+				"n.symbol_id == ?",+				"s.id == n.symbol_id",+				"mu.id == n.module_id"]])+			(Only msid)+	locals <- do+		defs <- query @_ @(ModuleId :. Only Text :. Position :. Only (Maybe Text) :. Region) (toQuery $ mconcat [+			qModuleId,+			select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type", "n.line", "n.column", "n.line_to", "n.column_to"],+			from_ ["names as n", "names as defn"],+			where_ [+				"n.module_id = mu.id",+				"n.def_line = defn.def_line",+				"n.def_column = defn.def_column",+				"defn.module_id = mu.id",+				"(?, ?) between (defn.line, defn.column) and (defn.line_to, defn.column_to)",+				"mu.file = ?"]])+			(l, c, fpath ^. path)+		return $ do+			(mid :. Only nm :. defPos :. Only ftype :. useRgn) <- defs+			let+				sym = Symbol {+					_symbolId = SymbolId nm mid,+					_symbolDocs = Nothing,+					_symbolPosition = Just defPos,+					_symbolInfo = Function ftype }+			return $ SymbolUsage sym Nothing mid useRgn+	return $ us ++ locals+runCommand (Complete input True fpath) = toValue $+	query @_ @Symbol (toQuery $ mconcat [+		qSymbol,+		from_ ["modules as srcm", "exports as e"],+		where_ [+			"e.module_id in (select srcm.id union select module_id from projects_modules_scope where (((cabal is null) and (srcm.cabal is null)) or (cabal == srcm.cabal)))",+			"s.id == e.symbol_id",+			"msrc.file == ?",+			"s.name like ? escape '\\'"]])+		(fpath ^. path, likePattern (SearchQuery input SearchPrefix))+runCommand (Complete input False fpath) = toValue $+	query @_ @(Scoped Symbol) (toQuery $ mconcat [+		qSymbol,+		select_ ["c.qualifier"],+		from_ ["completions as c", "modules as srcm"],+		where_ [+			"c.module_id == srcm.id",+			"c.symbol_id == s.id",+			"srcm.file == ?",+			"c.completion like ? escape '\\'"]])+		(fpath ^. path, likePattern (SearchQuery input SearchPrefix))+runCommand (Hayoo hq p ps) = 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,501 +1,501 @@-{-# LANGUAGE OverloadedStrings, TypeOperators, TypeApplications #-}
-
-module HsDev.Database.SQLite (
-	initialize, purge,
-	privateMemory, sharedMemory,
-	query, query_, queryNamed, execute, execute_, executeMany, executeNamed,
-	withTemporaryTable,
-	updatePackageDb, removePackageDb, insertPackageDb,
-	updateProject, removeProject, insertProject, insertBuildInfo,
-	removeModuleContents, removeModule,
-	lookupModuleLocation, lookupModule,
-	lookupSymbol,
-	lastRow,
-
-	loadModule, loadModules,
-	loadProject,
-
-	updateModules, upsertModules,
-
-	-- * Utils
-	lookupId,
-	escapeLike,
-
-	-- * Reexports
-	module Database.SQLite.Simple,
-	module HsDev.Database.SQLite.Select,
-	module HsDev.Database.SQLite.Instances,
-	module HsDev.Database.SQLite.Transaction
-	) where
-
-import Control.Lens hiding ((.=))
-import Control.Monad
-import Control.Monad.Catch
-import Control.Monad.IO.Class
-import Data.Aeson hiding (Error)
-import Data.List (intercalate)
-import Data.Maybe
-import Data.String
-import qualified Data.Set as S
-import Data.Text (Text)
-import qualified Data.Text as T
-import Database.SQLite.Simple hiding (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)
-import qualified Database.SQLite.Simple as SQL (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)
-import Distribution.Text (display)
-import Language.Haskell.Extension ()
-import System.Directory
-import System.Log.Simple
-import Text.Format
-
-import System.Directory.Paths
-
-import HsDev.Database.SQLite.Instances
-import HsDev.Database.SQLite.Schema
-import HsDev.Database.SQLite.Select
-import HsDev.Database.SQLite.Transaction
-import qualified HsDev.Display as Display
-import HsDev.Error
-import HsDev.PackageDb.Types
-import HsDev.Project.Types
-import HsDev.Symbols (hasTag)
-import HsDev.Symbols.Types hiding (loadProject)
-import HsDev.Server.Types
-import HsDev.Util
-
--- | Open new connection and set some pragmas
-new :: String -> IO Connection
-new p = do
-	conn <- open p
-	SQL.execute_ conn "pragma case_sensitive_like = true;"
-	SQL.execute_ conn "pragma synchronous = off;"
-	SQL.execute_ conn "pragma journal_mode = memory;"
-	return conn
-
--- | Initialize database
-initialize :: String -> IO Connection
-initialize p = do
-	conn <- new p
-	[Only hasTables] <- SQL.query_ conn "select count(*) > 0 from sqlite_master where type == 'table';"
-	goodVersion <- if hasTables
-		then do
-			[Only equalVersion] <- SQL.query conn "select sum(json(value) == json(?)) > 0 from hsdev where option == 'version';" (Only $ toJSON version)
-			return equalVersion
-		else return True
-	let
-		start
-			| not goodVersion = do
-					close conn
-					removeFile p
-					conn' <- new p
-					initDb conn'
-			| not hasTables = initDb conn
-			| otherwise = return conn
-		initDb conn' = SQL.withTransaction conn' $ do
-			mapM_ (SQL.execute_ conn') commands
-			SQL.execute @(Text, Value) conn' "insert into hsdev values (?, ?);" ("version", toJSON version)
-			return conn'
-	start
-
-purge :: SessionMonad m => m ()
-purge = do
-	tables <- query_ @(Only String) "select name from sqlite_master where type == 'table';"
-	forM_ tables $ \(Only table) ->
-		execute_ $ fromString $ "delete from {};" ~~ table
-
--- | Private memory for db
-privateMemory :: String
-privateMemory = ":memory:"
-
--- | Shared db in memory
-sharedMemory :: String
-sharedMemory = "file::memory:?cache=shared"
-
--- | Retries for simple queries
-retried :: (MonadIO m, MonadCatch m) => m a -> m a
-retried = retry def
-
-query :: (ToRow q, FromRow r, SessionMonad m) => Query -> q -> m [r]
-query q' params = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.query conn q' params
-
-query_ :: (FromRow r, SessionMonad m) => Query -> m [r]
-query_ q' = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.query_ conn q'
-
-queryNamed :: (FromRow r, SessionMonad m) => Query -> [NamedParam] -> m [r]
-queryNamed q' ps' = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.queryNamed conn q' ps'
-
-execute :: (ToRow q, SessionMonad m) => Query -> q -> m ()
-execute q' params = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.execute conn q' params
-
-execute_ :: SessionMonad m => Query -> m ()
-execute_ q' = retried $ do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.execute_ conn q'
-
-executeMany :: (ToRow q, SessionMonad m) => Query -> [q] -> m ()
-executeMany q' params = do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.executeMany conn q' params
-
-executeNamed :: SessionMonad m => Query -> [NamedParam] -> m ()
-executeNamed q' ps' = do
-	conn <- serverSqlDatabase
-	liftIO $ SQL.executeNamed conn q' ps'
-
-withTemporaryTable :: SessionMonad m => String -> [String] -> m a -> m a
-withTemporaryTable tableName columns = bracket_ createTable dropTable where
-	createTable = execute_ $ fromString $ "create temporary table {} ({});" ~~ tableName ~~ (intercalate ", " columns)
-	dropTable = execute_ $ fromString $ "drop table {};" ~~ tableName
-
-updatePackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()
-updatePackageDb pdb pkgs = scope "update-package-db" $ transaction_ Immediate $ do
-	sendLog Trace $ "update package-db: {}" ~~ Display.display pdb
-	removePackageDb pdb
-	insertPackageDb pdb pkgs
-
-removePackageDb :: SessionMonad m => PackageDb -> m ()
-removePackageDb pdb = scope "remove-package-db" $
-	execute "delete from package_dbs where package_db == ?;" (Only pdb)
-
-insertPackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()
-insertPackageDb pdb pkgs = scope "insert-package-db" $ forM_ pkgs $ \pkg ->
-	execute
-		"insert into package_dbs (package_db, package_name, package_version) values (?, ?, ?);"
-		(pdb, pkg ^. packageName, pkg ^. packageVersion)
-
-updateProject :: SessionMonad m => Project -> m ()
-updateProject proj = scope "update-project" $ transaction_ Immediate $ do
-	sendLog Trace $ "update project: {}" ~~ Display.display proj
-	removeProject proj
-	insertProject proj
-
-removeProject :: SessionMonad m => Project -> m ()
-removeProject proj = scope "remove-project" $ do
-	projId <- query @_ @(Only Int) "select id from projects where cabal == ?;" (Only $ proj ^. projectCabal)
-	case projId of
-		[] -> return ()
-		pids -> do
-			when (length pids > 1) $
-				sendLog Warning $ "multiple projects for cabal {} found" ~~ (proj ^. projectCabal)
-			forM_ pids $ \pid -> do
-				bids <- query @_ @(Only Int) "select build_info_id from targets where project_id == ?;" pid
-				execute "delete from projects where id == ?;" pid
-				execute "delete from libraries where project_id == ?;" pid
-				execute "delete from executables where project_id == ?;" pid
-				execute "delete from tests where project_id == ?;" pid
-				forM_ bids $ \bid -> execute "delete from build_infos where id == ?;" bid
-
-insertProject :: SessionMonad m => Project -> m ()
-insertProject proj = scope "insert-project" $ do
-	execute "insert into projects (name, cabal, version, 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"
+{-# LANGUAGE OverloadedStrings, TypeOperators, TypeApplications #-}++module HsDev.Database.SQLite (+	initialize, purge,+	privateMemory, sharedMemory,+	query, query_, queryNamed, execute, execute_, executeMany, executeNamed,+	withTemporaryTable,+	updatePackageDb, removePackageDb, insertPackageDb,+	updateProject, removeProject, insertProject, insertBuildInfo,+	removeModuleContents, removeModule,+	lookupModuleLocation, lookupModule,+	lookupSymbol,+	lastRow,++	loadModule, loadModules,+	loadProject,++	updateModules, upsertModules,++	-- * Utils+	lookupId,+	escapeLike,++	-- * Reexports+	module Database.SQLite.Simple,+	module HsDev.Database.SQLite.Select,+	module HsDev.Database.SQLite.Instances,+	module HsDev.Database.SQLite.Transaction+	) where++import Control.Lens hiding ((.=))+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Aeson hiding (Error)+import Data.List (intercalate)+import Data.Maybe+import Data.String+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Database.SQLite.Simple hiding (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)+import qualified Database.SQLite.Simple as SQL (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)+import Distribution.Text (display)+import Language.Haskell.Extension ()+import System.Directory+import System.Log.Simple+import Text.Format++import System.Directory.Paths++import HsDev.Database.SQLite.Instances+import HsDev.Database.SQLite.Schema+import HsDev.Database.SQLite.Select+import HsDev.Database.SQLite.Transaction+import qualified HsDev.Display as Display+import HsDev.Error+import HsDev.PackageDb.Types+import HsDev.Project.Types+import HsDev.Symbols (hasTag)+import HsDev.Symbols.Types hiding (loadProject)+import HsDev.Server.Types+import HsDev.Util++-- | Open new connection and set some pragmas+new :: String -> IO Connection+new p = do+	conn <- open p+	SQL.execute_ conn "pragma case_sensitive_like = true;"+	SQL.execute_ conn "pragma synchronous = off;"+	SQL.execute_ conn "pragma journal_mode = memory;"+	return conn++-- | Initialize database+initialize :: String -> IO Connection+initialize p = do+	conn <- new p+	[Only hasTables] <- SQL.query_ conn "select count(*) > 0 from sqlite_master where type == 'table';"+	goodVersion <- if hasTables+		then do+			[Only equalVersion] <- SQL.query conn "select sum(json(value) == json(?)) > 0 from hsdev where option == 'version';" (Only $ toJSON version)+			return equalVersion+		else return True+	let+		start+			| not goodVersion = do+					close conn+					removeFile p+					conn' <- new p+					initDb conn'+			| not hasTables = initDb conn+			| otherwise = return conn+		initDb conn' = SQL.withTransaction conn' $ do+			mapM_ (SQL.execute_ conn') commands+			SQL.execute @(Text, Value) conn' "insert into hsdev values (?, ?);" ("version", toJSON version)+			return conn'+	start++purge :: SessionMonad m => m ()+purge = do+	tables <- query_ @(Only String) "select name from sqlite_master where type == 'table';"+	forM_ tables $ \(Only table) ->+		execute_ $ fromString $ "delete from {};" ~~ table++-- | Private memory for db+privateMemory :: String+privateMemory = ":memory:"++-- | Shared db in memory+sharedMemory :: String+sharedMemory = "file::memory:?cache=shared"++-- | Retries for simple queries+retried :: (MonadIO m, MonadCatch m) => m a -> m a+retried = retry def++query :: (ToRow q, FromRow r, SessionMonad m) => Query -> q -> m [r]+query q' params = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.query conn q' params++query_ :: (FromRow r, SessionMonad m) => Query -> m [r]+query_ q' = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.query_ conn q'++queryNamed :: (FromRow r, SessionMonad m) => Query -> [NamedParam] -> m [r]+queryNamed q' ps' = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.queryNamed conn q' ps'++execute :: (ToRow q, SessionMonad m) => Query -> q -> m ()+execute q' params = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.execute conn q' params++execute_ :: SessionMonad m => Query -> m ()+execute_ q' = retried $ do+	conn <- serverSqlDatabase+	liftIO $ SQL.execute_ conn q'++executeMany :: (ToRow q, SessionMonad m) => Query -> [q] -> m ()+executeMany q' params = do+	conn <- serverSqlDatabase+	liftIO $ SQL.executeMany conn q' params++executeNamed :: SessionMonad m => Query -> [NamedParam] -> m ()+executeNamed q' ps' = do+	conn <- serverSqlDatabase+	liftIO $ SQL.executeNamed conn q' ps'++withTemporaryTable :: SessionMonad m => String -> [String] -> m a -> m a+withTemporaryTable tableName columns = bracket_ createTable dropTable where+	createTable = execute_ $ fromString $ "create temporary table {} ({});" ~~ tableName ~~ (intercalate ", " columns)+	dropTable = execute_ $ fromString $ "drop table {};" ~~ tableName++updatePackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()+updatePackageDb pdb pkgs = scope "update-package-db" $ transaction_ Immediate $ do+	sendLog Trace $ "update package-db: {}" ~~ Display.display pdb+	removePackageDb pdb+	insertPackageDb pdb pkgs++removePackageDb :: SessionMonad m => PackageDb -> m ()+removePackageDb pdb = scope "remove-package-db" $+	execute "delete from package_dbs where package_db == ?;" (Only pdb)++insertPackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m ()+insertPackageDb pdb pkgs = scope "insert-package-db" $ forM_ pkgs $ \pkg ->+	execute+		"insert into package_dbs (package_db, package_name, package_version) values (?, ?, ?);"+		(pdb, pkg ^. packageName, pkg ^. packageVersion)++updateProject :: SessionMonad m => Project -> m ()+updateProject proj = scope "update-project" $ transaction_ Immediate $ do+	sendLog Trace $ "update project: {}" ~~ Display.display proj+	removeProject proj+	insertProject proj++removeProject :: SessionMonad m => Project -> m ()+removeProject proj = scope "remove-project" $ do+	projId <- query @_ @(Only Int) "select id from projects where cabal == ?;" (Only $ proj ^. projectCabal)+	case projId of+		[] -> return ()+		pids -> do+			when (length pids > 1) $+				sendLog Warning $ "multiple projects for cabal {} found" ~~ (proj ^. projectCabal)+			forM_ pids $ \pid -> do+				bids <- query @_ @(Only Int) "select build_info_id from targets where project_id == ?;" pid+				execute "delete from projects where id == ?;" pid+				execute "delete from libraries where project_id == ?;" pid+				execute "delete from executables where project_id == ?;" pid+				execute "delete from tests where project_id == ?;" pid+				forM_ bids $ \bid -> execute "delete from build_infos where id == ?;" bid++insertProject :: SessionMonad m => Project -> m ()+insertProject proj = scope "insert-project" $ do+	execute "insert into projects (name, cabal, version, build_tool, package_db_stack) values (?, ?, ?, ?, ?);" proj+	projId <- lastRow++	forM_ (proj ^? projectDescription . _Just . projectLibrary . _Just) $ \lib -> do+		buildInfoId <- insertBuildInfo $ lib ^. libraryBuildInfo+		execute "insert into libraries (project_id, modules, build_info_id) values (?, ?, ?);"+			(projId, encode $ lib ^. libraryModules, buildInfoId)++	forM_ (proj ^.. projectDescription . _Just . projectExecutables . each) $ \exe -> do+		buildInfoId <- insertBuildInfo $ exe ^. executableBuildInfo+		execute "insert into executables (project_id, name, path, build_info_id) values (?, ?, ?, ?);"+			(projId, exe ^. executableName, exe ^. executablePath . path, buildInfoId)++	forM_ (proj ^.. projectDescription . _Just . projectTests . each) $ \test -> do+		buildInfoId <- insertBuildInfo $ test ^. testBuildInfo+		execute "insert into tests (project_id, name, enabled, main, build_info_id) values (?, ?, ?, ?, ?);"+			(projId, test ^. testName, test ^. testEnabled, test ^? testMain . _Just . path, buildInfoId)++insertBuildInfo :: SessionMonad m => Info -> m Int+insertBuildInfo info = scope "insert-build-info" $ do+	execute "insert into build_infos (depends, language, extensions, ghc_options, source_dirs, other_modules) values (?, ?, ?, ?, ?, ?);" (+			encode $ info ^. infoDepends,+			fmap display $ info ^. infoLanguage,+			encode $ map display $ info ^. infoExtensions,+			encode $ info ^. infoGHCOptions,+			encode $ info ^.. infoSourceDirs . each . path,+			encode $ info ^. infoOtherModules)+	lastRow++removeModuleContents :: SessionMonad m => Int -> m ()+removeModuleContents mid = scope "remove-module-contents" $ do+	execute "delete from imports where module_id = ?;" (Only mid)+	execute "delete from exports where module_id = ?;" (Only mid)+	execute "delete from scopes where module_id = ?;" (Only mid)+	execute "delete from names where module_id = ?;" (Only mid)+	execute "delete from types where module_id = ?;" (Only mid)+	execute "delete from symbols where module_id = ?;" (Only mid)++removeModule :: SessionMonad m => Int -> m ()+removeModule mid = scope "remove-module" $ do+	removeModuleContents mid+	execute "delete from modules where id == ?;" (Only mid)++upsertModules :: SessionMonad m => [InspectedModule] -> m [Int]+upsertModules ims = scope "upsert-modules" $ bracket_ initTemp removeTemp $ do+	executeMany "insert into upserted_modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ map moduleData ims+	execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location));"+	execute_ "insert or replace into modules (id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is not null;"+	execute_ "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is null;"+	execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location)) where id is null;"++	liftM (map fromOnly) $ query_ "select id from upserted_modules order by rowid;"+	where+		initTemp :: SessionMonad m => m ()+		initTemp = do+			execute_ "create temporary table upserted_modules as select * from modules where 0;"+			execute_ "create index upserted_modules_id_index on upserted_modules (id);"++		removeTemp :: SessionMonad m => m ()+		removeTemp = execute_ "drop table if exists upserted_modules;"++		moduleData im = (+			im ^? inspectedKey . moduleFile . path,+			im ^? inspectedKey . moduleProject . _Just . projectCabal,+			fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs),+			im ^? inspectedKey . modulePackage . packageName,+			im ^? inspectedKey . modulePackage . packageVersion,+			im ^? inspectedKey . installedModuleName,+			im ^? inspectedKey . installedModuleExposed,+			im ^? inspectedKey . otherLocationName)+			:. (+			msum [im ^? inspected . moduleId . moduleName, im ^? inspectedKey . installedModuleName],+			im ^? inspected . moduleDocs,+			fmap encode $ im ^? inspected . moduleFixities,+			encode $ asDict $ im ^. inspectionTags,+			fmap show $ im ^? inspectionResult . _Left)+			:.+			fromMaybe InspectionNone (im ^? inspection)+		asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags]++lookupModuleLocation :: SessionMonad m => ModuleLocation -> m (Maybe Int)+lookupModuleLocation m = do+	mids <- queryNamed "select id from modules where (file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location);" [+		":file" := m ^? moduleFile . path,+		":package_name" := m ^? modulePackage . packageName,+		":package_version" := m ^? modulePackage . packageVersion,+		":installed_name" := m ^? installedModuleName,+		":other_location" := m ^? otherLocationName]+	when (length mids > 1) $ sendLog Warning  $ "different modules with location: {}" ~~ Display.display m+	return $ listToMaybe [mid | Only mid <- mids]++lookupModule :: SessionMonad m => ModuleId -> m (Maybe Int)+lookupModule m = do+	mids <- queryNamed "select id from modules where ((name is null and :name is null) or name = :name) and ((file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location));" [+		":name" := m ^. moduleName,+		":file" := m ^? moduleLocation . moduleFile . path,+		":package_name" := m ^? moduleLocation . modulePackage . packageName,+		":package_version" := m ^? moduleLocation . modulePackage . packageVersion,+		":installed_name" := m ^? moduleLocation . installedModuleName,+		":other_location" := m ^? moduleLocation . otherLocationName]+	when (length mids > 1) $ sendLog Warning  $ "different modules with same name and location: {}" ~~ (m ^. moduleName)+	return $ listToMaybe [mid | Only mid <- mids]++lookupSymbol :: SessionMonad m => Int -> SymbolId -> m (Maybe Int)+lookupSymbol mid sym = do+	sids <- query "select id from symbols where name == ? and module_id == ?;" (+		sym ^. symbolName,+		mid)+	when (length sids > 1) $ sendLog Warning $ "different symbols with same module id: {}.{}" ~~ show mid ~~ (sym ^. symbolName)+	return $ listToMaybe [sid | Only sid <- sids]++lastRow :: SessionMonad m => m Int+lastRow = do+	[Only i] <- query_ "select last_insert_rowid();"+	return i++loadModule :: SessionMonad m => Int -> m Module+loadModule mid = scope "load-module" $ do+	ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int))+		(toQuery $ mconcat [+			qModuleId,+			select_ ["mu.docs", "mu.fixities", "mu.id"],+			where_ [fromString "mu.id == ?"]])+		(Only mid)+	case ms of+		[] -> sqlFailure $ "module with id {} not found" ~~ mid+		mods@((mid' :. (mdocs, mfixities, _)):_) -> do+			when (length mods > 1) $ sendLog Warning $ "multiple modules with same id = {} found" ~~ mid+			syms <- query @_ @Symbol+				(toQuery $ mconcat [+					qSymbol,+					from_ ["exports as e"],+					where_ ["e.module_id == ?", "e.symbol_id == s.id"]])+				(Only mid)+			imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid)+			return Module {+				_moduleId = mid',+				_moduleDocs = mdocs,+				_moduleImports = imps,+				_moduleExports = syms,+				_moduleFixities = fromMaybe [] (mfixities >>= fromJSON'),+				_moduleScope = mempty,+				_moduleSource = Nothing }++loadModules :: (SessionMonad m, ToRow q) => String -> q -> m [Module]+loadModules selectExpr args = scope "load-modules" $ do+	ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int))+		(toQuery $ mconcat [+			qModuleId,+			select_ ["mu.docs", "mu.fixities", "mu.id"],+			where_ [fromString $ "mu.id in (" ++ selectExpr ++ ")"]])+		args+	forM ms $ \(mid' :. (mdocs, mfixities, mid)) -> do+		syms <- query @_ @Symbol+			(toQuery $ mconcat [+				qSymbol,+				from_ ["exports as e"],+				where_ ["e.module_id == ?", "e.symbol_id == s.id"]])+			(Only mid)+		imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid)+		return Module {+			_moduleId = mid',+			_moduleDocs = mdocs,+			_moduleImports = imps,+			_moduleExports = syms,+			_moduleFixities = fromMaybe [] (mfixities >>= fromJSON'),+			_moduleScope = mempty,+			_moduleSource = Nothing }++loadProject :: SessionMonad m => Path -> m Project+loadProject cabal = scope "load-project" $ do+	projs <- query @_ @(Only Int :. Project) "select id, name, cabal, version, build_tool, package_db_stack from projects where cabal == ?;" (Only $ view path cabal)+	(Only pid :. proj) <- case projs of+		[] -> sqlFailure $ "project with cabal {} not found" ~~ view path cabal+		_ -> do+			when (length projs > 1) $ sendLog Warning $ "multiple projects with same cabal = {} found" ~~ view path cabal+			return $ head projs++	libs <- query+		(toQuery $ mconcat [+			select_ ["lib.modules"],+			from_ ["libraries as lib"],+			qBuildInfo,+			where_ [+				"lib.build_info_id == bi.id",+				"lib.project_id == ?"]])+			(Only pid)++	exes <- query+		(toQuery $ mconcat [+			select_ ["exe.name", "exe.path"],+			from_ ["executables as exe"],+			qBuildInfo,+			where_ [+				"exe.build_info_id == bi.id",+				"exe.project_id == ?"]])+			(Only pid)++	tests <- query+		(toQuery $ mconcat [+			select_ ["tst.name", "tst.enabled", "tst.main"],+			from_ ["tests as tst"],+			qBuildInfo,+			where_ [+				"tst.build_info_id == bi.id",+				"tst.project_id == ?"]])+			(Only pid)++	return $+		set (projectDescription . _Just . projectLibrary) (listToMaybe libs) .+		set (projectDescription . _Just . projectExecutables) exes .+		set (projectDescription . _Just . projectTests) tests $+		proj++-- | Update a bunch of modules+updateModules :: SessionMonad m => [InspectedModule] -> m ()+updateModules ims = scope "update-modules" $ do+	ids <- upsertModules ims+	updateModulesSymbols $ zip ids ims++-- | Update symbols of bunch of modules+updateModulesSymbols :: SessionMonad m => [(Int, InspectedModule)] -> m ()+updateModulesSymbols ims = scope "update-modules" $ timer "updated modules" $ bracket_ initTemps dropTemps $ do+	initUpdatedIds ims++	removeModulesContents+	transaction_ Immediate $ insertModulesDefs ims+	transaction_ Immediate $ insertModulesExports ims+	where+		initTemps :: SessionMonad m => m ()+		initTemps = execute_ "create temporary table updated_ids (id integer not null, cabal text, module text not null, only_header int not null, dirty int not null);"++		dropTemps :: SessionMonad m => m ()+		dropTemps = execute_ "drop table if exists updated_ids;" ++		initUpdatedIds :: SessionMonad m => [(Int, InspectedModule)] -> m ()+		initUpdatedIds imods = transaction_ Immediate $ do+			execute_ "create unique index updated_ids_id_index on updated_ids (id);"+			execute_ "create index updated_ids_module_index on updated_ids (module);"+			executeMany "insert into updated_ids (id, cabal, module, only_header, dirty) values (?, ?, ?, ?, ?);" $ do+				(mid, im) <- imods+				return (+					mid,+					im ^? inspectedKey . moduleProject . _Just . projectCabal,+					im ^?! inspected . moduleId . moduleName,+					hasTag OnlyHeaderTag im,+					hasTag DirtyTag im)++		removeModulesContents :: SessionMonad m => m ()+		removeModulesContents = scope "remove-modules-contents" $ do+			transaction_ Immediate $ do+				execute_ "delete from symbols where module_id in (select id from updated_ids where not only_header or not dirty);"+				execute_ "update symbols set line = null, column = null where module_id in (select id from updated_ids where only_header and dirty);"+				execute_ "delete from imports where module_id in (select id from updated_ids);"+				execute_ "delete from exports where module_id in (select id from updated_ids);"++			transaction_ Immediate $ execute_ "delete from scopes where module_id in (select id from updated_ids);"+			transaction_ Immediate $ execute_ "delete from names where module_id in (select id from updated_ids);"+			transaction_ Immediate $ execute_ "delete from types where module_id in (select id from updated_ids);"++		insertModulesDefs :: SessionMonad m => [(Int, InspectedModule)] -> m ()+		insertModulesDefs imods = executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do+			(mid, im) <- imods+			m <- im ^.. inspected+			sym <- m ^. moduleExports+			guard (sym ^. symbolId . symbolModule == m ^. moduleId)+			return $ (+				sym ^. symbolId . symbolName,+				mid,+				sym ^. symbolDocs,+				sym ^? symbolPosition . _Just . positionLine,+				sym ^? symbolPosition . _Just . positionColumn)+				:. (sym ^. symbolInfo)++		insertModulesExports :: SessionMonad m => [(Int, InspectedModule)] -> m ()+		insertModulesExports imods = executeMany "insert into exports (module_id, symbol_id) select ?, s.id from modules as m, symbols as s where ((? = m.file) or (? = m.package_name and ? = m.package_version and ? = m.installed_name) or (? = m.other_location)) and s.module_id = m.id and ? = s.name and ? = s.what;" $ do+			(mid, im) <- imods+			m <- im ^.. inspected+			sym <- m ^. moduleExports+			return $+				(Only mid) :.+				mkLocationId (sym ^. symbolId . symbolModule) :.+				(sym ^. symbolId . symbolName, symbolType sym)++		mkLocationId m' = (+			m' ^? moduleLocation . moduleFile,+			m' ^? moduleLocation . modulePackage . packageName,+			m' ^? moduleLocation . modulePackage . packageVersion,+			m' ^? moduleLocation . installedModuleName,+			m' ^? moduleLocation . otherLocationName)+++escapeLike :: Text -> Text+escapeLike = T.replace "%" "\\%" . T.replace "_" "\\_" . T.replace "\\" "\\\\"++-- Util++sqlFailure :: SessionMonad m => Text -> m a+sqlFailure msg = do+	sendLog Error msg+	hsdevError $ SQLiteError $ T.unpack msg++lookupId :: SessionMonad m => ModuleLocation -> m Int+lookupId = lookupModuleLocation >=> maybe err return where+	err = hsdevError $ SQLiteError "module not exist in db"
src/HsDev/Database/SQLite/Instances.hs view
@@ -1,357 +1,371 @@-{-# 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.Display+import HsDev.Symbols.Name+import HsDev.Symbols.Location+import HsDev.Symbols.Types+import HsDev.Tools.Ghc.Types+import HsDev.Tools.Types+import HsDev.Util++instance ToField Value where+	toField = SQLBlob . L.toStrict . encode++instance FromField Value where+	fromField fld = case fieldData fld of+		SQLText s -> either fail return . eitherDecode . L.fromStrict . T.encodeUtf8 $ s+		SQLBlob s -> either fail return . eitherDecode . L.fromStrict $ s+		_ -> fail "invalid json field type"++newtype JSON a = JSON { getJSON :: a }+	deriving (Eq, Ord, Read, Show)++instance ToJSON a => ToField (JSON a) where+	toField = SQLBlob . L.toStrict . encode . getJSON++instance FromJSON a => FromField (JSON a) where+	fromField fld = case fieldData fld of+		SQLText s -> either fail (return . JSON) . eitherDecode . L.fromStrict . T.encodeUtf8 $ s+		SQLBlob s -> either fail (return . JSON) . eitherDecode . L.fromStrict $ s+		_ -> fail "invalid json field type"++instance FromRow Position where+	fromRow = Position <$> field <*> field++instance ToRow Position where+	toRow (Position l c) = [toField l, toField c]++instance FromRow Region where+	fromRow = Region <$> fromRow <*> fromRow++instance ToRow Region where+	toRow (Region f t) = toRow f ++ toRow t++instance FromRow ModulePackage where+	fromRow = ModulePackage <$> field <*> (fromMaybe T.empty <$> field)++instance ToRow ModulePackage where+	toRow (ModulePackage name ver) = [toField name, toField ver]++instance FromRow ModuleLocation where+	fromRow = do+		file <- field+		cabal <- field+		dirs <- field+		pname <- field+		pver <- field+		iname <- field+		iexposed <- field+		other <- field++		maybe (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 ToField BuildTool where+	toField CabalTool = toField @String "cabal"+	toField StackTool = toField @String "stack"++instance FromField BuildTool where+	fromField = fromField @String >=> fromStr where+		fromStr "cabal" = return CabalTool+		fromStr "stack" = return StackTool+		fromStr s = fail $ "Error parsing build tool: {}" ~~ s++instance ToRow Sandbox where+	toRow (Sandbox t p) = [toField t, toField p]++instance FromRow Sandbox where+	fromRow = Sandbox <$> field <*> field++instance ToRow Project where+	toRow (Project name _ cabal pdesc t dbs) = [toField name, toField cabal, toField $ pdesc ^? _Just . projectVersion, toField t, toField dbs]++instance FromRow Project where+	fromRow = do+		name <- field+		cabal <- field+		ver <- field+		tool <- field+		dbs <- field+		return $ Project name (takeDir cabal) cabal (fmap (\v -> ProjectDescription v Nothing [] []) ver) tool dbs++instance FromRow Library where+	fromRow = do+		mods <- field >>= maybe (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,159 @@-{-# LANGUAGE OverloadedStrings, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-
-module HsDev.Database.SQLite.Select (
-	Select(..), select_, from_, where_, buildQuery, toQuery,
-	qSymbolId, qSymbol, qModuleLocation, qModuleId, qImport, qBuildInfo,
-	qNSymbol, qNote
-	) where
-
-import Data.String
-import Data.Text (Text)
-import qualified Data.Text as T
-import 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 Data.Semigroup+import Database.SQLite.Simple+import Text.Format++data Select a = Select {+	selectColumns :: [a],+	selectTables :: [a],+	selectConditions :: [a] }+		deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)++instance Semigroup (Select a) where+	Select lc lt lcond <> Select rc rt rcond = Select+		(lc <> rc)+		(lt <> rt)+		(lcond <> rcond)++instance Monoid (Select a) where+	mempty = Select mempty mempty mempty+	mappend l r = l <> r++select_ :: [a] -> Select a+select_ cols = Select cols [] []++from_ :: [a] -> Select a+from_ tbls = Select [] tbls []++where_ :: [a] -> Select a+where_ = Select [] []++buildQuery :: Select Text -> String+buildQuery (Select cols tables conds) = "select {} from {} where {}"+	~~ T.intercalate ", " cols+	~~ T.intercalate ", " tables+	~~ T.intercalate " and " (map (\cond -> T.concat ["(", cond, ")"]) conds)++toQuery :: Select Text -> Query+toQuery = fromString . buildQuery++qSymbolId :: Select Text+qSymbolId = mconcat [+	select_ [+		"s.name",+		"m.name",+		"m.file",+		"m.cabal",+		"m.install_dirs",+		"m.package_name",+		"m.package_version",+		"m.installed_name",+		"m.exposed",+		"m.other_location"],+	from_ ["modules as m", "symbols as s"],+	where_ ["m.id == s.module_id"]]++qSymbol :: Select Text+qSymbol = mconcat [+	qSymbolId,+	select_ [+		"s.docs",+		"s.line",+		"s.column",+		"s.what",+		"s.type",+		"s.parent",+		"s.constructors",+		"s.args",+		"s.context",+		"s.associate",+		"s.pat_type",+		"s.pat_constructor"]]++qModuleLocation :: Text -> Select Text+qModuleLocation ml = template ["ml" ~% ml] [+	select_ [+		"{ml}.file",+		"{ml}.cabal",+		"{ml}.install_dirs",+		"{ml}.package_name",+		"{ml}.package_version",+		"{ml}.installed_name",+		"{ml}.exposed",+		"{ml}.other_location"],+	from_ ["modules as {ml}"]]++qModuleId :: Select Text+qModuleId = mconcat [+	select_ [+		"mu.name",+		"mu.file",+		"mu.cabal",+		"mu.install_dirs",+		"mu.package_name",+		"mu.package_version",+		"mu.installed_name",+		"mu.exposed",+		"mu.other_location"],+	from_ ["modules as mu"],+	where_ ["mu.name is not null"]]++qImport :: Text -> Select Text+qImport i = template ["i" ~% i] [+	select_ [+		"{i}.line", "{i}.column",+		"{i}.module_name",+		"{i}.qualified",+		"{i}.alias"],+	from_ ["imports as {i}"]]++qBuildInfo :: Select Text+qBuildInfo = mconcat [+	select_ [+		"bi.depends",+		"bi.language",+		"bi.extensions",+		"bi.ghc_options",+		"bi.source_dirs",+		"bi.other_modules"],+	from_ ["build_infos as bi"]]++-- | Symbol from haskell-names+qNSymbol :: Text -> Text -> Select Text+qNSymbol m s = template ["m" ~% m, "s" ~% s] [+	select_ [+		"{s}.what",+		"{m}.name",+		"{s}.name",+		"{s}.parent",+		"{s}.constructors",+		"{s}.associate",+		"{s}.pat_type",+		"{s}.pat_constructor"],+	from_ ["symbols as {s}", "modules as {m}"],+	where_ ["{m}.id = {s}.module_id"]]++qNote :: Text -> Text -> Select Text+qNote m n = template ["m" ~% m, "n" ~% n] [+	select_ [+		"{m}.file",+		"{n}.line", "{n}.column", "{n}.line_to", "{n}.column_to",+		"{n}.severity",+		"{n}.message", "{n}.suggestion"],+	from_ ["modules as {m}", "messages as {n}"],+	where_ [+		"{m}.file is not null",+		"{n}.module_id = {m}.id"]]++template :: [FormatArg] -> [Select Text] -> Select Text+template args = fmap ((`formats` args) . T.unpack) . mconcat
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,688 @@-{-# 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
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses, RankNTypes, TypeOperators, TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsDev.Database.Update (+	Status(..), Progress(..), Task(..),+	UpdateOptions(..),++	UpdateM(..),+	runUpdate,++	postStatus, updater, runTask, runTasks, runTasks_,++	scanModules, scanFile, scanFiles, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanPackageDbStack, scanProjectFile, scanProjectStack, scanProject, scanDirectory,+	scanPackageDbStackDocs, scanDocs,+	setModTypes, inferModTypes,+	scan,+	processEvents, updateEvents, applyUpdates,++	cacheGhcWarnings, cachedWarnings,++	module HsDev.Database.Update.Types,++	module HsDev.Watcher,++	module Control.Monad.Except+	) where++import qualified Control.Concurrent.Async as A+import Control.Concurrent.MVar+import Control.DeepSeq+import Control.Exception (ErrorCall, evaluate, displayException)+import Control.Lens+import Control.Monad.Catch (catch, handle, MonadThrow, bracket_)+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State (get, modify, runStateT)+import Data.Aeson+import Data.List (intercalate)+import Data.String (fromString)+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.Maybe+import Data.Text (Text)+import Data.Time.Clock.POSIX+import qualified Data.Text as T+import System.FilePath+import qualified System.Log.Simple as Log++import Data.Maybe.JustIf+import HsDev.Error+import qualified HsDev.Database.SQLite as SQLite+import HsDev.Display+import HsDev.Inspect+import HsDev.Inspect.Order+import HsDev.PackageDb+import HsDev.Project+import HsDev.Sandbox+import qualified HsDev.Stack as S+import HsDev.Symbols+import HsDev.Tools.Ghc.Session hiding (Session, evaluate)+import HsDev.Tools.Ghc.Types (fileTypes, TypedExpr)+import HsDev.Tools.Types+import HsDev.Tools.HDocs+import qualified HsDev.Scan as S+import HsDev.Scan.Browse+import HsDev.Util (ordNub, fromJSON', uniqueBy, timer)+import qualified HsDev.Util as Util (withCurrentDirectory)+import HsDev.Server.Types (commandNotify, inSessionGhc, FileSource(..))+import HsDev.Server.Message+import HsDev.Database.Update.Types+import HsDev.Watcher+import Text.Format+import System.Directory.Paths++onStatus :: UpdateMonad m => m ()+onStatus = asks (view (updateOptions . updateTasks)) >>= commandNotify . Notification . toJSON . reverse++childTask :: UpdateMonad m => Task -> m a -> m a+childTask t = local (over (updateOptions . updateTasks) (t:))++transact :: SessionMonad m => m a -> m a+transact = SQLite.transaction_ SQLite.Immediate++runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a+runUpdate uopts act = Log.scope "update" $ do+	(r, updatedMods) <- withUpdateState uopts $ \ust ->+		runWriterT (runUpdateM act' `runReaderT` ust)+	Log.sendLog Log.Debug $ "updated {} modules" ~~ length updatedMods+	return r+	where+		act' = do+			(r, _) <- listen act+			-- (r, mlocs') <- listen act++			-- dbs <- liftM S.unions $ forM mlocs' $ \mloc' -> do+			-- 	mid <- SQLite.lookupModuleLocation mloc'+			-- 	case mid of+			-- 		Nothing -> return (S.empty :: S.Set PackageDb)+			-- 		Just mid' -> liftM (S.fromList . map SQLite.fromOnly) $ SQLite.query (SQLite.toQuery $ SQLite.select_+			-- 			["ps.package_db"]+			-- 			["package_dbs as ps", "modules as m"]+			-- 			["m.package_name == ps.package_name", "m.package_version == ps.package_version", "m.id == ?"]) (SQLite.Only mid')++			-- If some sourced files depends on currently scanned package-dbs+			-- We must resolve them and even rescan if there was errors scanning without+			-- dependencies provided (lack of fixities can cause errors inspecting files)++			-- sboxes = databaseSandboxes dbval+			-- sboxOf :: Path -> Maybe Sandbox+			-- sboxOf fpath = find (pathInSandbox fpath) sboxes+			-- projsRows <- SQLite.query_ "select name, cabal, version, ifnull(package_db_stack, json('[]')) from projects;"+			-- let+			-- 	projs = [proj' | (proj' SQLite.:. (SQLite.Only (SQLite.JSON projPdbs))) <- projsRows,+			-- 		not (S.null (S.fromList projPdbs `S.intersection` dbs))]++			-- 	stands = []+			-- 	-- HOWTO?+			-- 	-- stands = do+			-- 	-- 	sloc <- dbval ^.. standaloneSlice . modules . moduleId . moduleLocation+			-- 	-- 	guard $ sboxUpdated $ sboxOf (sloc ^?! moduleFile)+			-- 	-- 	guard (notElem sloc mlocs')+			-- 	-- 	return (sloc, dbval ^.. databaseModules . ix sloc . inspection . inspectionOpts . each . unpacked, Nothing)++			-- Log.sendLog Log.Trace $ "updated package-dbs: {}, have to rescan {} projects and {} files"+			-- 	~~ intercalate ", " (map display $ S.toList dbs)+			-- 	~~ length projs ~~ length stands+			-- (_, rlocs') <- listen $ runTasks_ (scanModules [] stands : [scanProject [] (proj ^. projectCabal) | proj <- projs])+			-- let+			-- 	ulocs' = filter (isJust . preview moduleFile) (ordNub $ mlocs' ++ rlocs')+			-- 	getMods :: (MonadIO m) => m [InspectedModule]+			-- 	getMods = do+			-- 		db' <- liftIO $ readAsync db+			-- 		return $ filter ((`elem` ulocs') . view inspectedKey) $ toList $ view databaseModules db'++			-- FIXME: Now it's broken since `Database` is not used anymore+			when (view updateDocs uopts) $ do+				Log.sendLog Log.Trace "forking inspecting source docs"+				Log.sendLog Log.Warning "not implemented"+				-- void $ fork (getMods >>= waiter . mapM_ scanDocs_)+			when (view updateInfer uopts) $ do+				Log.sendLog Log.Trace "forking inferring types"+				Log.sendLog Log.Warning "not implemented"+				-- void $ fork (getMods >>= waiter . mapM_ inferModTypes_)+			return r+		-- scanDocs_ :: UpdateMonad m => InspectedModule -> m ()+		-- scanDocs_ im = do+		-- 	im' <- (S.scanModify (\opts -> inSessionGhc . liftGhc . inspectDocsGhc opts) im) <|> return im+		-- 	sendUpdateAction $ Log.scope "scan-docs" $ SQLite.updateModule im'+		-- inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()+		-- inferModTypes_ im = do+		-- 	-- TODO: locate sandbox+		-- 	im' <- (S.scanModify infer' im) <|> return im+		-- 	sendUpdateAction $ Log.scope "infer-types" $ SQLite.updateModule im'+		-- infer' :: UpdateMonad m => [String] -> Module -> m Module+		-- infer' opts m = case preview (moduleId . moduleLocation . moduleFile) m of+		-- 	Nothing -> return m+		-- 	Just _ -> inSessionGhc $ do+		-- 		targetSession opts m+		-- 		inferTypes opts m Nothing++-- | Post status+postStatus :: UpdateMonad m => Task -> m ()+postStatus t = childTask t onStatus++-- | Mark module as updated+updater :: UpdateMonad m => [ModuleLocation] -> m ()+updater mlocs = tell $!! mlocs++-- | Run one task+runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a+runTask action subj act = Log.scope "task" $ do+	postStatus $ set taskStatus StatusWorking task+	x <- childTask task act+	x `deepseq` postStatus (set taskStatus StatusOk task)+	return x+	`catch`+	(\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e)+	where+		task = Task {+			_taskName = action,+			_taskStatus = StatusWorking,+			_taskSubjectType = displayType subj,+			_taskSubjectName = display subj,+			_taskProgress = Nothing }++-- | Run many tasks with numeration+runTasks :: UpdateMonad m => [m a] -> m [a]+runTasks ts = liftM catMaybes $ zipWithM taskNum [1..] (map noErr ts) where+	total = length ts+	taskNum n = local setProgress where+		setProgress = set (updateOptions . updateTasks . _head . taskProgress) (Just (Progress n total))+	noErr v = hsdevIgnore Nothing (Just <$> v)++-- | Run many tasks with numeration+runTasks_ :: UpdateMonad m => [m ()] -> m ()+runTasks_ = void . runTasks++data PreloadFailure = PreloadFailure ModuleLocation Inspection HsDevError++instance NFData PreloadFailure where+	rnf (PreloadFailure mloc insp err) = rnf mloc `seq` rnf insp `seq` rnf err++-- | Scan modules+scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()+scanModules opts ms = Log.scope "scan-modules" $ mapM_ (uncurry scanModules') grouped where+	scanModules' mproj ms' = do+		maybe (return ()) (sendUpdateAction . SQLite.updateProject) mproj+		updater $ ms' ^.. each . _1+		defines <- askSession sessionDefines++		let+			pload (mloc, mopts, mcts) = runTask "preloading" mloc $ do+				mfcts <- maybe (S.getFileContents (mloc ^?! moduleFile)) (const $ return Nothing) mcts+				insp <- liftIO $ fileInspection (mloc ^?! moduleFile) (opts ++ mopts)+				case (mfcts ^? _Just . _1) of+					Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm+					Nothing -> return ()+				let+					inspection' = maybe insp (fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1+					dirtyTag' = maybe id (const $ inspectTag DirtyTag) $ mfcts ^? _Just . _1+					mcts' = mplus mcts (mfcts ^? _Just . _2)+				runInspect mloc $ withInspection (return inspection') $ dirtyTag' $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mcts'++		ploaded <- runTasks (map pload ms')+		sendUpdateAction $ void $ SQLite.upsertModules $ map (fmap (view asModule)) ploaded+		let+			mlocs' = ploaded ^.. each . inspected . preloadedId . moduleLocation++		updater mlocs'++		let+			mcabal = mproj ^? _Just . projectCabal++		(env, fixities) <- loadEnv mcabal++		Log.sendLog Log.Trace $ "resolved environment: {} modules" ~~ M.size env+		case orderBy (preview inspected) ploaded of+			Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err)+			Right ordered -> do+				(ms'', (updEnv, updFixities)) <- flip runStateT (env, fixities) $ runTasks (map inspect' ordered)+				saveEnv mcabal updEnv updFixities+				mlocs'' <- timer "updated scanned modules" $ do+					Log.sendLog Log.Trace $ case mproj of+						Just proj -> "inserting data for resolved modules of project: {}" ~~ proj+						Nothing -> "inserting data for resolved standalone modules"+					sendUpdateAction $ Log.scope "resolved" $ updateResolveds mcabal ms''+					return (ms'' ^.. each . inspectedKey)+				updater mlocs''+				where+					inspect' pmod = runTask "scanning" ploc $ Log.scope "module" $ do+						(env', fixities') <- get+						r <- continueInspect pmod $ \p -> do+							resolved' <- msum [+								resolveModule env' fixities' p,+								do+									lift (Log.sendLog Log.Trace ("error resolving module {}, falling to resolving just imports/scope" ~~ (p ^. preloadedId . moduleLocation)))+									resolvePreloaded env' p]+							eval resolved'+						modify $ mappend (+							maybe mempty resolvedEnv (r ^? inspected),+							maybe mempty resolvedFixitiesTable (r ^? inspected))+						return r+						where+							ploc = pmod ^?! inspected . preloadedId . moduleLocation++	grouped = M.toList $ M.unionsWith (++) [M.singleton (m ^? _1 . moduleProject . _Just) [m] | m <- ms]+	eval v = handle onError (v `deepseq` liftIO (evaluate v)) where+		onError :: MonadThrow m => ErrorCall -> m a+		onError = hsdevError . OtherError . displayException++-- | Scan source file, possibly scanning also related project and installed modules+scanFile :: UpdateMonad m => [String] -> Path -> BuildTool -> Bool -> Bool -> m ()+scanFile opts fpath tool scanProj scanDb = do+	mproj <- fmap (set (_Just . projectBuildTool) tool) $ locateProjectInfo fpath+	sbox <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj+	when scanDb $ do+		[SQLite.Only scanned] <- SQLite.query @_ @(SQLite.Only Bool) "select count(*) > 0 from package_dbs as pdbs where pdbs.package_db = ?;" (SQLite.Only (topPackageDb sbox))+		unless scanned $ scanPackageDbStack opts sbox+	case join (mproj `justIf` scanProj) of+		Nothing -> scanFiles [(FileSource fpath Nothing, opts)]+		Just proj -> scanProject opts tool (view projectCabal proj)++-- | Scan source files, resolving dependent modules+scanFiles :: UpdateMonad m => [(FileSource, [String])] -> m ()+scanFiles fsrcs = runTask "scanning" ("files" :: String) $ Log.scope "files" $ hsdevLiftIO $ do+	Log.sendLog Log.Trace $ "scanning {} files" ~~ length fsrcs+	fpaths' <- traverse (liftIO . canonicalize) $ map (fileSource . fst) fsrcs+	forM_ fpaths' $ \fpath' -> do+		ex <- liftIO $ fileExists fpath'+		unless ex $ hsdevError $ FileNotFound fpath'+	mlocs <- forM fpaths' $ \fpath' -> do+		mids <- SQLite.query (SQLite.toQuery $ SQLite.qModuleId `mappend` SQLite.where_ ["mu.file == ?"]) (SQLite.Only fpath')+		if length mids > 1+			then return (head mids ^. moduleLocation)+			else do+				mproj <- locateProjectInfo fpath'+				return $ FileModule fpath' mproj+	let+		filesMods = liftM concat $ forM fpaths' $ \fpath' -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file == ?;" (SQLite.Only fpath')+	scan filesMods [(mloc, opts, mcts) | (mloc, (FileSource _ mcts, opts)) <- zip mlocs fsrcs] [] $ \mlocs' -> do+		mapM_ ((watch . flip watchModule) . view _1) mlocs'+		S.ScanContents dmods _ _ <- fmap mconcat $ mapM (S.enumDependent . view (_1 . moduleFile . path)) mlocs'+		Log.sendLog Log.Trace $ "dependent modules: {}" ~~ length dmods+		scanModules [] (mlocs' ++ dmods)++-- | Scan source file with contents and resolve dependent modules+scanFileContents :: UpdateMonad m => [String] -> Path -> Maybe Text -> m ()+scanFileContents opts fpath mcts = scanFiles [(FileSource fpath mcts, opts)]++-- | Scan cabal modules, doesn't rescan if already scanned+scanCabal :: UpdateMonad m => [String] -> m ()+scanCabal opts = Log.scope "cabal" $ scanPackageDbStack opts userDb++-- | Prepare sandbox for scanning. This is used for stack project to build & configure.+prepareSandbox :: UpdateMonad m => Sandbox -> m ()+prepareSandbox sbox@(Sandbox StackTool fpath) = Log.scope "prepare" $ runTasks_ [+	runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.buildDeps Nothing]+	where+		dir = takeDirectory $ view path fpath+prepareSandbox _ = return ()++-- | Scan sandbox modules, doesn't rescan if already scanned+scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()+scanSandbox opts sbox = Log.scope "sandbox" $ do+	-- prepareSandbox sbox+	pdbs <- inSessionGhc $ sandboxPackageDbStack sbox+	scanPackageDbStack opts pdbs++-- | Scan top of package-db stack, usable for rescan+scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m ()+scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do+	pdbState <- liftIO $ readPackageDb (topPackageDb pdbs)+	let+		packageDbMods = S.fromList $ concat $ M.elems pdbState+		packages' = M.keys pdbState+	Log.sendLog Log.Trace $ "package-db state: {} modules" ~~ length packageDbMods+	watch (\w -> watchPackageDb w pdbs opts)++	pkgs <- SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only $ topPackageDb pdbs)+	if S.fromList packages' == S.fromList pkgs+		then Log.sendLog Log.Trace "nothing changes, all packages the same"+		else do+			mlocs <- liftM+				(filter (`S.member` packageDbMods)) $+				(inSessionGhc $ listModules opts pdbs packages')+			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] -> BuildTool -> Path -> m Project+scanProjectFile opts tool cabal = runTask "scanning" cabal $ do+	proj <- fmap (set projectBuildTool tool) $ S.scanProjectFile opts cabal+	pdbs <- inSessionGhc $ getProjectPackageDbStack proj+	let+		proj' = set projectPackageDbStack (Just pdbs) proj+	sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj'+	return proj'++-- | Refine project info and update if necessary+refineProjectInfo :: UpdateMonad m => Project -> m Project+refineProjectInfo proj = do+	[SQLite.Only exist] <- SQLite.query "select count(*) > 0 from projects where cabal == ?;" (SQLite.Only (proj ^. projectCabal))+	if exist+		then SQLite.loadProject (proj ^. projectCabal)+		else runTask "scanning" (proj ^. projectCabal) $ do+			proj' <- liftIO $ loadProject proj+			pdbs <- inSessionGhc $ getProjectPackageDbStack proj'+			let+				proj'' = set projectPackageDbStack (Just pdbs) proj'+			sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj''+			return proj''++-- | Get project info for module+locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project)+locateProjectInfo cabal = liftIO (locateProject (view path cabal)) >>= traverse refineProjectInfo++-- | Scan project and related package-db stack+scanProjectStack :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()+scanProjectStack opts tool cabal = do+	sbox <- liftIO $ projectSandbox tool cabal+	maybe (scanCabal opts) (scanSandbox opts) sbox+	scanProject opts tool cabal++-- | Scan project+scanProject :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()+scanProject opts tool cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do+	proj <- scanProjectFile opts tool cabal+	watch (\w -> watchProject w proj opts)+	S.ScanContents _ [(_, sources)] _ <- S.enumProject proj+	let+		projMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file is not null and m.cabal == ?;" (SQLite.Only $ proj ^. projectCabal)+	scan projMods sources opts $ scanModules opts++		-- Scan docs+		-- inSessionGhc $ do+		-- 	currentSession >>= maybe (return ()) (const clearTargets)++		-- 	forM_ (maybe [] targetInfos (proj ^. projectDescription)) $ \tinfo' -> do+		-- 		opts' <- getProjectTargetOpts [] proj (tinfo' ^. targetBuildInfo)+		-- 		files' <- projectTargetFiles proj tinfo'+		-- 		haddockSession opts'+		-- 		docsMap <- liftGhc $ readProjectTargetDocs opts' proj files'+		-- 		Log.sendLog Log.Debug $ "scanned logs for modules: {}, summary docs: {}" ~~ (intercalate "," (M.keys docsMap)) ~~ (sum $ map M.size $ M.elems docsMap)+++-- | Scan directory for source files and projects+scanDirectory :: UpdateMonad m => [String] -> Path -> m ()+scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do+	S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory (view path dir)+	runTasks_ [scanProject opts CabalTool (view projectCabal p) | (p, _) <- projSrcs]+	runTasks_ $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan+	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs+	let+		standaloneMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.cabal is null and m.file is not null and m.file like ? escape '\\';" (SQLite.Only $ SQLite.escapeLike dir `T.append` "%")+	scan standaloneMods standSrcs opts $ scanModules opts++-- | Scan installed docs+scanPackageDbStackDocs :: UpdateMonad m => [String] -> PackageDbStack -> m ()+scanPackageDbStackDocs opts pdbs+	| hdocsSupported = Log.scope "docs" $ do+		docs <- inSessionGhc $ hdocsCabal pdbs opts+		Log.sendLog Log.Trace $ "docs scanned: {} packages, {} modules total"+			~~ length docs ~~ sum (map (M.size . snd) docs)+		sendUpdateAction $ transact $ SQLite.executeMany "update symbols set docs = ? where name == ? and module_id in (select id from modules where name == ? and package_name == ? and package_version == ?);" $ do+			(ModulePackage pname pver, pdocs) <- docs+			(mname, mdocs) <- M.toList pdocs+			(nm, doc) <- M.toList mdocs+			return (doc, nm, mname, pname, pver)+		Log.sendLog Log.Trace "docs set"+	| otherwise = Log.sendLog Log.Warning "hdocs not supported"++-- | Scan docs for inspected modules+scanDocs :: UpdateMonad m => [Module] -> m ()+scanDocs+	| hdocsSupported = runTasks_ . map scanDocs'+	| otherwise = const $ Log.sendLog Log.Warning "hdocs not supported"+	where+		scanDocs' m = runTask "scanning docs" (view (moduleId . moduleLocation) m) $ Log.scope "docs" $ do+			mid <- SQLite.lookupModule (m ^. moduleId)+			mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid+			m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m+			Log.sendLog Log.Trace $ "Scanning docs for {}" ~~ view (moduleId . moduleLocation) m'+			docsMap <- inSessionGhc $ do+				(pdbs, opts') <- getModuleOpts [] m'+				currentSession >>= maybe (return ()) (const clearTargets)+				-- Calling haddock with targets set sometimes cause errors+				haddockSession pdbs opts'+				readModuleDocs opts' m'+			sendUpdateAction $ transact $ do+				SQLite.executeMany "update symbols set docs = ? where name == ? and module_id == ?;"+					[(doc, nm, mid') | (nm, doc) <- maybe [] M.toList docsMap]+				SQLite.execute "update modules set tags = json_set(tags, '$.docs', 1) where id == ?;" (SQLite.Only mid')++-- | Set inferred types for module+setModTypes :: UpdateMonad m => ModuleId -> [Note TypedExpr] -> m ()+setModTypes m ts = Log.scope "set-types" $ do+	mid <- SQLite.lookupModule m+	mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid+	sendUpdateAction $ transact $ do+		SQLite.execute "delete from types where module_id = ?;" (SQLite.Only mid')+		SQLite.executeMany "insert into types (module_id, line, column, line_to, column_to, expr, type) values (?, ?, ?, ?, ?, ?, ?);" [+			(SQLite.Only mid' SQLite.:. view noteRegion n' SQLite.:. view note n') | n' <- uniqueBy (view noteRegion) ts]+		SQLite.execute "update names set inferred_type = (select type from types as t where t.module_id = ? and names.line = t.line and names.column = t.column and names.line_to = t.line_to and names.column_to = t.column_to) where module_id == ?;"+			(mid', mid')+		SQLite.execute "update symbols set type = (select type from types as t where t.module_id = ? and symbols.line = t.line and symbols.column = t.column order by t.line_to, t.column_to) where module_id == ? and type is null;" (mid', mid')+		SQLite.execute "update modules set tags = json_set(tags, '$.types', 1) where id == ?;" (SQLite.Only mid')++-- | Infer types for modules+inferModTypes :: UpdateMonad m => [Module] -> m ()+inferModTypes = runTasks_ . map inferModTypes' where+	inferModTypes' m = runTask "inferring types" (view (moduleId . moduleLocation) m) $ Log.scope "types" $ do+		mid <- SQLite.lookupModule (m ^. moduleId)+		_ <- maybe (hsdevError $ SQLiteError "module id not found") return mid+		m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m+		Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view (moduleId . moduleLocation) m'++		sess <- getSession+		mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile)+		types' <- inSessionGhc $ do+			targetSession [] m'+			cacheGhcWarnings sess (m' ^.. moduleId . moduleLocation) $+				fileTypes m' mcts++		setModTypes (m' ^. moduleId) types'++-- | Generic scan function. Removed obsolete modules and calls callback on changed modules.+scan :: UpdateMonad m+	=> m [SQLite.Only Int SQLite.:. ModuleLocation SQLite.:. Inspection]+	-- ^ Get affected modules, obsolete will be removed, changed will be updated+	-> [S.ModuleToScan]+	-- ^ Actual modules, other will be removed+	-> [String]+	-- ^ Extra scan options+	-> ([S.ModuleToScan] -> m ())+	-- ^ Update function+	-> m ()+scan part' mlocs opts act = Log.scope "scan" $ do+	mlocs' <- liftM (M.fromList . map (\(SQLite.Only mid SQLite.:. (m SQLite.:. i)) -> (m, (mid, i)))) part'+	let+		obsolete = M.filterWithKey (\k _ -> k `S.notMember` S.fromList (map (^. _1) mlocs)) mlocs'+	changed <- S.changedModules (M.map snd mlocs') opts mlocs+	sendUpdateAction $ Log.scope "remove-obsolete" $ transact $+		forM_ (M.elems obsolete) $ SQLite.removeModule . fst+	act changed++processEvents :: ([(Watched, Event)] -> IO ()) -> MVar (A.Async ()) -> MVar [(Watched, Event)] -> [(Watched, Event)] -> ClientM IO ()+processEvents handleEvents updaterTask eventsVar evs = Log.scope "event" $ do+	Log.sendLog Log.Trace $ "events received: {}" ~~ intercalate ", " (evs ^.. each . _2 . eventPath)+	l <- Log.askLog+	liftIO $ do+		modifyMVar_ eventsVar (return . (++evs))+		modifyMVar_ updaterTask $ \task -> do+			done <- fmap isJust $ poll task+			if done+				then do+					Log.withLog l $ Log.sendLog Log.Trace "starting update thread"+					A.async $ fix $ \loop -> do+						updates <- modifyMVar eventsVar (\es -> return ([], es))+						unless (null updates) $ handleEvents updates >> loop+				else return task++updateEvents :: ServerMonadBase m => [(Watched, Event)] -> UpdateM m ()+updateEvents updates = Log.scope "updater" $ do+	Log.sendLog Log.Trace $ "prepared to process {} events" ~~ length updates+	files <- fmap concat $ forM updates $ \(w, e) -> case w of+		WatchedProject proj projOpts+			| isSource e -> do+				Log.sendLog Log.Info $ "File '{file}' in project {proj} changed"+					~~ ("file" ~% view eventPath e)+					~~ ("proj" ~% view projectName proj)+				[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)+				opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts+				return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]+			| isCabal e -> do+				Log.sendLog Log.Info $ "Project {proj} changed"+					~~ ("proj" ~% view projectName proj)+				scanProject projOpts (view projectBuildTool proj) (view projectCabal proj)+				return []+			| otherwise -> return []+		WatchedPackageDb pdbs opts+			| isConf e -> do+				Log.sendLog Log.Info $ "Package db {package} changed"+					~~ ("package" ~% topPackageDb pdbs)+				scanPackageDb opts pdbs+				return []+			| otherwise -> return []+		WatchedModule+			| isSource e -> do+				Log.sendLog Log.Info $ "Module {file} changed"+					~~ ("file" ~% view eventPath e)+				[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)+				opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts+				return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]+			| otherwise -> return []+	scanFiles files+	where+		parseErr' mopts' = do+			Log.sendLog Log.Error $ "Error parsing inspection_opts: {}" ~~ show mopts'+			hsdevError $ SQLiteError $ "Error parsing inspection_opts: {}" ~~ show mopts'++applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO ()+applyUpdates uopts = runUpdate uopts . updateEvents++-- Save ghc warnings on loading target, because second loading won't produce any+cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a+cacheGhcWarnings sess mlocs act = Log.scope "cache-warnings" $ do+	tm <- liftIO getPOSIXTime+	(r, msgs) <- collectMessages act+	Log.sendLog Log.Trace $ "collected {} warnings" ~~ length msgs+	_ <- liftIO $ withSession sess $ postSessionUpdater $ refreshCache mlocs tm msgs+	return r+	where+		refreshCache :: [ModuleLocation] -> POSIXTime -> [Note OutputMessage] -> ServerM IO ()+		refreshCache mlocs' tm' msgs' = Log.scope "refresh" $ bracket_ initTemp dropTemp $ do+			fillTemp+			removeOutdated+			insertMessages+			where+				initTemp :: SessionMonad m => m ()+				initTemp = do+					SQLite.execute_ "create temporary table updating_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 = whenJustM (askSession sessionWatcher) $ liftIO . f
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 onErr where+	onErr :: MonadThrow m => IOException -> m a+	onErr = 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,320 @@-{-# 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.Semigroup+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 Semigroup AnalyzeEnv where+	AnalyzeEnv lenv lf lt <> AnalyzeEnv renv rf rt = AnalyzeEnv+		(lenv <> renv)+		(lf <> rf)+		(lt <> rt)++instance Monoid AnalyzeEnv where+	mempty = AnalyzeEnv mempty mempty mempty+	mappend l r = l <> r++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 mproj -> searchPackageDbStack (maybe CabalTool (view projectBuildTool) mproj) 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 onErr (return $!! analyzePreloaded mempty p)) >>= either (hsdevError . InspectError) return+		return $ set (moduleId . moduleLocation) (FileModule absFilename mproj) forced+	where+		onErr :: E.ErrorCall -> IO (Either String Module)+		onErr = 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,383 +1,383 @@-{-# 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)
+{-# 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,69 +1,70 @@-{-# 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
+{-# 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 -> mapM (mapM canonicalize) $+							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,198 @@-{-# 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.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+	Right 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 }+	Left e -> Left $ "Parse failed: " ++ 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 = do+		p' <- readProject (_projectCabal p ^. path)+		return $ set projectBuildTool (view projectBuildTool p) p'++-- | 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,79 @@-{-# 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.Version (Version)+import Distribution.Text (display)++#if MIN_VERSION_Cabal(2,2,0)+import Distribution.PackageDescription.Parsec+import Distribution.Parsec.Common (showPError)+import qualified Data.ByteString.Char8 as C8 (pack)+#else+import Distribution.PackageDescription.Parse+#endif++#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 -> Either String PD.GenericPackageDescription+#if MIN_VERSION_Cabal(2,2,0)+parsePackageDesc s = case snd . runParseResult . parseGenericPackageDescription . C8.pack $ s of+	Left (_, errs) -> Left $ unlines $ map (showPError "cabal") errs+	Right r -> Right r+#elif MIN_VERSION_Cabal(2,0,0)+parsePackageDesc s = case parseGenericPackageDescription s of+	ParseOk _ r -> Right r+	ParseFailed e -> Left $ show e+#else+parsePackageDesc s = case parsePackageDescription s of+	ParseOk _ r -> Right r+	ParseFailed e -> Left $ show e+#endif
src/HsDev/Project/Types.hs view
@@ -1,366 +1,429 @@-{-# 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
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeApplications, LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsDev.Project.Types (+	BuildTool(..), Sandbox(..), sandboxType, sandbox,+	Project(..), projectName, projectPath, projectCabal, projectDescription, projectBuildTool, 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 hiding ((<>))+import Data.Ord+import Data.Semigroup (Semigroup(..))+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++-- | Project build tool+data BuildTool = CabalTool | StackTool deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance NFData BuildTool where+	rnf CabalTool = ()+	rnf StackTool = ()++instance Display BuildTool where+	display CabalTool = "cabal"+	display StackTool = "stack"+	displayType _ = "build-tool"++instance Formattable BuildTool where+	formattable = formattable . display++instance ToJSON BuildTool where+	toJSON CabalTool = toJSON @String "cabal"+	toJSON StackTool = toJSON @String "stack"++instance FromJSON BuildTool where+	parseJSON = withText "build-tool" $ \case+		"cabal" -> return CabalTool+		"stack" -> return StackTool+		other -> fail $ "Can't parse BuildTool, unknown tool: {}" ~~ other++data Sandbox = Sandbox { _sandboxType :: BuildTool, _sandbox :: Path } deriving (Eq, Ord)++makeLenses ''Sandbox++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 CabalTool _) = "cabal-sandbox"+	displayType (Sandbox StackTool _) = "stack-work"++instance Formattable Sandbox where+	formattable = formattable . display++instance ToJSON Sandbox where+	toJSON (Sandbox t p) = object ["type" .= t, "path" .= p]++instance FromJSON Sandbox where+	parseJSON = withObject "sandbox" $ \v -> Sandbox <$>+		v .:: "type" <*>+		v .:: "path"++instance Paths Sandbox where+	paths f (Sandbox st p) = Sandbox st <$> paths f p++-- | Cabal project+data Project = Project {+	_projectName :: Text,+	_projectPath :: Path,+	_projectCabal :: Path,+	_projectDescription :: Maybe ProjectDescription,+	_projectBuildTool :: BuildTool,+	_projectPackageDbStack :: Maybe PackageDbStack }++instance NFData Project where+	rnf (Project n p c _ t dbs) = rnf n `seq` rnf p `seq` rnf c `seq` rnf t `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,+		"build-tool" .= _projectBuildTool p,+		"package-db-stack" .= _projectPackageDbStack p]++instance FromJSON Project where+	parseJSON = withObject "project" $ \v -> Project <$>+		v .:: "name" <*>+		v .:: "path" <*>+		v .:: "cabal" <*>+		v .:: "description" <*>+		v .:: "build-tool" <*>+		v .::? "package-db-stack"++instance Paths Project where+	paths f (Project nm p c desc t dbs) = Project nm <$> paths f p <*> paths f c <*> traverse (paths f) desc <*> pure t <*> 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,+	_projectBuildTool = CabalTool,+	_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 Semigroup Info where+	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 Monoid Info where+	mempty = Info [] Nothing [] [] [] []+	mappend l r = l <> 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,171 @@-{-# 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 #-}++module HsDev.Sandbox (+	Sandbox(..), sandboxType, sandbox,+	isSandbox, guessSandboxType, sandboxFromPath,+	findSandbox, searchSandbox, searchSandboxes,+	projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack,++	-- * package-db+	userPackageDb,++	-- * cabal-sandbox util+	cabalSandboxPackageDb,++	getModuleOpts, getProjectTargetOpts,++	getProjectSandbox,+	getProjectPackageDbStack+	) where++import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.Except+import Control.Lens (view)+import Data.List (find, intercalate)+import Data.Maybe (isJust, fromMaybe, catMaybes)+import Data.Maybe.JustIf+import System.Directory (getAppUserDataDirectory, doesDirectoryExist)+import System.FilePath+import System.Log.Simple (MonadLog(..))+import Text.Format++import System.Directory.Paths+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)++isSandbox :: Path -> Bool+isSandbox = isJust . guessSandboxType++guessSandboxType :: Path -> Maybe BuildTool+guessSandboxType fpath+	| takeFileName (view path fpath) == ".cabal-sandbox" = Just CabalTool+	| takeFileName (view path fpath) == ".stack-work" = Just StackTool+	| 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)++-- | Search sandboxes up from current directory+searchSandboxes :: Path -> IO [Sandbox]+searchSandboxes p = do+	mcabal <- searchFor CabalTool ".cabal-sandbox" ".cabal-sandbox"+	mstack <- searchFor StackTool "stack.yaml" ".stack-work"+	return $ catMaybes [mcabal, mstack]+	where+		searchFor :: BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox)+		searchFor tool lookFor sandboxDir = runMaybeT $ do+			root <- searchPath (view path p) (MaybeT . getRoot)+			return $ Sandbox tool $ fromFilePath (takeDirectory root </> sandboxDir)+			where+				getRoot = directoryContents >=> return . find ((== lookFor) . takeFileName)++-- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents+projectSandbox :: BuildTool -> Path -> IO (Maybe Sandbox)+projectSandbox tool fpath = runMaybeT $ do+	p <- searchPath (view path fpath) (MaybeT . getCabalFile)+	sboxes <- liftIO $ searchSandboxes (fromFilePath $ takeDirectory p)+	MaybeT $ return $ find ((== tool) . view sandboxType) sboxes+	where+		getCabalFile = directoryContents >=> return . find cabalFile++-- | Get package-db stack for sandbox+sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack+sandboxPackageDbStack (Sandbox CabalTool fpath) = do+	dir <- cabalSandboxPackageDb $ view path fpath+	return $ PackageDbStack [PackageDb $ fromFilePath dir]+sandboxPackageDbStack (Sandbox StackTool fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory (view path fpath)++-- | Search package-db stack with user-db as default+searchPackageDbStack :: BuildTool -> Path -> GhcM PackageDbStack+searchPackageDbStack tool p = do+	mbox <- liftIO $ projectSandbox tool 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 mproj -> searchPackageDbStack (maybe CabalTool (view projectBuildTool) mproj) 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 projectBuildTool proj) (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 p = liftIO . projectSandbox (view projectBuildTool p) . view projectPath $ p++-- | Get project package-db stack+getProjectPackageDbStack :: Project -> GhcM PackageDbStack+getProjectPackageDbStack = getProjectSandbox >=> maybe (return userDb) sandboxPackageDbStack
src/HsDev/Scan.hs view
@@ -1,255 +1,259 @@-{-# 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.Semigroup+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 Semigroup ScanContents where+	ScanContents lm lp ls <> ScanContents rm rp rs = ScanContents+		(uniqueBy (view _1) $ lm ++ rm)+		(uniqueBy (view _1) $ lp ++ rp)+		(ordNub $ ls ++ rs)++instance Monoid ScanContents where+	mempty = ScanContents [] [] []+	mappend l r = l <> r++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 projectBuildTool p') (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,226 @@-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 System.Directory.Paths (canonicalize)++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+	sequence [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+	mlocsDb <- sequence [ghcModuleLocation p m e | (p, m, e) <- ms]+	midTbl <- newLookupTable+	sidTbl <- newLookupTable+	let+		lookupModuleId p' m' e' = do+			mloc' <- ghcModuleLocation p' m' e'+			modId' <- ghcModuleId p' m' e'+			lookupTable mloc' modId' midTbl+	liftM catMaybes $ sequence [browseModule' mloc lookupModuleId (cacheInTableM sidTbl) p m e | ((p, m, e), mloc) <- zip ms mlocsDb, mloc `S.member` mlocs']+	where+		browseModule' :: ModuleLocation -> (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM (Maybe InspectedModule)+		browseModule' mloc modId' sym' p m e = tryT $ runInspect mloc $ 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 :: MonadIO m => GHC.PackageConfig -> GHC.Module -> Bool -> m ModuleLocation+ghcModuleLocation p m = liftIO . canonicalize . InstalledModule (map fromString $ GHC.libraryDirs p) (readPackage p) (fromString $ GHC.moduleNameString $ GHC.moduleName m)++ghcModuleId :: MonadIO m => GHC.PackageConfig -> GHC.Module -> Bool -> m 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,407 +1,411 @@-{-# 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
+{-# 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 Data.Maybe.JustIf+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 -> maybeWithWatcher $ \mwatcher -> 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))+						whenJustM (askSession sessionWatcher) $ \watcher -> 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+			mwatcher+			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 []+		whenJust mwatcher $ \watcher -> 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+		maybeWithWatcher fn+			| serverWatchFS sopts = Watcher.withWatcher (fn . Just)+			| otherwise = fn Nothing+		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+	whenJustM (askSession sessionWatcher) $ \w -> do+		-- 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,193 @@-{-# 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 GHC (getSessionDynFlags)++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+import HsDev.PackageDb.Types (globalDb)+import HsDev.Tools.Ghc.Worker+import qualified HsDev.Tools.Ghc.System as System++#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 showCompiler)+	| showCompiler = do+		w <- Log.noLog ghcWorker+		compVer <- inWorker w $ do+			workerSession SessionGhc globalDb []+			df <- getSessionDynFlags+			return $ System.formatBuildPath "{compiler}-{version}" (System.buildInfo df)+		putStrLn $ $cabalVersion ++ " " ++ compVer+		joinWorker w+	| otherwise = 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,921 @@-{-# 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, TypeApplications #-}+{-# 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.PackageDb.Types+import HsDev.Project.Types+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 :: Maybe 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 Bool |+	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,+	serverWatchFS :: Bool,+	serverSilent :: Bool }+		deriving (Show)++instance Default ServerOpts where+	def = ServerOpts def 0 Nothing "info" False Nothing True 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" (Version <$> compilerVersionFlag),+			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 <*>+		(not <$> noWatchFlag) <*>+		serverSilentFlag++instance FromCmd ClientOpts where+	cmdP = ClientOpts <$>+		(connectionArg <|> pure (clientPort def)) <*>+		prettyFlag <*>+		stdinFlag <*>+		(timeoutArg <|> pure (clientTimeout def)) <*>+		silentFlag++portArg :: Parser ConnectionPort+compilerVersionFlag :: Parser Bool+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+noWatchFlag :: Parser Bool++portArg = NetworkPort <$> option auto (long "port" <> metavar "number" <> help "connection port")+compilerVersionFlag = switch (long "compiler" <> short 'c' <> help "show compiler version")+#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")+noWatchFlag = switch (long "no-watch" <> help "don't watch filesystem for source changes")++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],+		scanBuildTool :: BuildTool,+		scanGhcOpts :: [String],+		scanDocs :: Bool,+		scanInferTypes :: Bool } |+	ScanProject {+		scanProjectPath :: Path,+		scanProjectBuildTool :: BuildTool,+		scanProjectDeps :: Bool } |+	ScanFile {+		scanFilePath :: Path,+		scanFileBuildTool :: BuildTool,+		scanFileProject :: Bool,+		scanFileDeps :: Bool } |+	ScanPackageDbs {+		scanPackageDbStack :: PackageDbStack } |+	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 btool ghcs docs infer) = Scan <$>+		traverse (paths f) projs <*>+		pure c <*>+		traverse (paths f) cs <*>+		traverse (paths f) fs <*>+		traverse (paths f) ps <*>+		pure btool <*>+		pure ghcs <*>+		pure docs <*>+		pure infer+	paths f (ScanProject proj tool deps) = ScanProject <$> paths f proj <*> pure tool <*> pure deps+	paths f (ScanFile file' tool scanProj deps) = ScanFile <$> paths f file' <*> pure tool <*> pure scanProj <*> pure deps+	paths f (ScanPackageDbs pdbs) = ScanPackageDbs <$> paths f pdbs+	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" (+			subparser (cmd "project" "scan project" (ScanProject <$> textArgument idm <*> toolArg <*> depsArg)) <|>+			subparser (cmd "file" "scan file" (ScanFile <$> textArgument idm <*> (toolArg <|> pure CabalTool) <*> depProjArg <*> depsArg)) <|>+			subparser (cmd "package-dbs" "scan package-dbs; note, that order of package-dbs matters - dependent package-dbs should go first" (ScanPackageDbs <$> (mkPackageDbStack <$> many packageDbArg))) <|>+			(Scan <$>+				many projectArg <*>+				cabalFlag <*>+				many sandboxArg <*>+				many cmdP <*>+				many (pathArg $ help "path") <*>+				(toolArg' <|> pure CabalTool) <*>+				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+depProjArg :: Parser Bool+depsArg :: Parser Bool+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+packageDbArg :: Parser PackageDb+pathArg :: Mod OptionFields String -> Parser Path+projectArg :: Parser Path+pureFlag :: Parser Bool+sandboxArg :: Parser Path+toolArg :: Parser BuildTool+toolArg' :: Parser BuildTool+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+depProjArg = fmap not $ switch (long "no-project" <> help "don't scan related project")+depsArg = fmap not $ switch (long "no-deps" <> help "don't scan dependent package-dbs")+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")+packageDbArg =+	flag' GlobalDb (long "global-db" <> help "global package-db") <|>+	flag' UserDb (long "user-db" <> help "per-user package-db") <|>+	fmap PackageDb (textOption (long "package-db" <> metavar "path" <> help "custom package-db"))+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")+toolArg =+	flag' CabalTool (long "cabal" <> help "use cabal as build tool") <|>+	flag' StackTool (long "stack" <> help "use stack as build tool") <|>+	toolArg'+toolArg' = option readTool (long "tool" <> help "specify build tool, `cabal` or `stack`") where+	readTool :: ReadM BuildTool+	readTool = do+		s <- str @String+		msum [+			guard (s == "cabal") >> return CabalTool,+			guard (s == "stack") >> return StackTool,+			readerError ("unknown build tool: {}" ~~ s)]++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 btool ghcs docs' infer') = cmdJson "scan" [+		"projects" .= projs,+		"cabal" .= cabal,+		"sandboxes" .= sboxes,+		"files" .= fs,+		"paths" .= ps,+		"build-tool" .= btool,+		"ghc-opts" .= ghcs,+		"docs" .= docs',+		"infer" .= infer']+	toJSON (ScanProject proj tool deps) = cmdJson "scan project" [+		"project" .= proj,+		"build-tool" .= tool,+		"scan-deps" .= deps]+	toJSON (ScanFile file' tool scanProj deps) = cmdJson "scan file" [+		"file" .= file',+		"build-tool" .= tool,+		"scan-project" .= scanProj,+		"scan-deps" .= deps]+	toJSON (ScanPackageDbs pdbs) = cmdJson "scan package-dbs" [+		"package-db-stack" .= pdbs]+	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 .:: "build-tool" <|> pure CabalTool) <*>+			v .::?! "ghc-opts" <*>+			(v .:: "docs" <|> pure False) <*>+			(v .:: "infer" <|> pure False)),+		guardCmd "scan project" v *> (ScanProject <$>+			v .:: "project" <*>+			v .:: "build-tool" <*>+			(v .:: "scan-deps" <|> pure True)),+		guardCmd "scan file" v *> (ScanFile <$>+			v .:: "file" <*>+			(v .:: "build-tool" <|> pure CabalTool) <*>+			(v .:: "scan-project" <|> pure True) <*>+			(v .:: "scan-deps" <|> pure True)),+		guardCmd "scan package-dbs" v *> (ScanPackageDbs <$> v .:: "package-db-stack"),+		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,648 @@-{-# 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.Monoid hiding ((<>))+import Data.Function+import Data.Ord+import Data.Semigroup+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 Semigroup Inspection where+	InspectionNone <> r = r+	l <> InspectionNone = l+	InspectionAt ltm lopts <> InspectionAt rtm ropts+		| ltm >= rtm = InspectionAt ltm lopts+		| otherwise = InspectionAt rtm ropts++instance Monoid Inspection where+	mempty = InspectionNone+	mappend l r = l <> r++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 <- modSummaries 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,237 @@-{-# 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,+	TcId,+	UnitId, InstalledUnitId, toInstalledUnitId,+	unitId, moduleUnitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle,+	LogAction, setLogAction, addLogAction,+	languages, flags,+	recSelParent, recSelCtors,+	getFixity,+	unqualStyle,+	exposedModuleName,+	exprType,+	modSummaries,+	cleanTemps+	) 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 qualified SysTools+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__ >= 804+type TcId = GHC.GhcTc+#else+type TcId = GHC.Id+#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__ > 800+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++modSummaries :: GHC.ModuleGraph -> [GHC.ModSummary]+#if __GLASGOW_HASKELL__ >= 804+modSummaries = GHC.mgModSummaries+#else+modSummaries = id+#endif++cleanTemps :: GHC.DynFlags -> IO ()+#if __GLASGOW_HASKELL__ >= 804+cleanTemps _ = return ()+#else+cleanTemps df = do+	SysTools.cleanTempFiles df+	SysTools.cleanTempDirs df+#endif
src/HsDev/Tools/Ghc/MGhc.hs view
@@ -1,241 +1,256 @@-{-# 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 CPP, 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 as Def+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 HsDev.Tools.Ghc.Compat (cleanTemps)++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++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 onErr = StateT $ \st -> gcatch (runStateT act st) (\e -> runStateT (onErr 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 onErr = ReaderT $ \v -> gcatch (runReaderT act v) (\e -> runReaderT (onErr 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+#if MIN_VERSION_exceptions(0,10,0)+	generalBracket acq rel act = GhcT $ \r -> generalBracket+		(unGhcT acq r)+		(\res exitCase -> case exitCase of+			ExitCaseSuccess v -> unGhcT (rel res (ExitCaseSuccess v)) r+			ExitCaseException e -> unGhcT (rel res (ExitCaseException e)) r+			ExitCaseAbort -> unGhcT (rel res ExitCaseAbort) r)+		(\res -> unGhcT (act res) r)+#elif MIN_VERSION_exceptions(0,9,0)+	generalBracket acq rel clean act = GhcT $ \r -> generalBracket+		(unGhcT acq r)+		(\res -> unGhcT (rel res) r)+		(\res e -> unGhcT (clean res e) r)+		(\res -> unGhcT (act res) r)+#endif++-- | 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.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+	cleanTemps 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,149 @@-{-# 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 GhcPlugins (mkFunTys)+import CoreUtils as C+import NameSet (NameSet)+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 TcId) 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 TcId) 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 TcId) 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' = everythingTyped (++) [] ([] `mkQ` (\x -> [x | p' x]))+	p (L spn _) = isGoodSrcSpan spn++everythingTyped :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+everythingTyped k z f x+	| (const False `extQ` nameSet) x = z+	| otherwise = foldl k (f x) (gmapQ (everythingTyped k z f) x)+	where+		nameSet :: NameSet -> Bool+		nameSet = const True++moduleTypes :: GhcMonad m => Path -> m [(SrcSpan, Type)]+moduleTypes fpath = do+	fpath' <- liftIO $ canonicalize fpath+	mg <- getModuleGraph+	[m] <- liftIO $ flip filterM (modSummaries 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 TcId]),+		mapM getType (locatedTypes ts :: [LHsBind TcId]),+		mapM getType (locatedTypes ts :: [LPat TcId])]++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,119 @@-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
+{-# LANGUAGE CPP #-}++module HsDev.Tools.HLint (+	hlint,+	hlintSupported,++	module Control.Monad.Except+	) where++import Control.Monad.Except+import Data.Text (Text)++import HsDev.Tools.Base++#ifndef NOHLINT+import Control.Arrow+import Control.Lens (over, view, _Just)+import Data.Char+import Data.List+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Data.Ord+import Data.String (fromString)+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.HLint3 (argsSettings, parseModuleEx, applyHints, Idea(..), parseErrorMessage, ParseFlags(..), CppFlags(..))+import qualified Language.Haskell.HLint3 as HL (Severity(..))++import System.Directory.Paths+import HsDev.Symbols.Location+import HsDev.Util (readFileUtf8)+#endif++hlint :: [String] -> FilePath -> Maybe Text -> ExceptT String IO [Note OutputMessage]+#ifndef NOHLINT+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]+#else+hlint _ _ _ = throwError "Compiled with no hlint support"+#endif++#ifndef NOHLINT+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+#endif++hlintSupported :: Bool+#ifndef NOHLINT+hlintSupported = True+#else+hlintSupported = False+#endif
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,137 @@-{-# 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.Semigroup+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 Semigroup HsDevError where+	_ <> r = r++instance Monoid HsDevError where+	mempty = HsDevFailure+	mappend l r = l <> 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,317 +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, 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
+{-# 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,189 @@-{-# 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 (Text, unpack)+import qualified Data.Text as T+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 Text+exports v = mkSet (v ^.. _Just . values . key "exports" . values . key "id" . key "name" . _String)++imports :: Maybe Value -> S.Set Import+imports v = mkSet $ do+	is <- v ^.. _Just . values . key "imports" . values+	maybeToList $ Import <$> (is ^? key "pos" . _JSON) <*> (is ^? key "name" . _String) <*> (is ^? key "qualified" . _Bool) <*> pure (is ^? key "as" . _String)++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", "--cabal", "--no-deps"]++		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 ^.. _Just . values . key "level" . _String) `shouldSatisfy` (("error" :: Text) `notElem`)++		it "should return types and docs" $ do+			test' <- send s ["whois", "test", "--file", dir </> "tests/test-package/ModuleOne.hs"]+			let+				testType :: Maybe Text+				testType = test' ^? _Just . values . key "info" . key "type" . _String+			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, Text)]+				exprs = do+					note' <- ts ^.. _Just . values+					rgn' <- maybeToList $ note' ^? key "region" . _JSON+					ty' <- maybeToList $ note' ^? key "note" . key "type" . _String+					return (rgn', ty')+			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 Text+				whoName = who' ^? _Just . values . key "id" . key "name" . _String+				whoType :: Maybe Text+				whoType = who' ^? _Just . values . key "info" . key "type" . _String+			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 ^? _Just . values . key "info" . key "what" . _String) `shouldBe` Just "data"+			(whoCtor ^? _Just . values . key "info" . key "what" . _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 ^.. _Just . values . key "note" . key "message" . _String) `shouldSatisfy` (any ("Defined but not used" `T.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 :: [(Text, Region)]+				locs = do+					n <- us ^.. _Just . values+					nm <- maybeToList $ n ^? key "in" . key "name" . _String+					p <- maybeToList $ n ^? key "at" . _JSON+					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 ^.. _Just . values+					maybeToList $ n ^? key "at" . _JSON+			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 ^.. _Just . values . key "ok" . _String `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 ^.. _Just . values . key "ok" . _String `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 ^.. _Just . values . key "id" . key "name" . _String `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