hsdev 0.2.5.1 → 0.3.0.0

raw patch · 88 files changed

+11120/−10131 lines, 88 filesdep +direct-sqlitedep +haskell-namesdep +sqlite-simpledep ~basedep ~containersdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: direct-sqlite, haskell-names, sqlite-simple, stm

Dependency ranges changed: base, containers, directory, haskell-src-exts, hdocs, hformat, text-region

API changes (from Hackage documentation)

Files

• data/hsdev.sql +283/−0
• hsdev.cabal +245/−318
• src/Control/Apply/Util.hs +1/−7
• src/Control/Concurrent/FiniteChan.hs +33/−49
• src/Control/Concurrent/Util.hs +8/−1
• src/Control/Concurrent/Worker.hs +34/−38
• src/Data/Async.hs +0/−47
• src/Data/Deps.hs +101/−70
• src/Data/Group.hs +0/−40
• src/Data/Help.hs +24/−21
• src/Data/LookupTable.hs +46/−0
• src/Data/Maybe/JustIf.hs +1/−9
• src/HsDev.hs +31/−33
• src/HsDev/Cache.hs +0/−79
• src/HsDev/Cache/Structured.hs +0/−72
• src/HsDev/Client/Commands.hs +622/−414
• src/HsDev/Commands.hs +0/−193
• src/HsDev/Database.hs +0/−253
• src/HsDev/Database/Async.hs +0/−30
• src/HsDev/Database/SQLite.hs +527/−0
• src/HsDev/Database/SQLite/Instances.hs +226/−0
• src/HsDev/Database/SQLite/Schema.hs +20/−0
• src/HsDev/Database/SQLite/Schema/TH.hs +16/−0
• src/HsDev/Database/SQLite/Select.hs +111/−0
• src/HsDev/Database/SQLite/Transaction.hs +98/−0
• src/HsDev/Database/Update.hs +601/−447
• src/HsDev/Database/Update/Types.hs +43/−10
• src/HsDev/Display.hs +77/−54
• src/HsDev/Error.hs +53/−63
• src/HsDev/Inspect.hs +450/−467
• src/HsDev/Inspect/Order.hs +39/−0
• src/HsDev/PackageDb.hs +63/−106
• src/HsDev/PackageDb/Types.hs +113/−0
• src/HsDev/Project.hs +197/−167
• src/HsDev/Project/Compat.hs +63/−62
• src/HsDev/Project/Types.hs +352/−298
• src/HsDev/Sandbox.hs +185/−161
• src/HsDev/Scan.hs +251/−209
• src/HsDev/Scan/Browse.hs +245/−248
• src/HsDev/Server/Base.hs +395/−159
• src/HsDev/Server/Commands.hs +180/−434
• src/HsDev/Server/Message.hs +118/−115
• src/HsDev/Server/Message/Lisp.hs +47/−0
• src/HsDev/Server/Types.hs +813/−792
• src/HsDev/Stack.hs +133/−131
• src/HsDev/Symbols.hs +127/−278
• src/HsDev/Symbols/Class.hs +30/−20
• src/HsDev/Symbols/Documented.hs +62/−24
• src/HsDev/Symbols/HaskellNames.hs +61/−0
• src/HsDev/Symbols/Location.hs +353/−277
• src/HsDev/Symbols/Name.hs +82/−0
• src/HsDev/Symbols/Parsed.hs +197/−0
• src/HsDev/Symbols/Resolve.hs +27/−176
• src/HsDev/Symbols/Types.hs +529/−620
• src/HsDev/Symbols/Util.hs +0/−203
• src/HsDev/Tools/AutoFix.hs +67/−92
• src/HsDev/Tools/Base.hs +101/−117
• src/HsDev/Tools/Cabal.hs +85/−85
• src/HsDev/Tools/ClearImports.hs +113/−112
• src/HsDev/Tools/Ghc/Check.hs +65/−88
• src/HsDev/Tools/Ghc/Compat.hs +192/−154
• src/HsDev/Tools/Ghc/MGhc.hs +215/−204
• src/HsDev/Tools/Ghc/Prelude.hs +1/−5
• src/HsDev/Tools/Ghc/Session.hs +42/−49
• src/HsDev/Tools/Ghc/Types.hs +141/−143
• src/HsDev/Tools/Ghc/Worker.hs +267/−249
• src/HsDev/Tools/HDocs.hs +179/−60
• src/HsDev/Tools/HLint.hs +99/−97
• src/HsDev/Tools/Hayoo.hs +139/−135
• src/HsDev/Tools/Refact.hs +53/−0
• src/HsDev/Tools/Types.hs +100/−99
• src/HsDev/Types.hs +124/−112
• src/HsDev/Util.hs +309/−340
• src/HsDev/Watcher.hs +73/−73
• src/System/Directory/Paths.hs +85/−31
• src/System/Directory/Watcher.hs +174/−151
• src/System/Win32/FileMapping/NamePool.hs +4/−2
• src/System/Win32/PowerShell.hs +36/−214
• tests/Test.hs +100/−47
• tests/data/ModuleTwo.modified.hs +25/−0
• tests/data/base.sql +4/−0
• tests/test-package/ModuleOne.hs +14/−14
• tools/Tool.hs +0/−48
• tools/hsautofix.hs +0/−87
• tools/hscabal.hs +0/−10
• tools/hsclearimports.hs +0/−44
• tools/hshayoo.hs +0/−22
• tools/hsinspect.hs +0/−52

@@ -0,0 +1,283 @@+pragma case_sensitive_like = true;
+
+create table hsdev (
+	option text,
+	value json
+);
+
+create table package_dbs (
+	package_db text, -- global, user or path
+	package_name text,
+	package_version text
+);
+
+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;
+
+create table projects (
+	id integer primary key autoincrement,
+	name text,
+	cabal text,
+	version text,
+	package_db_stack json -- list of package-db
+);
+
+create unique index projects_id_index on projects (id);
+
+create table libraries (
+	project_id integer,
+	modules json, -- list of modules
+	build_info_id integer
+);
+
+create table executables (
+	project_id integer,
+	name text,
+	path text,
+	build_info_id integer
+);
+
+create table tests (
+	project_id integer,
+	name text,
+	enabled integer,
+	main text,
+	build_info_id integer
+);
+
+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;
+
+create table build_infos(
+	id integer primary key autoincrement,
+	depends json, -- list of dependencies
+	language text,
+	extensions json, -- list of extensions
+	ghc_options json, -- list of ghc-options
+	source_dirs json, -- list of source directories
+	other_modules json -- list of other modules
+);
+
+create view projects_deps (
+	cabal,
+	package_name,
+	package_version
+) as
+select distinct p.cabal, deps.value, 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);
+
+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)
+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, package_dbs as ps
+where (m.package_name == ps.package_name) and (m.package_version == ps.package_version) and (ps.package_db in ('user-db', 'global-db'));
+
+create unique index build_infos_id_index on build_infos (id);
+
+create table symbols (
+	id integer primary key autoincrement,
+	name text,
+	module_id integer,
+	docs text,
+	line integer,
+	column integer,
+	what text, -- kind of symbol: function, method, ...
+	type text,
+	parent text,
+	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 index symbols_module_id_index on symbols (module_id);
+create index symbols_name_index on symbols (name);
+
+create table modules (
+	id integer primary key autoincrement,
+	file text,
+	cabal text,
+	-- project_id integer,
+	install_dirs json, -- list of paths
+	package_name text,
+	package_version text,
+	installed_name text, -- if not null, should be equal to name
+	other_location text,
+
+	name text,
+	docs text,
+	fixities json, -- list of fixities
+	tags json, -- dict of tags, value not used, tag is set if present
+	inspection_error text,
+	inspection_time integer,
+	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;
+
+create table imports (
+	module_id integer,
+	line integer,
+	module_name text,
+	qualified integer,
+	alias text,
+	hiding integer,
+	import_list json -- list of import specs
+);
+
+create index imports_module_id_index on imports (module_id);
+
+create view imported_modules as
+select i.*, im.id as imported_id
+from imports as i, projects_modules_scope as ps, modules as im, modules as m
+where
+	i.module_id == m.id and
+	((ps.cabal is null and m.cabal is null) or (ps.cabal == m.cabal)) and
+	ps.module_id == im.id and
+	im.name == i.module_name;
+
+create view imported_scopes as
+select i.*, q.value as qualifier, s.name as name, s.id as symbol_id
+from imported_modules 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.imported_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));
+
+create table exports (
+	module_id integer,
+	symbol_id integer
+);
+
+create index exports_module_id_index on exports (module_id);
+
+create table scopes (
+	module_id integer,
+	qualifier text,
+	name text,
+	symbol_id integer
+);
+
+create index scopes_module_id_index on scopes (module_id);
+
+create view completions (
+	module_id,
+	completion,
+	symbol_id
+) as
+select id, (case when sc.qualifier is null then sc.name else sc.qualifier || '.' || sc.name end) as full_name, sc.symbol_id
+from modules as m, scopes as sc
+where (m.id == sc.module_id);
+
+create table names (
+	module_id integer,
+	qualifier text,
+	name text,
+	line integer,
+	column integer,
+	line_to integer,
+	column_to integer,
+	def_line integer,
+	def_column integer,
+	inferred_type text,
+	resolved_module text,
+	resolved_name text,
+	resolve_error text
+);
+
+create unique index names_position_index on names (module_id, line, column, line_to, column_to);
+create index names_module_id_index on names (module_id);
+
+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, projects_modules_scope as ps, symbols as s
+where
+	(n.module_id == srcm.id) and
+	(srcm.cabal == ps.cabal) and
+	(m.id == ps.module_id) and
+	(m.name == n.resolved_module) and
+	(s.module_id == m.id) and
+	(s.name == n.resolved_name);
+
+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);
+
+create table types (
+	module_id integer,
+	line integer,
+	column integer,
+	line_to integer,
+	column_to integer,
+	expr text,
+	type text
+);
+
+create table file_contents (
+	file text not null,
+	contents text,
+	mtime integer
+);
+
+create unique index file_contents_index on file_contents (file);

@@ -1,318 +1,245 @@-name:                hsdev-version:             0.2.5.1-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--source-repository head-  type: git-  location: git://github.com/mvoidex/hsdev.git--library-  hs-source-dirs: src-  ghc-options: -Wall -fno-warn-tabs-  exposed-modules:-    Control.Apply.Util-    Control.Concurrent.FiniteChan-    Control.Concurrent.Worker-    Control.Concurrent.Util-    Data.Async-    Data.Deps-    Data.Group-    Data.Help-    Data.Lisp-    Data.Maybe.JustIf-    HsDev-    HsDev.Cache-    HsDev.Cache.Structured-    HsDev.Client.Commands-    HsDev.Commands-    HsDev.Database-    HsDev.Database.Async-    HsDev.Database.Update-    HsDev.Database.Update.Types-    HsDev.Display-    HsDev.Error-    HsDev.Inspect-    HsDev.PackageDb-    HsDev.Project-    HsDev.Project.Compat-    HsDev.Project.Types-    HsDev.Scan-    HsDev.Scan.Browse-    HsDev.Server.Base-    HsDev.Server.Commands-    HsDev.Server.Message-    HsDev.Server.Types-    HsDev.Sandbox-    HsDev.Stack-    HsDev.Symbols-    HsDev.Symbols.Class-    HsDev.Symbols.Location-    HsDev.Symbols.Documented-    HsDev.Symbols.Resolve-    HsDev.Symbols.Types-    HsDev.Symbols.Util-    HsDev.Tools.AutoFix-    HsDev.Tools.Base-    HsDev.Tools.Cabal-    HsDev.Tools.ClearImports-    HsDev.Tools.Ghc.Check-    HsDev.Tools.Ghc.Compat-    HsDev.Tools.Ghc.MGhc-    HsDev.Tools.Ghc.Prelude-    HsDev.Tools.Ghc.Types-    HsDev.Tools.Ghc.Worker-    HsDev.Tools.Ghc.Session-    HsDev.Tools.Hayoo-    HsDev.Tools.HDocs-    HsDev.Tools.HLint-    HsDev.Tools.Types-    HsDev.Types-    HsDev.Util-    HsDev.Version-    HsDev.Watcher-    HsDev.Watcher.Types-    System.Directory.Paths-    System.Directory.Watcher--  if os(windows)-    build-depends:-      Win32 >= 2.3.0-    exposed-modules:-      System.Win32.PowerShell-      System.Win32.FileMapping.NamePool-      System.Win32.FileMapping.Memory-  else-    build-depends:-      unix >= 2.7.0--  if impl(ghc >= 8.2) && impl(ghc < 8.3)-    build-depends:-      haddock-api >= 2.18.0 && < 2.19.0,-      ghc == 8.2.*,-      ghc-boot,-      directory >= 1.2.6.0-  if impl(ghc >= 8.0) && impl(ghc < 8.2)-    build-depends:-      haddock-api >= 2.17.0 && < 2.18.0,-      ghc >= 8.0.0 && < 8.1.0,-      ghc-boot,-      directory >= 1.2.6.0-  if impl(ghc < 8.0)-    build-depends:-      haddock-api >= 2.16.0 && < 2.17.0,-      ghc >= 7.10.0 && < 7.11.0,-      bin-package-db,-      directory == 1.2.2.*--  build-depends:-    base >= 4.7 && < 5,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    array >= 0.5.0,-    async >= 2.0,-    attoparsec >= 0.11.0,-    bytestring >= 0.10.0,-    Cabal >= 1.22.0,-    containers >= 0.5.0,-    cpphs >= 1.19.0,-    data-default >= 0.5.0,-    deepseq >= 1.4.0,-    exceptions >= 0.6.0,-    filepath >= 1.4.0,-    fsnotify >= 0.2.1,-    ghc-paths >= 0.1.0,-    ghc-syb-utils >= 0.2.3,-    haskell-src-exts >= 1.18.0 && < 1.20.0,-    hdocs >= 0.5.0,-    hformat == 0.3.*,-    hlint >= 1.9.13 && < 2.1,-    HTTP >= 4000.2.0,-    lens >= 4.8,-    lifted-base >= 0.2,-    monad-control >= 1.0,-    monad-loops >= 0.4,-    mmorph >= 1.0 && < 1.2,-    mtl >= 2.2.0,-    network >= 2.6.0,-    optparse-applicative >= 0.11,-    process >= 1.2.0,-    regex-pcre-builtin >= 0.94,-    scientific >= 0.3,-    simple-log == 0.9.*,-    syb >= 0.5.1,-    template-haskell,-    text >= 1.2.0,-    text-region == 0.3.*,-    time >= 1.5.0,-    transformers >= 0.4.0,-    transformers-base >= 0.4.0,-    uniplate >= 1.6.0,-    unordered-containers >= 0.2.0,-    vector >= 0.10.0--executable hsdev-  main-is: hsdev.hs-  hs-source-dirs: tools-  ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4"--  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    bytestring >= 0.10.0,-    containers >= 0.5.0,-    deepseq >= 1.4.0,-    directory,-    exceptions >= 0.6.0,-    filepath >= 1.4.0,-    monad-loops >= 0.4.0,-    mtl >= 2.2.0,-    network >= 2.6.0,-    optparse-applicative >= 0.11,-    process >= 1.2.0,-    text >= 1.2.0,-    transformers >= 0.4.0,-    unordered-containers >= 0.2.0--executable hsinspect-  main-is: hsinspect.hs-  hs-source-dirs: tools-  ghc-options: -Wall -fno-warn-tabs-  other-modules:-    Tool-  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    bytestring >= 0.10.0,-    containers >= 0.5.0,-    data-default >= 0.5.0,-    directory,-    filepath >= 1.4.0,-    mtl >= 2.2.0,-    optparse-applicative >= 0.11,-    text >= 1.2.0,-    transformers >= 0.4.0,-    unordered-containers >= 0.2.0,-    vector >= 0.10.0--executable hsclearimports-  main-is: hsclearimports.hs-  hs-source-dirs: tools-  ghc-options: -Wall -fno-warn-tabs-  other-modules:-    Tool-  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    bytestring >= 0.10.0,-    containers >= 0.5.0,-    data-default >= 0.5.0,-    directory,-    haskell-src-exts >= 1.18.0 && < 1.20.0,-    lens >= 4.8,-    mtl >= 2.2.0,-    optparse-applicative >= 0.11,-    text >= 1.2.0,-    transformers >= 0.4.0,-    unordered-containers >= 0.2.0--executable hscabal-  main-is: hscabal.hs-  hs-source-dirs: tools-  ghc-options: -Wall -fno-warn-tabs-  other-modules:-    Tool-  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    bytestring >= 0.10.0,-    containers >= 0.5.0,-    data-default >= 0.5.0,-    mtl >= 2.2.0,-    optparse-applicative >= 0.11,-    text >= 1.2.0,-    transformers >= 0.4.0,-    unordered-containers >= 0.2.0--executable hshayoo-  main-is: hshayoo.hs-  hs-source-dirs: tools-  ghc-options: -Wall -fno-warn-tabs-  other-modules:-    Tool-  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    bytestring >= 0.10.0,-    containers >= 0.5.0,-    data-default >= 0.5.0,-    mtl >= 2.2.0,-    optparse-applicative >= 0.11,-    text >= 1.2.0,-    transformers >= 0.4.0,-    unordered-containers >= 0.2.0--executable hsautofix-  main-is: hsautofix.hs-  hs-source-dirs: tools-  ghc-options: -Wall -fno-warn-tabs-  other-modules:-    Tool-  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-pretty >= 0.7.0,-    bytestring >= 0.10.0,-    data-default >= 0.5.0,-    directory,-    filepath >= 1.4.0,-    lens >= 4.8,-    mtl >= 2.2.0,-    optparse-applicative >= 0.11,-    transformers >= 0.4.0--test-suite test-  main-is: Test.hs-  hs-source-dirs: tests-  ghc-options: -threaded -Wall -fno-warn-tabs-  type: exitcode-stdio-1.0-  build-depends:-    base >= 4.7 && < 5,-    hsdev,-    aeson >= 0.7.0,-    aeson-lens >= 0.5.0,-    async >= 2.0,-    data-default >= 0.5.0,-    deepseq >= 1.4.0,-    directory,-    filepath >= 1.4.0,-    containers >= 0.5.0,-    hformat == 0.3.*,-    hspec,-    lens >= 4.8,-    mtl >= 2.2.0,-    text >= 1.2.0+name:                hsdev
+version:             0.3.0.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
+  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.Order
+    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.Check
+    HsDev.Tools.Ghc.Compat
+    HsDev.Tools.Ghc.MGhc
+    HsDev.Tools.Ghc.Prelude
+    HsDev.Tools.Ghc.Session
+    HsDev.Tools.Ghc.Types
+    HsDev.Tools.Ghc.Worker
+    HsDev.Tools.Hayoo
+    HsDev.Tools.HDocs
+    HsDev.Tools.HLint
+    HsDev.Tools.Refact
+    HsDev.Tools.Types
+    HsDev.Types
+    HsDev.Util
+    HsDev.Version
+    HsDev.Watcher
+    HsDev.Watcher.Types
+    System.Directory.Paths
+    System.Directory.Watcher
+
+  if os(windows)
+    build-depends:
+      Win32 >= 2.3.0
+    exposed-modules:
+      System.Win32.PowerShell
+      System.Win32.FileMapping.NamePool
+      System.Win32.FileMapping.Memory
+  else
+    build-depends:
+      unix >= 2.7.0
+
+  if impl(ghc >= 8.2) && impl(ghc < 8.3)
+    if flag(docs)
+      build-depends:
+        haddock-api >= 2.18.0 && < 2.19.0
+
+    build-depends:
+      ghc == 8.2.*,
+      ghc-boot,
+      directory >= 1.2.6.0
+  if impl(ghc >= 8.0) && impl(ghc < 8.2)
+    if flag(docs)
+      build-depends:
+        haddock-api >= 2.17.0 && < 2.18.0
+
+    build-depends:
+      ghc >= 8.0.0 && < 8.1.0,
+      ghc-boot,
+      directory >= 1.2.6.0
+  if impl(ghc < 8.0)
+    if flag(docs)
+      build-depends:
+        haddock-api >= 2.16.0 && < 2.17.0
+
+    build-depends:
+      ghc >= 7.10.0 && < 7.11.0,
+      bin-package-db,
+      directory == 1.2.2.*
+
+  if flag(docs)
+    build-depends:
+      hdocs >= 0.5.1
+
+  build-depends:
+    base >= 4.7 && < 5,
+    aeson >= 0.7.0,
+    aeson-pretty >= 0.7.0,
+    array >= 0.5.0,
+    async >= 2.0,
+    attoparsec >= 0.11.0,
+    bytestring >= 0.10.0,
+    Cabal >= 1.22.0,
+    containers >= 0.5,
+    cpphs >= 1.19.0,
+    data-default >= 0.5.0,
+    deepseq >= 1.4.0,
+    exceptions >= 0.6.0,
+    filepath >= 1.4.0,
+    fsnotify >= 0.2.1,
+    ghc-paths >= 0.1.0,
+    ghc-syb-utils >= 0.2.3,
+    haskell-names >= 0.9.0 && < 0.10.0,
+    haskell-src-exts >= 1.18.0 && < 1.21.0,
+    hformat >= 0.3.0,
+    hlint >= 1.9.13 && < 2.1,
+    HTTP >= 4000.2.0,
+    lens >= 4.8,
+    lifted-base >= 0.2,
+    monad-control >= 1.0,
+    monad-loops >= 0.4,
+    mmorph >= 1.0 && < 1.2,
+    mtl >= 2.2.0,
+    network >= 2.6.0,
+    optparse-applicative >= 0.11,
+    process >= 1.2.0,
+    regex-pcre-builtin >= 0.94,
+    scientific >= 0.3,
+    simple-log == 0.9.*,
+    stm == 2.4.*,
+    direct-sqlite >= 2.3.21,
+    sqlite-simple,
+    syb >= 0.5.1,
+    template-haskell,
+    text >= 1.2.0,
+    text-region >= 0.3,
+    time >= 1.5.0,
+    transformers >= 0.4.0,
+    transformers-base >= 0.4.0,
+    uniplate >= 1.6.0,
+    unordered-containers >= 0.2.0,
+    vector >= 0.10.0
+
+executable hsdev
+  main-is: hsdev.hs
+  hs-source-dirs: tools
+  ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4"
+
+  build-depends:
+    base >= 4.7 && < 5,
+    hsdev,
+    aeson >= 0.7.0,
+    aeson-pretty >= 0.7.0,
+    bytestring >= 0.10.0,
+    containers >= 0.5,
+    deepseq >= 1.4.0,
+    directory,
+    exceptions >= 0.6.0,
+    filepath >= 1.4.0,
+    monad-loops >= 0.4.0,
+    mtl >= 2.2.0,
+    network >= 2.6.0,
+    optparse-applicative >= 0.11,
+    process >= 1.2.0,
+    text >= 1.2.0,
+    transformers >= 0.4.0,
+    unordered-containers >= 0.2.0
+
+test-suite test
+  main-is: Test.hs
+  hs-source-dirs: tests
+  ghc-options: -threaded -Wall -fno-warn-tabs
+  type: exitcode-stdio-1.0
+  build-depends:
+    base >= 4.7 && < 5,
+    hsdev,
+    aeson >= 0.7.0,
+    aeson-lens >= 0.5.0,
+    async >= 2.0,
+    data-default >= 0.5.0,
+    deepseq >= 1.4.0,
+    directory,
+    filepath >= 1.4.0,
+    containers >= 0.5.0,
+    hformat == 0.3.*,
+    hspec,
+    lens >= 4.8,
+    mtl >= 2.2.0,
+    text >= 1.2.0

@@ -1,5 +1,5 @@ module Control.Apply.Util (
-	(&), chain, with
+	(&), chain
 	) where
 
 (&) :: a -> (a -> b) -> b
@@ -7,9 +7,3 @@ 
 chain :: [a -> a] -> a -> a
 chain = foldr (.) id
-
--- | Flipped version of 'chain', which can be used like this:
---
--- >foo `with` [f, g, h]
-with :: a -> [a -> a] -> a
-with = flip chain

@@ -1,73 +1,57 @@ module Control.Concurrent.FiniteChan (
 	Chan,
-	newChan, dupChan, openedChan, closedChan, doneChan, sendChan, putChan, getChan, readChan, closeChan, stopChan
+	newChan, openedChan, closedChan, doneChan, sendChan, getChan, closeChan, stopChan
 	) where
 
 import Control.Monad (void, when, liftM2)
-import qualified Control.Concurrent.Chan as C
-import Control.Concurrent.MVar
-import Data.Maybe
-
-data State = Opened | Closing | Closed deriving (Eq, Ord, Enum, Bounded, Read, Show)
+import Control.Monad.Loops
+import Control.Concurrent.STM
 
--- | 'Chan' is stoppable channel unline 'Control.Concurrent.Chan'
-data Chan a = Chan (C.Chan (Maybe a)) (MVar State)
+-- | 'Chan' is stoppable channel
+data Chan a = Chan {
+	chanOpened :: TMVar Bool,
+	chanQueue :: TQueue a }
 
--- | Create channel
+-- -- | Create new channel
 newChan :: IO (Chan a)
-newChan = liftM2 Chan C.newChan (newMVar Opened)
-
--- | Duplicate channel
-dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan ch st) = liftM2 Chan (C.dupChan ch) (return st)
+newChan = liftM2 Chan (newTMVarIO True) newTQueueIO
 
 -- | Is channel opened
 openedChan :: Chan a -> IO Bool
-openedChan (Chan _ st) = (== Opened) <$> readMVar st
+openedChan = atomically . readTMVar . chanOpened
 
--- | Is channel closing/closed
+-- | Is channel closed
 closedChan :: Chan a -> IO Bool
-closedChan (Chan _ st) = (/= Opened) <$> readMVar st
+closedChan = fmap not . openedChan
 
--- | Is channed closed and all data allready read from it
+-- | Is channel closed and all data consumed
 doneChan :: Chan a -> IO Bool
-doneChan (Chan _ st) = (== Closed) <$> readMVar st
+doneChan ch = atomically $ do
+	o <- readTMVar $ chanOpened ch
+	e <- isEmptyTQueue (chanQueue ch)
+	return $ not o && e
 
--- | Write data to channel
+-- | Write data to channel if it is open
 sendChan :: Chan a -> a -> IO Bool
-sendChan (Chan ch st) v = do
-	state <- readMVar st
-	if state == Opened
-		then do
-			C.writeChan ch (Just v)
-			return True
-		else return False
-
--- | Put data to channel
-putChan :: Chan a -> a -> IO ()
-putChan ch = void . sendChan ch
+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 (Chan ch st) = do
-	state <- readMVar st
-	if state == Closed then return Nothing else do
-		r <- C.readChan ch
-		when (isNothing r) (void $ swapMVar st Closed)
-		return r
-
--- | Read channel contents
-readChan :: Chan a -> IO [a]
-readChan (Chan ch _) = (catMaybes . takeWhile isJust) <$> C.getChanContents ch
+getChan ch = atomically $ do
+	o <- readTMVar $ chanOpened ch
+	if o
+		then fmap Just (readTQueue (chanQueue ch))
+		else tryReadTQueue (chanQueue ch)
 
--- | Close channel. 'putChan' will still work, but no data will be available on other ending
+-- | Close channel
 closeChan :: Chan a -> IO ()
-closeChan (Chan ch st) = do
-	state <- readMVar st
-	when (state == Opened) $ do
-		_ <- swapMVar st Closing
-		C.writeChan ch Nothing
+closeChan ch = atomically $ void $ swapTMVar (chanOpened ch) False
 
--- | Stop channel and return all data
+-- | Close channel and read all messages
 stopChan :: Chan a -> IO [a]
-stopChan ch = closeChan ch >> readChan ch
+stopChan ch = do
+	closeChan ch
+	whileJust (getChan ch) return

@@ -1,5 +1,5 @@ module Control.Concurrent.Util (
-	fork, timeout
+	fork, timeout, sync
 	) where
 
 import Control.Concurrent
@@ -13,3 +13,10 @@ 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

@@ -2,10 +2,9 @@ 
 module Control.Concurrent.Worker (
 	Worker(..), WorkerStopped(..),
-	startWorker, workerDone,
-	sendTask, pushTask,
-	restartWorker, stopWorker, syncTask,
-	inWorkerWith, inWorker, inWorker_,
+	startWorker, workerAlive, workerDone,
+	sendTask, stopWorker, joinWorker, syncTask,
+	inWorkerWith, inWorker,
 
 	module Control.Concurrent.Async
 	) where
@@ -14,7 +13,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Catch
 import Control.Monad.Except
-import Data.Maybe (isJust)
+import Data.Maybe (isNothing)
 import Data.Typeable
 
 import Control.Concurrent.FiniteChan
@@ -22,34 +21,36 @@ 
 data Worker m = Worker {
 	workerChan :: Chan (Async (), m ()),
-	workerWrap :: forall a. m a -> m a,
-	workerTask :: MVar (Async ()),
-	workerTouch :: IO () }
+	workerTask :: MVar (Async ()) }
 
 data WorkerStopped = WorkerStopped deriving (Show, Typeable)
 
 instance Exception WorkerStopped
 
 -- | Create new worker
-startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (forall a. m a -> m a) -> IO (Worker m)
-startWorker run initialize wrap = do
+startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m)
+startWorker run initialize handleErrs = do
 	ch <- newChan
 	taskVar <- newEmptyMVar
 	let
-		start = async $ run $ initialize go
+		job = onException (run $ initialize go) $ do
+			closeChan ch
+			abort
 		go = do
 			t <- fmap snd <$> liftIO (getChan ch)
-			maybe (return ()) (>> go) t
-	start >>= putMVar taskVar
-	let
-		restart = do
-			done <- doneChan ch
-			unless done $ do
-				task <- readMVar taskVar
-				stopped <- isJust <$> poll task
-				when stopped (start >>= void . swapMVar taskVar)
-	return $ Worker ch wrap taskVar restart
+			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
 
@@ -57,7 +58,7 @@ sendTask w act = mfix $ \async' -> do
 	var <- newEmptyMVar
 	let
-		act' = (workerWrap w act >>= liftIO . putMVar var . Right) `catch` onError
+		act' = (act >>= liftIO . putMVar var . Right) `catch` onError
 		onError :: MonadIO m => SomeException -> m ()
 		onError = liftIO . putMVar var . Left
 		f = do
@@ -67,30 +68,25 @@ 			either throwM return r
 	async f
 
-pushTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a)
-pushTask w act = workerTouch w >> sendTask w act
-
-restartWorker :: Worker m -> IO ()
-restartWorker w = do
-	async' <- readMVar (workerTask w)
-	cancel async'
-	void $ waitCatch async'
-
+-- | 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 = pushTask w (return ()) >>= void . wait
+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 (pushTask w act) >>= (liftIO . waitCatch >=> either err return)
+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 = pushTask w act >>= liftIO . wait
-
--- | Run action in worker and wait for result
-inWorker_ :: (MonadIO m, MonadCatch m) => Worker m -> m a -> ExceptT SomeException IO a
-inWorker_ w act = liftIO (pushTask w act) >>= ExceptT . waitCatch
+inWorker w act = sendTask w act >>= liftIO . wait

@@ -1,47 +0,0 @@-module Data.Async (
-	Event(..),
-	event,
-	Async(..),
-	newAsync, readAsync, modifyAsync,
-
-	-- * Reexports
-	Group, NFData
-	) where
-
-import Control.DeepSeq (NFData, force)
-import Control.Monad (forM_)
-import Control.Concurrent
-
-import Data.Group (Group(..))
-
--- | Event on async value
-data Event a = Append a | Remove a | Clear | Modify (a -> a) | Action (a -> IO a)
-
--- | Event to function
-event :: Group a => Event a -> a -> IO a
-event (Append v) x = return $ add x v
-event (Remove v) x = return $ sub x v
-event Clear _ = return zero
-event (Modify p) x = return $ p x
-event (Action p) x = p x
-
-data Async a = Async {
-	asyncVar :: MVar a,
-	asyncEvents :: Chan (Event a) }
-
-newAsync :: (NFData a, Group a) => IO (Async a)
-newAsync = do
-	var <- newMVar zero
-	events <- newChan
-	_ <- forkIO $ do
-		evs <- getChanContents events
-		forM_ evs $ \e -> modifyMVar_ var $ \val -> do
-			x' <- event e val
-			force x' `seq` return x'
-	return $ Async var events
-
-readAsync :: Async a -> IO a
-readAsync = readMVar . asyncVar
-
-modifyAsync :: Async a -> Event a -> IO ()
-modifyAsync avar = writeChan (asyncEvents avar)

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

@@ -1,40 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}--module Data.Group (-	Group(..),-	groupSum-	) where--import Data.List ((\\))-import Data.Map (Map)-import qualified Data.Map as M-import Data.Set (Set)-import qualified Data.Set as S---- | Group is monoid with invertibility--- But for our purposes we prefer two functions: `add` and `sub`.-class Eq a => Group a where-	add :: a -> a -> a-	sub :: a -> a -> a-	zero :: a--instance Eq a => Group [a] where-	add = (++)-	sub = (\\)-	zero = []--instance Ord a => Group (Set a) where-	add = S.union-	sub = S.difference-	zero = S.empty--instance (Ord k, Group a) => Group (Map k a) where-	add = M.unionWith add-	sub = M.differenceWith sub' where-		sub' x y = if z == zero then Nothing else Just z where-			z = sub x y-	zero = M.empty---- | Sums list-groupSum :: Group a => [a] -> a-groupSum = foldr add zero

@@ -1,21 +1,24 @@-module Data.Help (-	Help(..),-	indent, indentHelp, detailed, indented-	) where--class Help a where-	brief :: a -> String-	help :: a -> [String]--indent :: String -> String-indent = ('\t':)--indentHelp :: [String] -> [String]-indentHelp [] = []-indentHelp (h:hs) = h : map indent hs--detailed :: Help a => a -> [String]-detailed v = brief v : help v--indented :: Help a => a -> [String]-indented = indentHelp . detailed+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

@@ -0,0 +1,46 @@+module Data.LookupTable (
+	LookupTable,
+	newLookupTable,
+	lookupTable, lookupTableM, cacheInTableM,
+	hasLookupTable,
+	cachedInTable
+	) 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)

@@ -1,16 +1,8 @@ module Data.Maybe.JustIf (
-	justIf, justWhen, soJust
+	justIf
 	) where
 
 -- | Return @Just@ if True
 justIf :: a -> Bool -> Maybe a
 x `justIf` True = Just x
 _ `justIf` False = Nothing
-
--- | Return @Just@ if @f x = True@
-justWhen :: a -> (a -> Bool) -> Maybe a
-x `justWhen` p = x `justIf` p x
-
--- | Flipped version of @justIf@
-soJust :: Bool -> a -> Maybe a
-soJust = flip justIf

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

@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HsDev.Cache (-	escapePath,-	versionCache,-	packageDbCache,-	projectCache,-	standaloneCache,-	dump,-	load,-	writeVersion,-	readVersion,--	-- * Reexports-	Database-	) where--import Control.DeepSeq (force)-import Control.Exception-import Control.Lens (view)-import Data.Aeson (encode, eitherDecode)-import Data.Aeson.Encode.Pretty (encodePretty)-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Char (isAlphaNum)-import Data.List (intercalate)-import System.FilePath--import HsDev.PackageDb-import HsDev.Project-import HsDev.Database (Database)-import HsDev.Util (version)---- | Escape path-escapePath :: FilePath -> FilePath-escapePath = intercalate "." . map (filter isAlphaNum) . splitDirectories---- | Name of cache for version-versionCache :: FilePath-versionCache = "version" <.> "json"---- | Name of cache for cabal-packageDbCache :: PackageDb -> FilePath-packageDbCache GlobalDb = "global" <.> "json"-packageDbCache UserDb = "user" <.> "json"-packageDbCache (PackageDb p) = escapePath p <.> "json"---- | Name of cache for projects-projectCache :: Project -> FilePath-projectCache p = (escapePath . view projectPath $ p) <.> "json"---- | Name of cache for standalone files-standaloneCache :: FilePath-standaloneCache = "standalone" <.> "json"---- | Dump database to file-dump :: FilePath -> Database -> IO ()-dump file = BS.writeFile file . encodePretty---- | Load database from file, strict-load :: FilePath -> IO (Either String Database)-load file = handle onIO $ do-	cts <- BS.readFile file-	return $ force $ eitherDecode cts-	where-		onIO :: IOException -> IO (Either String Database)-		onIO _ = return $ Left $ "IO exception while reading cache from " ++ file---- | Write version-writeVersion :: FilePath -> IO ()-writeVersion file = BS.writeFile file $ encode version---- | Read version-readVersion :: FilePath -> IO (Maybe [Int])-readVersion file = handle onIO $ do-	cts <- BS.readFile file-	return $ either (const Nothing) id $ eitherDecode cts-	where-		onIO :: IOException -> IO (Maybe [Int])-		onIO _ = return Nothing

@@ -1,72 +0,0 @@-module HsDev.Cache.Structured (-	dump, load,-	loadPackageDb, loadProject, loadFiles-	) where--import Control.DeepSeq-import Control.Exception-import Control.Lens (preview)-import Control.Monad.Except-import qualified Data.Map as M (assocs)-import System.Directory-import System.FilePath--import Data.Group (Group(zero))-import qualified HsDev.Cache as Cache-import HsDev.Database-import HsDev.Symbols hiding (loadProject)-import HsDev.Util---- | Write cache-dump :: FilePath -> Structured -> IO ()-dump dir db = do-	createDirectoryIfMissing True (dir </> "cabal")-	createDirectoryIfMissing True (dir </> "projects")-	forM_ (M.assocs $ structuredPackageDbs db) $ \(c, cdb) -> Cache.dump-		(dir </> "cabal" </> Cache.packageDbCache c)-		cdb-	forM_ (M.assocs $ structuredProjects db) $ \(p, pdb) -> Cache.dump-		(dir </> "projects" </> Cache.projectCache (project p))-		pdb-	files' <- either (const zero) id <$>-		handle wrapIO-		(Cache.load (dir </> Cache.standaloneCache))-	files' `deepseq` Cache.dump (dir </> Cache.standaloneCache) (files' `mappend` structuredFiles db)-	where-		wrapIO :: SomeException -> IO (Either String Database)-		wrapIO = return . Left . show---- | Load all cache-load :: FilePath -> IO (Either String Structured)-load dir = runExceptT $ join $ either throwError return <$> (structured <$> loadPackageDbs <*> loadProjects <*> loadStandaloneFiles) where-	loadPackageDbs = loadDir (dir </> "cabal")-	loadProjects = loadDir (dir </> "projects")-	loadStandaloneFiles = ExceptT $ Cache.load (dir </> Cache.standaloneCache)--	loadDir p = do-		fs <- liftE $ liftM (filter ((== ".json") . takeExtension)) $ directoryContents p-		mapM (ExceptT . Cache.load) fs---- | Load data from cache-loadData :: FilePath -> ExceptT String IO Database-loadData = liftExceptionM . ExceptT . Cache.load---- | Load cabal from cache-loadPackageDb :: PackageDb -> FilePath -> ExceptT String IO Structured-loadPackageDb c dir = do-	dat <- loadData (dir </> "cabal" </> Cache.packageDbCache c)-	ExceptT $ return $ structured [dat] [] mempty---- | Load project from cache-loadProject :: FilePath -> FilePath -> ExceptT String IO Structured-loadProject p dir = do-	dat <- loadData (dir </> "projects" </> Cache.projectCache (project p))-	ExceptT $ return $ structured [] [dat] mempty---- | Load standalone files-loadFiles :: (FilePath -> Bool) -> FilePath -> ExceptT String IO Structured-loadFiles f dir = do-	dat <- loadData (dir </> Cache.standaloneCache)-	ExceptT $ return $ structured [] [] $ filterDB f' (const False) dat-	where-		f' = maybe False f . preview (moduleIdLocation . moduleFile)

@@ -1,414 +1,622 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}--module HsDev.Client.Commands (-	runClient, runCommand-	) where--import Control.Applicative-import Control.Concurrent.MVar-import Control.Exception (displayException)-import Control.Lens (view, preview, _Just, (^..), each)-import Control.Monad-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.Foldable (toList)-import Data.Maybe-import qualified Data.Map as M-import Data.String (fromString)-import Data.Text (pack, unpack)-import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf)-import System.Directory-import System.FilePath-import qualified System.Log.Simple as Log-import qualified System.Log.Simple.Base as Log-import Text.Regex.PCRE ((=~))--import qualified System.Directory.Watcher as W-import qualified Data.Async as A-import System.Directory.Paths-import Text.Format-import HsDev.Cache-import HsDev.Commands-import HsDev.Error-import qualified HsDev.Database.Async as DB-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 HsDev.Symbols.Resolve (resolveOne, scopeModule, exportsModule)-import HsDev.Symbols.Util-import qualified HsDev.Tools.AutoFix as AutoFix-import qualified HsDev.Tools.Cabal as Cabal-import HsDev.Tools.Ghc.Session-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.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 (either Error (Result . toJSON)) $ runReaderT (try act) copts-	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b-	mapServerM f = ServerM . mapReaderT f . runServerM--toValue :: (ToJSON a, Monad m) => m a -> m Value-toValue = liftM toJSON--runCommand :: ServerMonadBase m => Command -> ClientM m Value-runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]-runCommand (Listen (Just l)) = case Log.level (pack l) of-	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l-	Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)-runCommand (Listen Nothing) = toValue $ do-	serverListen >>= mapM_ (\msg -> commandNotify (Notification $ object ["message" .= msg]))-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 (AddData cts) = toValue $ mapM_ updateData cts where-	updateData (AddedDatabase db) = toValue $ serverUpdateDB db-	updateData (AddedModule m) = toValue $ serverUpdateDB $ fromModule m-	updateData (AddedProject p) = toValue $ serverUpdateDB $ fromProject p-runCommand (Scan projs cabal sboxes fs paths' ghcs' docs' infer') = toValue $ do-	sboxes' <- getSandboxes sboxes-	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [-		map (\(FileSource f mcts) -> Update.scanFileContents ghcs' f mcts) fs,-		map (Update.scanProject ghcs') projs,-		map (Update.scanDirectory ghcs') paths',-		[Update.scanCabal ghcs' | cabal],-		map (Update.scanSandbox ghcs') sboxes']-runCommand (RefineDocs projs fs ms) = toValue $ do-	projects <- traverse findProject projs-	dbval <- getDb-	let-		filters = anyOf $ concat [-			map inProject projects,-			map inFile fs,-			map inModule ms]-		mods = selectModules (filters . view moduleId) dbval-	updateProcess (Update.UpdateOptions [] [] False False) [Update.scanDocs $ map (getInspected dbval) mods]-runCommand (InferTypes projs fs ms) = toValue $ do-	projects <- traverse findProject projs-	dbval <- getDb-	let-		filters = anyOf $ concat [-			map inProject projects,-			map inFile fs,-			map inModule ms]-		mods = selectModules (filters . view moduleId) dbval-	updateProcess (Update.UpdateOptions [] [] False False) [Update.inferModTypes $ map (getInspected dbval) mods]-runCommand (Remove projs cabal sboxes files) = toValue $ do-	db <- askSession sessionDatabase-	dbval <- getDb-	w <- askSession sessionWatcher-	projects <- traverse findProject projs-	sboxes' <- getSandboxes sboxes-	forM_ projects $ \proj -> do-		DB.clear db (return $ projectDB proj dbval)-		liftIO $ unwatchProject w proj-	dbPDbs <- mapM restorePackageDbStack $ databasePackageDbs dbval-	flip State.evalStateT dbPDbs $ do-		when cabal $ removePackageDbStack userDb-		forM_ sboxes' $ \sbox -> do-			pdbs <- lift $ sandboxPackageDbStack sbox-			removePackageDbStack pdbs-	forM_ files $ \file -> do-		DB.clear db (return $ filterDB (inFile file) (const False) dbval)-		let-			mloc = fmap (view moduleLocation) $ lookupFile file dbval-		maybe (return ()) (liftIO . unwatchModule w) mloc-	where-		-- 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-			db <- lift $ askSession sessionDatabase-			dbval <- lift getDb-			w <- lift $ askSession sessionWatcher-			can <- canRemove pdbs-			when can $ do-				State.modify (delete pdbs)-				DB.clear db (return $ packageDbDB (topPackageDb pdbs) dbval)-				liftIO $ unwatchPackageDb w $ topPackageDb pdbs-		-- Remove package-db stack when possible-		removePackageDbStack = mapM_ removePackageDb . packageDbStacks-runCommand RemoveAll = toValue $ do-	db <- askSession sessionDatabase-	liftIO $ A.modifyAsync db A.Clear-	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 (InfoModules fs) = toValue $ do-	dbval <- getDb-	filter' <- targetFilters fs-	return $ map (view moduleId) $ newestPackage $ selectModules (filter' . view moduleId) dbval-runCommand InfoPackages = toValue $ (ordNub . sort . 	mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules) <$> getDb-runCommand InfoProjects = toValue $ (toList . databaseProjects) <$> getDb-runCommand InfoSandboxes = toValue $ databasePackageDbs <$> getDb-runCommand (InfoSymbol sq fs locals') = toValue $ do-	dbval <- liftM (localsDatabase locals') $ getDb-	filter' <- targetFilters fs-	return $ newestPackage $ filterMatch sq $-		concatMap moduleModuleDeclarations $ filter (filter' . view moduleId) $ allModules dbval-runCommand (InfoModule sq fs) = toValue $ do-	dbval <- getDb-	filter' <- targetFilters fs-	return $ newestPackage $ filterMatch sq $ filter (filter' . view moduleId) $ allModules dbval-runCommand (InfoResolve fpath exports) = toValue $ do-	dbval <- getSDb fpath-	let-		getScope-			| exports = exportsModule-			| otherwise = scopeModule-	m <- refineSourceModule fpath-	return $ getScope $ resolveOne dbval m-runCommand (InfoProject (Left projName)) = toValue $ findProject projName-runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject projPath-runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandbox sandbox'-runCommand (Lookup nm fpath) = toValue $ do-	dbval <- getSDb fpath-	liftIO $ hsdevLift $ lookupSymbol dbval fpath nm-runCommand (Whois nm fpath) = toValue $ do-	dbval <- getSDb fpath-	liftIO $ hsdevLift $ whois dbval fpath nm-runCommand (ResolveScopeModules sq fpath) = toValue $ do-	dbval <- getSDb fpath-	liftM (filterMatch sq . map (view moduleId)) $ liftIO $ hsdevLift $ scopeModules dbval fpath-runCommand (ResolveScope sq global fpath) = toValue $ do-	dbval <- getSDb fpath-	liftM (filterMatch sq) $ liftIO $ hsdevLift $ scope dbval fpath global-runCommand (Complete input wide fpath) = toValue $ do-	dbval <- getSDb fpath-	liftIO $ hsdevLift $ completions dbval fpath input wide-runCommand (Hayoo hq p ps) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM-	(mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $-	liftIO $ hsdevLift $ Hayoo.hayoo hq (Just i)-runCommand (CabalList packages) = toValue $ liftIO $ hsdevLift $ Cabal.cabalList packages-runCommand (Lint fs) = toValue $ do-	liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs-runCommand (Check fs ghcs') = toValue $ Log.scope "check" $ do-	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs-	let-		checkSome file fn = Log.scope "checkSome" $ do-			m <- setFileSourceSession ghcs' file-			inSessionGhc $ fn m-	liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs-runCommand (CheckLint fs ghcs') = toValue $ do-	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs-	let-		checkSome file fn = Log.scope "checkSome" $ do-			m <- setFileSourceSession ghcs' file-			inSessionGhc $ fn m-	checkMsgs <- liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs-	lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs-	return $ checkMsgs ++ lintMsgs-runCommand (Types fs ghcs') = toValue $ do-	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs-	liftM concat $ forM fs $ \(FileSource file msrc) -> do-		m <- setFileSourceSession ghcs' file-		inSessionGhc $ Types.fileTypes ghcs' m msrc-runCommand (AutoFix (AutoFixShow ns)) = toValue $ return $ AutoFix.corrections ns-runCommand (AutoFix (AutoFixFix ns rest isPure)) = toValue $ do-	files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns-	let-		doFix :: FilePath -> Maybe String -> ([Tools.Note AutoFix.Correction], Maybe String)-		doFix file mcts = AutoFix.autoFix fCorrs (fUpCorrs, mcts) where-			findCorrs :: FilePath -> [Tools.Note AutoFix.Correction] -> [Tools.Note AutoFix.Correction]-			findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))-			fCorrs = findCorrs file ns-			fUpCorrs = findCorrs file rest-		runFix file-			| isPure = return $ fst $ doFix file Nothing-			| otherwise = do-				(corrs', Just cts') <- liftM (doFix file) $ liftIO $ Just <$> readFileUtf8 file-				liftIO $ writeFileUtf8 file cts'-				return corrs'-	liftM concat $ mapM runFix files-runCommand (GhcEval exprs mfile) = toValue $ do-	-- ensureUpToDate (Update.UpdateOptions [] [] False False) (maybeToList mfile)-	ghcw <- askSession sessionGhc-	case mfile of-		Nothing -> inSessionGhc ghciSession-		Just (FileSource f mcts) -> do-			m <- setFileSourceSession [] f-			inSessionGhc $ interpretModule m mcts-	async' <- liftIO $ pushTask ghcw $ do-		mapM (try . evaluate) exprs-	res <- waitAsync async'-	return $ map toValue' res-	where-		waitAsync :: CommandMonad m => Async a -> m a-		waitAsync a = liftIO (waitCatch a) >>= either (hsdevError . GhcError . displayException) return-		toValue' :: ToJSON a => Either SomeException a -> Value-		toValue' (Left (SomeException e)) = object ["fail" .= show e]-		toValue' (Right s) = toJSON s-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 Exit = toValue serverExit--targetFilters :: CommandMonad m => [TargetFilter] -> m (ModuleId -> Bool)-targetFilters fs = do-	fs_ <- mapM targetFilter fs-	return $ foldr (liftM2 (&&)) (const True) fs_--targetFilter :: CommandMonad m => TargetFilter -> m (ModuleId -> Bool)-targetFilter f = case f of-	TargetProject proj -> liftM inProject $ findProject proj-	TargetFile file -> liftM inFile $ refineSourceFile file-	TargetModule mname -> return $ inModule mname-	TargetDepsOf dep -> liftM inDeps $ findDep dep-	TargetPackageDb pdb -> return $ inPackageDb pdb-	TargetCabal -> return $ inPackageDbStack userDb-	TargetSandbox sbox -> liftM inPackageDbStack $ findSandbox sbox >>= sandboxPackageDbStack-	TargetPackage pkg -> liftM inPackage $ refinePackage pkg-	TargetSourced -> return byFile-	TargetStandalone -> return standalone---- 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 => FilePath -> m Sandbox-findSandbox fpath = do-	fpath' <- findPath fpath-	sbox <- liftIO $ S.findSandbox fpath'-	maybe (hsdevError $ FileNotFound fpath') return sbox---- | Get source file-refineSourceFile :: CommandMonad m => FilePath -> m FilePath-refineSourceFile fpath = do-	fpath' <- findPath fpath-	db' <- getDb-	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ do-		m' <- lookupFile fpath' db'-		preview (moduleLocation . moduleFile) m'---- | Get module by source-refineSourceModule :: CommandMonad m => FilePath -> m Module-refineSourceModule fpath = do-	fpath' <- findPath fpath-	db' <- getDb-	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ lookupFile fpath' db'---- | Set session by source-setFileSourceSession :: CommandMonad m => [String] -> FilePath -> m Module-setFileSourceSession opts fpath = do-	m <- refineSourceModule fpath-	inSessionGhc $ targetSession opts m-	return m---- | Ensure package exists-refinePackage :: CommandMonad m => String -> m String-refinePackage pkg = do-	db' <- getDb-	if pkg `elem` (allPackages db' ^.. each . packageName)-		then return pkg-		else hsdevError (PackageNotFound pkg)---- | Get list of enumerated sandboxes-getSandboxes :: CommandMonad m => [FilePath] -> m [Sandbox]-getSandboxes = traverse (findPath >=> findSandbox)---- | Find project by name or path-findProject :: CommandMonad m => String -> m Project-findProject proj = do-	db' <- getDb-	proj' <- liftM addCabal $ findPath proj-	let-		resultProj =-			refineProject db' (project proj') <|>-			find ((== proj) . view projectName) (databaseProjects db')-	maybe (hsdevError $ ProjectNotFound proj) return resultProj-	where-		addCabal p-			| takeExtension p == ".cabal" = p-			| otherwise = p </> (takeBaseName p <.> "cabal")---- | Find dependency: it may be source, project file or project name, also returns sandbox found-findDep :: CommandMonad m => String -> m (Project, Maybe FilePath, PackageDbStack)-findDep depName = do-	depPath <- findPath depName-	proj <- msum [-		do-			p <- liftIO (locateProject depPath)-			p' <- maybe (hsdevError $ ProjectNotFound depName) return p-			liftIO $ loadProject p',-		findProject depName]-	let-		src-			| takeExtension depPath == ".hs" = Just depPath-			| otherwise = Nothing-	pdbs <- searchPackageDbStack $ view projectPath proj-	return (proj, src, pdbs)---- FIXME: Doesn't work for file without project--- | Check if project or source depends from this module-inDeps :: (Project, Maybe FilePath, PackageDbStack) -> ModuleId -> Bool-inDeps (proj, src, pdbs) = liftM2 (&&) (restrictPackageDbStack pdbs) deps' where-	deps' = case src of-		Nothing -> inDepsOfProject proj-		Just src' -> inDepsOfFile proj src'---- | Bring locals to top scope to search within them if 'locals' flag set-localsDatabase :: Bool -> Database -> Database-localsDatabase True = databaseLocals-localsDatabase False = id---- | Get actual DB state-getDb :: SessionMonad m => m Database-getDb = askSession sessionDatabase >>= liftIO . DB.readAsync---- | Get DB with filtered sanxboxes for file-getSDb :: SessionMonad m => FilePath -> m Database-getSDb fpath = do-	dbval <- getDb-	pdbs <- searchPackageDbStack fpath-	return $ filterDB (restrictPackageDbStack pdbs) (const True) dbval---- | Run DB update action-updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM m ()] -> ClientM m ()-updateProcess uopts acts = Update.runUpdate uopts $ mapM_ runAct acts where-	runAct act = catch act onError-	onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError)---- | Ensure file is up to date--- ensureUpToDate :: ServerMonadBase m => Update.UpdateOptions -> [FileSource] -> ClientM m ()--- ensureUpToDate uopts fs = updateProcess uopts [Update.scanFileContents (view Update.updateGhcOpts uopts) f mcts | FileSource f mcts <- fs]---- | Filter declarations with prefix and infix-filterMatch :: Symbol a => SearchQuery -> [a] -> [a]-filterMatch (SearchQuery q st) = filter match' where-	match' m = case st of-		SearchExact -> fromString q == symbolName m-		SearchPrefix -> fromString q `T.isPrefixOf` symbolName m-		SearchInfix -> fromString q `T.isInfixOf` symbolName m-		SearchSuffix -> fromString q `T.isSuffixOf` symbolName m-		SearchRegex -> unpack (symbolName m) =~ q+{-# 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)
+import System.Directory
+import System.FilePath
+import qualified System.Log.Simple as Log
+import qualified System.Log.Simple.Base as Log
+import Text.Read (readMaybe)
+
+import qualified System.Directory.Watcher as W
+import System.Directory.Paths
+import Text.Format
+import HsDev.Error
+import HsDev.Database.SQLite as SQLite
+import HsDev.Inspect (preload, asModule)
+import HsDev.Scan (upToDate, getFileContents)
+import HsDev.Server.Message as M
+import HsDev.Server.Types
+import HsDev.Sandbox hiding (findSandbox)
+import qualified HsDev.Sandbox as S (findSandbox)
+import HsDev.Symbols
+import qualified HsDev.Tools.AutoFix as AutoFix
+import qualified HsDev.Tools.Cabal as Cabal
+import HsDev.Tools.Ghc.Session
+import HsDev.Tools.Ghc.Worker (clearTargets)
+import qualified HsDev.Tools.Ghc.Compat as Compat
+import qualified HsDev.Tools.Ghc.Check as Check
+import qualified HsDev.Tools.Ghc.Types as Types
+import qualified HsDev.Tools.Hayoo as Hayoo
+import qualified HsDev.Tools.HDocs as HDocs
+import qualified HsDev.Tools.HLint as HLint
+import qualified HsDev.Tools.Types as Tools
+import HsDev.Util
+import HsDev.Watcher
+
+import qualified HsDev.Database.Update as Update
+
+runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result
+runClient copts = mapServerM toResult . runClientM where
+	toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result
+	toResult act = liftM errorToResult $ runReaderT (try (try act)) copts
+	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b
+	mapServerM f = ServerM . mapReaderT f . runServerM
+	errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result
+	errorToResult = either (Error . UnhandledError . displayException) (either Error (Result . toJSON))
+
+toValue :: (ToJSON a, Monad m) => m a -> m Value
+toValue = liftM toJSON
+
+runCommand :: ServerMonadBase m => Command -> ClientM m Value
+runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]
+runCommand (Listen (Just l)) = case Log.level (pack l) of
+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
+	Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)
+runCommand (Listen Nothing) = toValue $ do
+	serverListen >>= mapM_ (commandNotify . Notification . toJSON)
+runCommand (SetLogLevel l) = case Log.level (pack l) of
+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
+	Just lev -> toValue $ do
+		lev' <- serverSetLogLevel lev
+		Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev
+		Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev
+runCommand (Scan projs cabal sboxes fs paths' ghcs' docs' infer') = toValue $ do
+	sboxes' <- getSandboxes sboxes
+	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
+		[Update.scanCabal ghcs' | cabal],
+		map (Update.scanSandbox ghcs') sboxes',
+		[Update.scanFiles (zip fs (repeat ghcs'))],
+		map (Update.scanProject ghcs') projs,
+		map (Update.scanDirectory ghcs') paths']
+runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts
+runCommand (RefineDocs projs fs)
+	| HDocs.hdocsSupported = toValue $ do
+		projects <- traverse findProject projs
+		mods <- do
+			projMods <- liftM concat $ forM projects $ \proj -> do
+				ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.docs') is null"
+					(Only $ proj ^. projectCabal)
+				p <- SQLite.loadProject (proj ^. projectCabal)
+				return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms
+			fileMods <- liftM concat $ forM fs $ \f ->
+				loadModules "select id from modules where file == ? and json_extract(tags, '$.docs') is null"
+					(Only f)
+			return $ projMods ++ fileMods
+		updateProcess def [Update.scanDocs mods]
+	| otherwise = hsdevError $ OtherError "docs not supported"
+runCommand (InferTypes projs fs) = toValue $ do
+	projects <- traverse findProject projs
+	mods <- do
+		projMods <- liftM concat $ forM projects $ \proj -> do
+			ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.types') is null"
+				(Only $ proj ^. projectCabal)
+			p <- SQLite.loadProject (proj ^. projectCabal)
+			return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms
+		fileMods <- liftM concat $ forM fs $ \f ->
+			loadModules "select id from modules where file == ? and json_extract(tags, '$.types') is null"
+				(Only f)
+		return $ projMods ++ fileMods
+	updateProcess def [Update.inferModTypes mods]
+runCommand (Remove projs cabal sboxes files) = toValue $ withSqlConnection $ SQLite.transaction_ SQLite.Immediate $ do
+	let
+		-- We can safely remove package-db from db iff doesn't used by some of other package-dbs
+		-- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db
+		-- We also can't remove stack snapshot package-db if there are some local package-db not yet removed
+		canRemove pdbs = do
+			from' <- State.get
+			return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from'
+		-- Remove top of package-db stack if possible
+		removePackageDb' pdbs = do
+			w <- lift $ askSession sessionWatcher
+			can <- canRemove pdbs
+			when can $ do
+				State.modify (delete pdbs)
+				ms <- liftM (map fromOnly) $ query_
+					"select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;"
+				removePackageDb (topPackageDb pdbs)
+				mapM_ SQLite.removeModule ms
+				liftIO $ unwatchPackageDb w $ topPackageDb pdbs
+		-- Remove package-db stack when possible
+		removePackageDbStack = mapM_ removePackageDb' . packageDbStacks
+	w <- askSession sessionWatcher
+	projects <- traverse findProject projs
+	sboxes' <- getSandboxes sboxes
+	forM_ projects $ \proj -> do
+		ms <- liftM (map fromOnly) $ query "select id from modules where cabal == ?;" (Only $ proj ^. projectCabal)
+		SQLite.removeProject proj
+		mapM_ SQLite.removeModule ms
+		liftIO $ unwatchProject w proj
+
+	allPdbs <- liftM (map fromOnly) $ query_ @(Only PackageDb) "select package_db from package_dbs;"
+	dbPDbs <- inSessionGhc $ mapM restorePackageDbStack allPdbs
+	flip State.evalStateT dbPDbs $ do
+		when cabal $ removePackageDbStack userDb
+		forM_ sboxes' $ \sbox -> do
+			pdbs <- lift $ inSessionGhc $ sandboxPackageDbStack sbox
+			removePackageDbStack pdbs
+
+	forM_ files $ \file -> do
+		ms <- query @_ @(ModuleId :. Only Int) (toQuery $ qModuleId `mappend` select_ ["mu.id"] [] ["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 Int :. Project) "select p.id, p.name, p.cabal, p.version from projects as p;"
+	forM ps $ \(Only pid :. proj) -> do
+		libs <- query @_ @Library "select l.modules, b.depends, b.language, b.extensions, b.ghc_options, b.source_dirs, b.other_modules from libraries as l, build_infos as b where (l.project_id == ?) and (l.build_info_id == b.id);"
+			(Only pid)
+		exes <- query @_ @Executable "select e.name, e.path, b.depends, b.language, b.extensions, b.ghc_options, b.source_dirs, b.other_modules from executables as e, build_infos as b where (e.project_id == ?) and (e.build_info_id == b.id);"
+			(Only pid)
+		tsts <- query @_ @Test "select t.name, t.enabled, t.main, b.depends, b.language, b.extensions, b.ghc_options, b.source_dirs, b.other_modules from tests as t, build_infos as b where (t.project_id == ?) and (t.build_info_id == b.id);"
+			(Only pid)
+		return $
+			set (projectDescription . _Just . projectLibrary) (listToMaybe libs) .
+			set (projectDescription . _Just . projectExecutables) exes .
+			set (projectDescription . _Just . projectTests) tsts $
+			proj
+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
+	rs <- queryNamed @SymbolId (toQuery $ qSymbolId `mappend` where_ ["s.name like :pattern escape '\\'"] `mappend` where_ conds)
+		([":pattern" := likePattern sq] ++ params)
+	return rs
+runCommand (InfoSymbol sq filters False _) = toValue $ do
+	let
+		(conds, params) = targetFilters "m" (Just "s") filters
+	queryNamed @Symbol (toQuery $ qSymbol `mappend` where_ ["s.name like :pattern escape '\\'"] `mappend` 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 $ select_ ["mu.id"] [] [] `mappend` qModuleId `mappend` where_ ["mu.name like :pattern escape '\\'"] `mappend` 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')
+			exports' <- query @_ @Symbol (toQuery $ qSymbol `mappend` select_ []
+				["exports as e"]
+				["e.module_id == ?", "e.symbol_id == s.id"])
+				(Only mid)
+			return $ Module mheader docs mempty 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 $
+	query @_ @Symbol (toQuery $ qSymbol `mappend` select_ []
+		["projects_modules_scope as pms", "modules as srcm", "exports as e"]
+		[
+			"pms.cabal is srcm.cabal",
+			"srcm.file == ?",
+			"pms.module_id == e.module_id",
+			"m.id == s.module_id",
+			"s.id == e.symbol_id",
+			"s.name == ?"])
+		(fpath ^. path, nm)
+runCommand (Whois nm fpath) = toValue $ do
+	let
+		q = nameModule $ toName nm
+		ident = nameIdent $ toName nm
+	query @_ @Symbol (toQuery $ qSymbol `mappend` select_ []
+		["modules as srcm", "scopes as sc"]
+		[
+			"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 $ qSymbol `mappend` select_ []
+		["names as n", "modules as srcm"]
+		[
+			"srcm.id == n.module_id",
+			"m.name == n.resolved_module",
+			"s.name == n.resolved_name",
+			"m.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)))",
+			"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 $ qModuleId `mappend` select_
+			["n.name", "n.def_line", "n.def_column", "n.inferred_type"]
+			["names as n"]
+			[
+				"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 $ qModuleId `mappend` select_ []
+			["projects_modules_scope as msc"]
+			[
+				"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 $ do
+	rs <- query @_ @(SymbolId :. Only (Maybe Text)) (toQuery $ qSymbolId `mappend` select_ ["sc.qualifier"]
+		["scopes as sc", "modules as srcm"]
+		[
+			"srcm.id == sc.module_id",
+			"sc.symbol_id == s.id",
+			"srcm.file == ?",
+			"s.name like ? escape '\\'"])
+		(fpath ^. path, likePattern sq)
+	return [ScopeSymbol q s | (s :. Only q) <- rs]
+runCommand (FindUsages nm) = toValue $ do
+	let
+		q = nameModule $ toName nm
+		ident = nameIdent $ toName nm
+	query @_ @SymbolUsage (toQuery $ qSymbol `mappend` qModuleId `mappend` select_
+		["n.line", "n.column"]
+		["names as n"]
+		[
+			"m.name == n.resolved_module",
+			"s.name == n.resolved_name",
+			"mu.id == n.module_id",
+			"n.resolved_module == ? or ? is null",
+			"n.resolved_name == ?"])
+		(q, q, ident)
+runCommand (Complete input True fpath) = toValue $
+	query @_ @Symbol (toQuery $ qSymbol `mappend` select_ []
+		["modules as srcm"]
+		[
+			"m.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)))",
+			"msrc.file == ?",
+			"s.name like ? escape '\\'"])
+		(fpath ^. path, likePattern (SearchQuery input SearchPrefix))
+runCommand (Complete input False fpath) = toValue $
+	query @_ @Symbol (toQuery $ qSymbol `mappend` select_ []
+		["completions as c", "modules as srcm"]
+		[
+			"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) = toValue $ liftM concat $ forM fs $ \fsrc -> do
+	FileSource f c <- actualFileContents fsrc
+	liftIO $ hsdevLift $ HLint.hlint (view path f) c
+runCommand (Check fs ghcs' clear) = toValue $ Log.scope "check" $ do
+	let
+		checkSome file fn = Log.scope "checkSome" $ do
+			Log.sendLog Log.Trace $ "setting file source session for {}" ~~ file
+			m <- setFileSourceSession ghcs' file
+			Log.sendLog Log.Trace $ "file source session set"
+			inSessionGhc $ do
+				when clear $ clearTargets
+				fn m
+	fs' <- mapM actualFileContents fs
+	liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check m c)) fs'
+runCommand (CheckLint fs ghcs' clear) = toValue $ do
+	let
+		checkSome file fn = Log.scope "checkSome" $ do
+			Log.sendLog Log.Trace $ "setting file source session for {}" ~~ file
+			m <- setFileSourceSession ghcs' file
+			Log.sendLog Log.Trace $ "file source session set"
+			inSessionGhc $ do
+				when clear $ clearTargets
+				fn m
+	fs' <- mapM actualFileContents fs
+	checkMsgs <- liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check m c)) fs'
+	lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint (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 $ select_ ["json_extract(tags, '$.types') is 1", "mu.id"] [] [] `mappend` qModuleId `mappend` 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
+			m <- setFileSourceSession ghcs' file
+			types' <- inSessionGhc $ do
+				when clear $ clearTargets
+				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
+			when (not 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
+	ghcw <- askSession sessionGhc
+	mfile' <- traverse actualFileContents mfile
+	case mfile' of
+		Nothing -> inSessionGhc ghciSession
+		Just (FileSource f mcts) -> do
+			m <- setFileSourceSession [] f
+			inSessionGhc $ interpretModule m mcts
+	async' <- liftIO $ sendTask ghcw $ do
+		mapM (try . evaluate) exprs
+	res <- waitAsync async'
+	return $ map toValue' res
+	where
+		waitAsync :: CommandMonad m => Async a -> m a
+		waitAsync a = liftIO (waitCatch a) >>= either (hsdevError . GhcError . displayException) return
+		toValue' :: ToJSON a => Either SomeException a -> Value
+		toValue' (Left (SomeException e)) = object ["fail" .= show e]
+		toValue' (Right s) = toJSON s
+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: {}" ~~ s
+			deleteSession s
+runCommand Exit = toValue serverExit
+
+-- TODO: Implement `targetFilter` for sql
+
+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 nm) = ("{t}.package_name == :package_name" ~~ ("t" ~% mtable), [":package_name" := nm])
+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")
+
+-- 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
+							p' <- liftIO $ preload (m ^. moduleId . moduleName) defs [] (m ^. moduleId . moduleLocation) Nothing
+							return $ set moduleImports (p' ^. asModule . moduleImports) 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 (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)

@@ -1,193 +0,0 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}--module HsDev.Commands (-	-- * Commands-	findDeclaration, findModule,-	fileModule,-	lookupSymbol,-	whois,-	scopeModules, scope,-	completions,-	moduleCompletions,--	-- * Filters-	checkModule, checkDeclaration, restrictPackageDb, restrictPackageDbStack, visibleFrom,-	splitIdentifier,--	-- * Helpers-	fileCtx, fileCtxMaybe,--	-- * Reexports-	module HsDev.Database,-	module HsDev.Symbols.Types,-	module Control.Monad.Except-	) where--import Control.Applicative-import Control.Lens (view, set, each, toListOf)-import Control.Monad.Except-import Data.List (delete)-import Data.Maybe-import Data.String (fromString)-import qualified Data.Text as T (isPrefixOf, split, unpack)-import System.Directory (canonicalizePath)--import System.Directory.Paths--import HsDev.Database-import HsDev.Project-import HsDev.Symbols-import HsDev.Symbols.Resolve-import HsDev.Symbols.Types-import HsDev.Symbols.Util-import HsDev.Tools.Base (matchRx, at_)-import HsDev.Util (liftE, ordNub)---- | Find declaration by name-findDeclaration :: Database -> String -> ExceptT String IO [ModuleDeclaration]-findDeclaration db ident = return $ selectDeclarations checkName db where-	checkName :: ModuleDeclaration -> Bool-	checkName m =-		(view (moduleDeclaration . declarationName) m == fromString iname) &&-		(maybe True ((view (declarationModuleId . moduleIdName) m ==) . fromString) qname)--	(qname, iname) = splitIdentifier ident---- | Find module by name-findModule :: Database -> String -> ExceptT String IO [Module]-findModule db mname = return $ selectModules ((== fromString mname) . view moduleName) db---- | Find module in file-fileModule :: Database -> FilePath -> ExceptT String IO Module-fileModule db src = do-	src' <- liftE $ canonicalizePath src-	maybe (throwError $ "File '" ++ src' ++ "' not found") return $ lookupFile src' db---- | Find project of module-getProject :: Database -> Project -> ExceptT String IO Project-getProject db p = do-	p' <- liftE $ canonicalize p-	maybe (throwError $ "Project " ++ view projectCabal p' ++ " not found") return $-		refineProject db p'---- | Lookup visible within project/cabal symbol-lookupSymbol :: Database -> FilePath -> String -> ExceptT String IO [ModuleDeclaration]-lookupSymbol db file ident = do-	(_, mthis, mproj) <- fileCtx db file-	liftM-		(filter $ checkModule $ allOf [-			visibleFrom mproj mthis,-			maybe (const True) inModule qname])-		(newestPackage <$> findDeclaration db iname)-	where-		(qname, iname) = splitIdentifier ident---- | Whois symbol in scope-whois :: Database -> FilePath -> String -> ExceptT String IO [Declaration]-whois db file ident = do-	(_, mthis, mproj) <- fileCtx db file-	return $-		newestPackage $ filter checkDecl $-		view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) $-		moduleLocals mthis-	where-		(qname, iname) = splitIdentifier ident-		checkDecl d = fmap fromString qname `elem` scopes d && view declarationName d == fromString iname---- | Accessible modules-scopeModules :: Database -> FilePath -> ExceptT String IO [Module]-scopeModules db file = do-	(file', mthis, mproj) <- fileCtxMaybe db file-	newestPackage <$> case mproj of-		Nothing -> return $ maybe id (:) mthis $ selectModules (installed . view moduleId) db-		Just proj -> let deps' = deps file' proj in-			return $ concatMap (\p -> selectModules (p . view moduleId) db) [-				inProject proj,-				\m -> any (`inPackage` m) deps']-	where-		deps f p = delete (view projectName p) $ concatMap (view infoDepends) $ fileTargets p f---- | Symbols in scope-scope :: Database -> FilePath -> Bool -> ExceptT String IO [Declaration]-scope db file False = do-	(_, mthis, mproj) <- fileCtx db file-	return $ view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) mthis-scope db file True = concatMap (view moduleDeclarations) <$> scopeModules db file---- | Completions-completions :: Database -> FilePath -> String -> Bool -> ExceptT String IO [Declaration]-completions db file prefix wide = do-	(_, mthis, mproj) <- fileCtx db file-	return $-		toListOf (each . minimalDecl) $ newestPackage $ filter checkDecl $-		view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) $-		dropImportLists mthis-	where-		(qname, iname) = splitIdentifier prefix-		checkDecl d = fmap fromString qname `elem` scopes d && fromString iname `T.isPrefixOf` view declarationName d-		dropImportLists m-			| wide = set (moduleImports . each . importList) Nothing m-			| otherwise = m---- | Module completions-moduleCompletions :: Database -> [Module] -> String -> ExceptT String IO [String]-moduleCompletions _ ms prefix = return $ map T.unpack $ ordNub $ completions' $ map (view moduleName) ms where-	completions' = mapMaybe getNext where-		getNext m-			| fromString prefix `T.isPrefixOf` m = listToMaybe $ map snd $ dropWhile (uncurry (==)) $ zip (T.split (== '.') $ fromString prefix) (T.split (== '.') m)-			| otherwise = Nothing---- | Check module-checkModule :: (ModuleId -> Bool) -> (ModuleDeclaration -> Bool)-checkModule = (. view declarationModuleId)---- | Check declaration-checkDeclaration :: (Declaration -> Bool) -> (ModuleDeclaration -> Bool)-checkDeclaration = (. view moduleDeclaration)---- | Allow only selected cabal sandbox-restrictPackageDb :: PackageDb -> ModuleId -> Bool-restrictPackageDb pdb m = inPackageDb pdb m || not (installed m)---- | Allow only selected cabal sandboxes-restrictPackageDbStack :: PackageDbStack -> ModuleId -> Bool-restrictPackageDbStack pdbs m = any (`inPackageDb` m) (packageDbs pdbs) || not (installed m)---- | Check whether module is visible from source file-visibleFrom :: Maybe Project -> Module -> ModuleId -> Bool-visibleFrom (Just p) this m = visible p (view moduleId this) m-visibleFrom Nothing this m = view moduleId this == m || installed m---- | Split identifier into module name and identifier itself-splitIdentifier :: String -> (Maybe String, String)-splitIdentifier name = fromMaybe (Nothing, name) $ do-	groups <- matchRx "(([A-Z][\\w']*\\.)*)(.*)" name-	return (dropDot <$> groups 1, groups `at_` 3)-	where-		dropDot :: String -> String-		dropDot "" = ""-		dropDot s = init s---- | Get context file and project-fileCtx :: Database -> FilePath -> ExceptT String IO (FilePath, Module, Maybe Project)-fileCtx db file = do-	file' <- liftE $ canonicalizePath file-	mthis <- fileModule db file'-	mproj <- traverse (getProject db) $ projectOf $ view moduleId mthis-	return (file', mthis, mproj)---- | Try get context file-fileCtxMaybe :: Database -> FilePath -> ExceptT String IO (FilePath, Maybe Module, Maybe Project)-fileCtxMaybe db file = ((\(f, m, p) -> (f, Just m, p)) <$> fileCtx db file) <|> onlyProj where-	onlyProj = do-		file' <- liftE $ canonicalizePath file-		mproj <- liftE $ locateProject file'-		mproj' <- traverse (getProject db) mproj-		return (file', Nothing, mproj')---- | Restrict only modules file depends on-fileDeps :: FilePath -> Maybe Project -> Database -> Database-fileDeps file mproj = filterDB fileDeps' (const True) where-	fileDeps' = liftM2 (||)-		(maybe (const True) inProject mproj)-		(\m -> any (`inDepsOfTarget` m) (fromMaybe [] $ fileTargets <$> mproj <*> pure file))

@@ -1,253 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HsDev.Database (-	Database(..),-	databaseIntersection, nullDatabase, databaseLocals, databasePackageDbs, allModules, allDeclarations, allPackages,-	fromModule, fromProject,-	filterDB,-	projectDB, packageDbDB, packageDbStackDB, standaloneDB,-	selectModules, selectDeclarations, lookupModule, lookupInspected, lookupFile, refineProject,-	getInspected,--	append, remove,--	Structured(..),-	structured, structurize, merge,--	Map-	) where--import Control.Lens (set, view, preview, _Just, _Right, each, (^..))-import Control.Monad (msum, join)-import Control.DeepSeq (NFData(..))-import Data.Aeson-import Data.Either (rights)-import Data.Foldable (find)-import Data.Function (on)-import Data.Group (Group(..))-import Data.Map (Map)-import Data.Maybe-import qualified Data.Map as M--import HsDev.Symbols-import HsDev.Symbols.Util-import HsDev.Util ((.::), ordNub, mapBy)---- | HsDev database-data Database = Database {-	databaseModules :: [InspectedModule],-	databaseProjects :: [Project] }-		deriving (Eq, Ord)--instance NFData Database where-	rnf (Database ms ps) = rnf ms `seq` rnf ps--instance Group Database where-	add old new = Database {-		databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules new) `M.union` mapBy (view inspectedId) (databaseModules old),-		databaseProjects = M.elems $ M.unionWith mergeProject-			(mapBy (view projectCabal) (databaseProjects new))-			(mapBy (view projectCabal) (databaseProjects old)) }-		where-			mergeProject pl pr = set projectDescription (msum [view projectDescription pl, view projectDescription pr]) pl-	sub old new = Database {-		databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules old) `M.difference` mapBy (view inspectedId) (databaseModules new),-		databaseProjects = M.elems $ mapBy (view projectCabal) (databaseProjects old) `M.difference` mapBy (view projectCabal) (databaseProjects new) }-	zero = Database [] []--instance Monoid Database where-	mempty = zero-	mappend = add--instance ToJSON Database where-	toJSON (Database ms ps) = object [-		"modules" .= ms,-		"projects" .= ps]--instance FromJSON Database where-	parseJSON = withObject "database" $ \v -> Database <$>-		(v .:: "modules") <*>-		(v .:: "projects")---- | Database intersection, prefers first database data-databaseIntersection :: Database -> Database -> Database-databaseIntersection l r = mempty {-	databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules l) `M.intersection` mapBy (view inspectedId) (databaseModules r),-	databaseProjects = M.elems $ mapBy (view projectCabal) (databaseProjects l) `M.intersection` mapBy (view projectCabal) (databaseProjects r) }---- | Check if database is empty-nullDatabase :: Database -> Bool-nullDatabase db = null (databaseModules db) && null (databaseProjects db)---- | Bring all locals to scope-databaseLocals :: Database -> Database-databaseLocals db = db {-	databaseModules = fmap (fmap moduleLocals) (databaseModules db) }---- | All scanned sandboxes-databasePackageDbs :: Database -> [PackageDb]-databasePackageDbs db = ordNub $ databaseModules db ^.. each . inspectionResult . _Right . moduleLocation . modulePackageDb---- | All modules-allModules :: Database -> [Module]-allModules = rights . fmap (view inspectionResult) . databaseModules---- | All declarations-allDeclarations :: Database -> [ModuleDeclaration]-allDeclarations db = do-	m <- allModules db-	moduleModuleDeclarations m---- | All packages-allPackages :: Database -> [ModulePackage]-allPackages = ordNub . mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules---- | Make database from module-fromModule :: InspectedModule -> Database-fromModule m = zero {-	databaseModules = [m] }---- | Make database from project-fromProject :: Project -> Database-fromProject p = zero {-	databaseProjects = [p] }---- | Filter database by predicate-filterDB :: (ModuleId -> Bool) -> (Project -> Bool) -> Database -> Database-filterDB m p db = mempty {-	databaseModules = filter (either (const False) (m . view moduleId) . view inspectionResult) (databaseModules db),-	databaseProjects = filter p (databaseProjects db) }---- | Project database-projectDB :: Project -> Database -> Database-projectDB proj = filterDB (inProject proj) (((==) `on` view projectCabal) proj)---- | Package-db database-packageDbDB :: PackageDb -> Database -> Database-packageDbDB pdb = filterDB (inPackageDb pdb) (const False)--packageDbStackDB :: PackageDbStack -> Database -> Database-packageDbStackDB pdbs = filterDB (inPackageDbStack pdbs) (const False)---- | Standalone database-standaloneDB :: Database -> Database-standaloneDB = filterDB check' (const False) where-	check' m = standalone m && byFile m---- | Select module by predicate-selectModules :: (Module -> Bool) -> Database -> [Module]-selectModules p = filter p . allModules---- | Select declaration by predicate-selectDeclarations :: (ModuleDeclaration -> Bool) -> Database -> [ModuleDeclaration]-selectDeclarations p = filter p . allDeclarations---- | Lookup module by its location and name-lookupModule :: ModuleLocation -> Database -> Maybe Module-lookupModule mloc db = do-	m <- find ((== mloc) . view inspectedId) $ databaseModules db-	either (const Nothing) Just $ view inspectionResult m---- | Lookup inspected module-lookupInspected :: ModuleLocation -> Database -> Maybe InspectedModule-lookupInspected mloc db = find ((== mloc) . view inspectedId) $ databaseModules db---- | Lookup module by its source file-lookupFile :: FilePath -> Database -> Maybe Module-lookupFile f = listToMaybe . selectModules (inFile f . view moduleId)---- | Refine project-refineProject :: Database -> Project -> Maybe Project-refineProject db proj = find ((== view projectCabal proj) . view projectCabal) $ databaseProjects db---- | Get inspected module-getInspected :: Database -> Module -> InspectedModule-getInspected db m = fromMaybe err $ find ((== view moduleLocation m) . view inspectedId) $ databaseModules db where-	err = error "Impossible happened: getInspected"---- | Append database-append :: Database -> Database -> Database-append = add---- | Remove database-remove :: Database -> Database -> Database-remove = sub---- | Structured database-data Structured = Structured {-	structuredPackageDbs :: Map PackageDb Database,-	structuredProjects :: Map FilePath Database,-	structuredFiles :: Database }-		deriving (Eq, Ord)--instance NFData Structured where-	rnf (Structured cs ps fs) = rnf cs `seq` rnf ps `seq` rnf fs--instance Group Structured where-	add old new = Structured {-		structuredPackageDbs = structuredPackageDbs new `M.union` structuredPackageDbs old,-		structuredProjects = structuredProjects new `M.union` structuredProjects old,-		structuredFiles = structuredFiles old `add` structuredFiles new }-	sub old new = Structured {-		structuredPackageDbs = structuredPackageDbs old `M.difference` structuredPackageDbs new,-		structuredProjects = structuredProjects old `M.difference` structuredProjects new,-		structuredFiles = structuredFiles old `sub` structuredFiles new }-	zero = Structured zero zero zero--instance Monoid Structured where-	mempty = zero-	mappend = add--instance ToJSON Structured where-	toJSON (Structured cs ps fs) = object [-		"cabals" .= M.elems cs,-		"projects" .= M.elems ps,-		"files" .= fs]--instance FromJSON Structured where-	parseJSON = withObject "structured" $ \v -> join $-		either fail return <$> (structured <$>-			(v .:: "cabals") <*>-			(v .:: "projects") <*>-			(v .:: "files"))--structured :: [Database] -> [Database] -> Database -> Either String Structured-structured cs ps fs = Structured <$> mkMap keyCabal cs <*> mkMap keyProj ps <*> pure fs where-	mkMap :: Ord a => (Database -> Either String a) -> [Database] -> Either String (Map a Database)-	mkMap key dbs = do-		keys <- mapM key dbs-		return $ M.fromList $ zip keys dbs-	keyCabal :: Database -> Either String PackageDb-	keyCabal db = unique-		"No cabal"-		"Different module cabals"-		(ordNub <$> mapM getPackageDb (allModules db))-		where-			getPackageDb m = case view moduleLocation m of-				InstalledModule c _ _ -> Right c-				_ -> Left "Module have no cabal"-	keyProj :: Database -> Either String FilePath-	keyProj db = unique-		"No project"-		"Different module projects"-		(return (databaseProjects db ^.. each . projectCabal))-	-- Check that list results in one element-	unique :: String -> String -> Either String [a] -> Either String a-	unique _ _ (Left e) = Left e-	unique no _ (Right []) = Left no-	unique _ _ (Right [x]) = Right x-	unique _ much (Right _) = Left much--structurize :: Database -> Structured-structurize db = Structured cs ps fs where-	cs = M.fromList [(c, packageDbDB c db) | c <- ordNub (mapMaybe modPackageDb (allModules db))]-	ps = M.fromList [(pname, projectDB (project pname) db) | pname <- databaseProjects db ^.. each . projectCabal]-	fs = standaloneDB db--merge :: Structured -> Database-merge (Structured cs ps fs) = mconcat $ M.elems cs ++ M.elems ps ++ [fs]--modPackageDb :: Module -> Maybe PackageDb-modPackageDb m = case view moduleLocation m of-	InstalledModule c _ _ -> Just c-	_ -> Nothing

@@ -1,30 +0,0 @@-module HsDev.Database.Async (
-	update, clear, wait,
-	module Data.Async
-	) where
-
-import Control.Concurrent.MVar
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.DeepSeq (force)
-
-import Data.Async
-
-import HsDev.Database (Database)
-
-update :: MonadIO m => Async Database -> m Database -> m ()
-update db act = do
-	db' <- act
-	force db' `seq` liftIO (modifyAsync db (Append db'))
-
-clear :: MonadIO m => Async Database -> m Database -> m ()
-clear db act = do
-	db' <- act
-	force db' `seq` liftIO (modifyAsync db (Remove db'))
-
--- | This function is used to ensure that all previous updates were applied
-wait :: MonadIO m => Async Database -> m ()
-wait db = liftIO $ do
-	waitVar <- newEmptyMVar
-	modifyAsync db (Action $ \d -> putMVar waitVar () >> return d)
-	-- FIXME: what if async process is dead?
-	takeMVar waitVar

@@ -0,0 +1,527 @@+{-# LANGUAGE OverloadedStrings, TypeOperators, TypeApplications #-}
+
+module HsDev.Database.SQLite (
+	initialize, purge,
+	privateMemory, sharedMemory,
+	query, query_, queryNamed, execute, execute_, executeMany, executeNamed,
+	withTemporaryTable,
+	updatePackageDb, removePackageDb, insertPackageDb,
+	updateProject, removeProject, insertProject, insertBuildInfo,
+	updateModule,
+	removeModuleContents, removeModule,
+	insertModuleSymbols,
+	upsertModule,
+	lookupModuleLocation, lookupModule,
+	lookupSymbol,
+	lastRow,
+
+	loadModule, loadModules,
+	loadProject,
+
+	-- * Utils
+	escapeLike,
+
+	-- * Reexports
+	module Database.SQLite.Simple,
+	module HsDev.Database.SQLite.Select,
+	module HsDev.Database.SQLite.Instances,
+	module HsDev.Database.SQLite.Transaction
+	) where
+
+import Control.Lens hiding ((.=))
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Data.Aeson hiding (Error)
+import Data.Generics.Uniplate.Operations
+import Data.List (intercalate)
+import Data.Maybe
+import Data.String
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Database.SQLite.Simple hiding (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)
+import qualified Database.SQLite.Simple as SQL (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction)
+import Distribution.Text (display)
+import Language.Haskell.Exts.Syntax hiding (Name, Module)
+import Language.Haskell.Extension ()
+import System.Log.Simple
+import Text.Format
+
+import System.Directory.Paths
+
+import HsDev.Database.SQLite.Instances
+import HsDev.Database.SQLite.Schema
+import HsDev.Database.SQLite.Select
+import HsDev.Database.SQLite.Transaction
+import qualified HsDev.Display as Display
+import HsDev.Error
+import HsDev.PackageDb.Types
+import HsDev.Project.Types
+import HsDev.Symbols.Name
+import HsDev.Symbols.Parsed
+import HsDev.Symbols.Types hiding (loadProject)
+import qualified HsDev.Symbols.Parsed as P
+import qualified HsDev.Symbols.Name as Name
+import HsDev.Server.Types
+import HsDev.Util
+
+-- | Initialize database
+initialize :: String -> IO Connection
+initialize p = do
+	conn <- open p
+	SQL.execute_ conn "pragma case_sensitive_like = true;"
+	[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
+	unless goodVersion $
+		-- TODO: Completely drop schema to reinitialize
+		hsdevError $ OtherError "Not implemented: dropping schema of db"
+	when (not hasTables || not goodVersion) $ SQL.withTransaction conn $ do
+		mapM_ (SQL.execute_ conn) commands
+		SQL.execute @(Text, Value) conn "insert into hsdev values (?, ?);" ("version", toJSON version)
+	return conn
+
+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" $ 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 -> Maybe PackageDbStack -> m ()
+updateProject proj pdbs = scope "update-project" $ do
+	sendLog Trace $ "update project: {}" ~~ Display.display proj
+	removeProject proj
+	insertProject proj pdbs
+
+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 -> Maybe PackageDbStack -> m ()
+insertProject proj pdbs = scope "insert-project" $ do
+	execute "insert into projects (name, cabal, version, package_db_stack) values (?, ?, ?, ?);" (
+		proj ^. projectName,
+		proj ^. projectCabal . path,
+		proj ^? projectDescription . _Just . projectVersion,
+		fmap (encode . packageDbs) pdbs)
+	projId <- lastRow
+
+	forM_ (proj ^? projectDescription . _Just . projectLibrary . _Just) $ \lib -> do
+		buildInfoId <- insertBuildInfo $ lib ^. libraryBuildInfo
+		execute "insert into libraries (project_id, modules, build_info_id) values (?, ?, ?);"
+			(projId, encode $ lib ^. libraryModules, buildInfoId)
+
+	forM_ (proj ^.. projectDescription . _Just . projectExecutables . each) $ \exe -> do
+		buildInfoId <- insertBuildInfo $ exe ^. executableBuildInfo
+		execute "insert into executables (project_id, name, path, build_info_id) values (?, ?, ?, ?);"
+			(projId, exe ^. executableName, exe ^. executablePath . path, buildInfoId)
+
+	forM_ (proj ^.. projectDescription . _Just . projectTests . each) $ \test -> do
+		buildInfoId <- insertBuildInfo $ test ^. testBuildInfo
+		execute "insert into tests (project_id, name, enabled, main, build_info_id) values (?, ?, ?, ?, ?);"
+			(projId, test ^. testName, test ^. testEnabled, test ^? testMain . _Just . path, buildInfoId)
+
+insertBuildInfo :: SessionMonad m => Info -> m Int
+insertBuildInfo info = scope "insert-build-info" $ do
+	execute "insert into build_infos (depends, language, extensions, ghc_options, source_dirs, other_modules) values (?, ?, ?, ?, ?, ?);" (
+			encode $ info ^. infoDepends,
+			fmap display $ info ^. infoLanguage,
+			encode $ map display $ info ^. infoExtensions,
+			encode $ info ^. infoGHCOptions,
+			encode $ info ^.. infoSourceDirs . each . path,
+			encode $ info ^. infoOtherModules)
+	lastRow
+
+updateModule :: SessionMonad m => InspectedModule -> m ()
+updateModule im = scope "update-module" $ do
+	_ <- upsertModule im
+	insertModuleSymbols im
+
+removeModuleContents :: SessionMonad m => Int -> m ()
+removeModuleContents mid = 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)
+
+removeModule :: SessionMonad m => Int -> m ()
+removeModule mid = scope "remove-module" $ do
+	removeModuleContents mid
+	execute "delete from modules where id == ?;" (Only mid)
+
+upsertModule :: SessionMonad m => InspectedModule -> m Int
+upsertModule im = scope "upsert-module" $ do
+	mmid <- lookupModuleLocation (im ^. inspectedKey)
+	case mmid of
+		Nothing -> do
+			execute "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"
+				moduleData
+			lastRow
+		Just mid' -> do
+			execute "update modules set file = ?, cabal = ?, install_dirs = ?, package_name = ?, package_version = ?, installed_name = ?, other_location = ?, name = ?, docs = ?, fixities = ?, tags = ?, inspection_error = ?, inspection_time = ?, inspection_opts = ? where id == ?;"
+				(moduleData :. Only mid')
+			return mid'
+	where
+		moduleData = (
+			im ^? inspectedKey . moduleFile . path,
+			im ^? inspectedKey . moduleProject . _Just . projectCabal,
+			fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs),
+			im ^? inspectedKey . modulePackage . packageName,
+			im ^? inspectedKey . modulePackage . packageVersion,
+			im ^? inspectedKey . installedModuleName,
+			im ^? inspectedKey . otherLocationName)
+			:. (
+			msum [im ^? inspected . moduleId . moduleName, im ^? inspectedKey . installedModuleName],
+			im ^? inspected . moduleDocs,
+			fmap encode $ im ^? inspected . moduleFixities,
+			encode $ asDict $ im ^. inspectionTags,
+			fmap show $ im ^? inspectionResult . _Left)
+			:.
+			fromMaybe InspectionNone (im ^? inspection)
+		asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags]
+
+insertModuleSymbols :: SessionMonad m => InspectedModule -> m ()
+insertModuleSymbols im = scope "insert-module-symbols" $ do
+	[Only mid] <- queryNamed "select id from modules where ((file is null and :file is null) or file = :file) and ((package_name is null and :package_name is null) or package_name = :package_name) and ((package_version is null and :package_version is null) or package_version = :package_version) and ((other_location is null and :other_location is null) or other_location = :other_location) and ((installed_name is null and :installed_name is null) or installed_name = :installed_name);" [
+		":file" := im ^? inspectedKey . moduleFile . path,
+		":package_name" := im ^? inspectedKey . modulePackage . packageName,
+		":package_version" := im ^? inspectedKey . modulePackage . packageVersion,
+		":other_location" := im ^? inspectedKey . otherLocationName,
+		":installed_name" := im ^? inspectedKey . installedModuleName]
+	-- TODO: Delete obsolete symbols (note, that they can be referenced from another modules)
+	removeModuleContents mid
+	insertModuleImports mid
+	insertExportSymbols mid (im ^.. inspected . moduleExports . each)
+	insertScopeSymbols mid (im ^.. inspected . scopeSymbols)
+	maybe (return ()) (insertResolvedNames mid) (im ^? inspected . moduleSource . _Just)
+	where
+		insertModuleImports :: SessionMonad m => Int -> m ()
+		insertModuleImports mid = scope "insert-module-imports" $ do
+			case im ^? inspected . moduleSource . _Just of
+				Nothing -> return ()
+				Just psrc -> do
+					let
+						imps = childrenBi psrc :: [ImportDecl Ann]
+						importRow idecl@(ImportDecl _ mname qual _ _ _ alias specList) = (
+							mid,
+							idecl ^. pos . positionLine,
+							getModuleName mname,
+							qual,
+							fmap getModuleName alias,
+							maybe False getHiding specList,
+							fmap makeImportList specList)
+					executeMany "insert into imports (module_id, line, module_name, qualified, alias, hiding, import_list) values (?, ?, ?, ?, ?, ?, ?);"
+						(map importRow imps)
+			where
+				getModuleName (ModuleName _ s) = s
+				getHiding (ImportSpecList _ h _) = h
+
+				makeImportList (ImportSpecList _ _ specs) = encode $ map asJson specs
+				asJson (IVar _ nm) = object ["name" .= fromName_ (void nm), "what" .= str' "var"]
+				asJson (IAbs _ ns nm) = object ["name" .= fromName_ (void nm), "what" .= str' "abs", "ns" .= fromNamespace ns] where
+					fromNamespace :: Namespace l -> Maybe String
+					fromNamespace (NoNamespace _) = Nothing
+					fromNamespace (TypeNamespace _) = Just "type"
+					fromNamespace (PatternNamespace _) = Just "pat"
+				asJson (IThingAll _ nm) = object ["name" .= fromName_ (void nm), "what" .= str' "all"]
+				asJson (IThingWith _ nm cs) = object ["name" .= fromName_ (void nm), "what" .= str' "with", "list" .= map (fromName_ . void . toName') cs] where
+					toName' (VarName _ n') = n'
+					toName' (ConName _ n') = n'
+
+				str' :: String -> String
+				str' = id
+
+		insertExportSymbols :: SessionMonad m => Int -> [Symbol] -> m ()
+		insertExportSymbols _ [] = return ()
+		insertExportSymbols mid syms = scope "insert-export-symbols" $ withTemporaryTable "export_symbols" (symbolsColumns ++ idColumns) $ do
+			dumpSymbols "export_symbols" symbolsColumns syms
+			updateExistingSymbols "export_symbols"
+			insertMissingModules "export_symbols"
+			insertMissingSymbols "export_symbols"
+			execute "insert into exports (module_id, symbol_id) select ?, symbol_id from export_symbols;" (Only mid)
+
+		insertScopeSymbols :: SessionMonad m => Int -> [(Symbol, [Name])] -> m ()
+		insertScopeSymbols _ [] = return ()
+		insertScopeSymbols mid snames = scope "insert-scope-symbols" $ withTemporaryTable "scope_symbols" (symbolsColumns ++ scopeNameColumns ++ idColumns) $ do
+			dumpSymbols "scope_symbols" (symbolsColumns ++ scopeNameColumns)
+				[(s :. (Name.nameModule nm, Name.nameIdent nm)) | (s, nms) <- snames, nm <- nms]
+			updateExistingSymbols "scope_symbols"
+			insertMissingModules "scope_symbols"
+			insertMissingSymbols "scope_symbols"
+			execute "insert into scopes (module_id, qualifier, name, symbol_id) select ?, qualifier, ident, symbol_id from scope_symbols;" (Only mid)
+
+		insertResolvedNames :: SessionMonad m => Int -> Parsed -> m ()
+		insertResolvedNames mid p = scope "insert-resolved-names" $ do
+			insertNames
+			replaceQNames
+			where
+				insertNames = executeMany insertQuery namesData
+				replaceQNames = executeMany insertQuery qnamesData
+				insertQuery = "insert or replace into names (module_id, qualifier, name, line, column, line_to, column_to, def_line, def_column, resolved_module, resolved_name, resolve_error) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);"
+				namesData = map toData $ p ^.. P.names
+				qnamesData = map toQData $ p ^.. P.qnames
+				toData name = (
+					mid,
+					Nothing :: Maybe Text,
+					Name.fromName_ $ void name,
+					name ^. P.pos . positionLine,
+					name ^. P.pos . positionColumn,
+					name ^. P.regionL . regionTo . positionLine,
+					name ^. P.regionL . regionTo . positionColumn)
+					:. (
+					name ^? P.defPos . positionLine,
+					name ^? P.defPos . positionColumn,
+					(name ^? P.resolvedName) >>= Name.nameModule,
+					Name.nameIdent <$> (name ^? P.resolvedName),
+					P.resolveError name)
+				toQData qname = (
+					mid,
+					Name.nameModule $ void qname,
+					Name.nameIdent $ void qname,
+					qname ^. P.pos . positionLine,
+					qname ^. P.pos . positionColumn,
+					qname ^. P.regionL . regionTo . positionLine,
+					qname ^. P.regionL . regionTo . positionColumn)
+					:. (
+					qname ^? P.defPos . positionLine,
+					qname ^? P.defPos . positionColumn,
+					(qname ^? P.resolvedName) >>= Name.nameModule,
+					Name.nameIdent <$> (qname ^? P.resolvedName),
+					P.resolveError qname)
+
+		symbolsColumns :: [String]
+		symbolsColumns = [
+			"name", "module_name",
+			"file", "cabal", "install_dirs", "package_name", "package_version", "installed_name", "other_location",
+			"docs",
+			"line", "column",
+			"what", "type", "parent", "constructors", "args", "context", "associate", "pat_type", "pat_constructor"]
+
+		scopeNameColumns :: [String]
+		scopeNameColumns = ["qualifier", "ident"]
+
+		idColumns :: [String]
+		idColumns = ["module_id", "symbol_id"]
+
+		-- Dumps symbol data to temporary row and fills with 'module_id' and 'symbol_id' fields
+		dumpSymbols :: (SessionMonad m, ToRow q) => String -> [String] -> [q] -> m ()
+		dumpSymbols tableName columnNames rows = scope "dump-symbols" $ do
+			executeMany (fromString ("insert into {} ({}) values ({});" ~~ tableName ~~ intercalate ", " columnNames ~~ intercalate ", " (replicate (length columnNames) "?"))) (map toRow rows)
+			updateModuleIds tableName
+			updateSymbolIds tableName
+
+		updateModuleIds :: SessionMonad m => String -> m ()
+		updateModuleIds tableName =
+			execute_ (fromString ("update {table} set module_id = (select m.id from modules as m where ((m.name is null and {table}.module_name is null) or m.name = {table}.module_name) and ((m.file is null and {table}.file is null) or m.file = {table}.file) and ((m.package_name is null and {table}.package_name is null) or m.package_name = {table}.package_name) and ((m.package_version is null and {table}.package_version is null) or m.package_version = {table}.package_version) and ((m.installed_name is null and {table}.installed_name is null) or m.installed_name = {table}.installed_name) and ((m.other_location is null and {table}.other_location is null) or m.other_location = {table}.other_location));" ~~ ("table" ~% tableName)))
+
+		updateSymbolIds :: SessionMonad m => String -> m ()
+		updateSymbolIds tableName =
+			execute_ (fromString ("update {table} set symbol_id = (select s.id from symbols as s where s.name = {table}.name and s.module_id = {table}.module_id);" ~~ ("table" ~% tableName)))
+
+		updateExistingSymbols :: SessionMonad m => String -> m ()
+		updateExistingSymbols tableName = scope "update-existing-symbols" $ do
+			execute_ (fromString ("replace into symbols (id, name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) select symbols.id, {table}.name, {table}.module_id, {table}.docs, {table}.line, {table}.column, {table}.what, {table}.type, {table}.parent, {table}.constructors, {table}.args, {table}.context, {table}.associate, {table}.pat_type, {table}.pat_constructor from {table} inner join symbols on (symbols.name == {table}.name) and (symbols.module_id == {table}.module_id);" ~~ ("table" ~% tableName)))
+
+		insertMissingModules :: SessionMonad m => String -> m ()
+		insertMissingModules tableName = scope "insert-missing-modules" $ do
+			execute_ (fromString ("insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, other_location, name) select distinct file, cabal, install_dirs, package_name, package_version, installed_name, other_location, module_name from {} where module_id is null;" ~~ tableName))
+			updateModuleIds tableName
+
+		insertMissingSymbols :: SessionMonad m => String -> m ()
+		insertMissingSymbols tableName = scope "insert-missing-symbols" $ do
+			execute_ (fromString ("insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) select distinct name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor from {} where module_id is not null and symbol_id is null;" ~~ tableName))
+			updateSymbolIds tableName
+
+lookupModuleLocation :: SessionMonad m => ModuleLocation -> m (Maybe Int)
+lookupModuleLocation m = do
+	mids <- queryNamed "select id from modules where ((file is null and :file is null) or file = :file) and ((package_name is null and :package_name is null) or package_name = :package_name) and ((package_version is null and :package_version is null) or package_version = :package_version) and ((installed_name is null and :installed_name is null) or installed_name = :installed_name) and ((other_location is null and :other_location is null) 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 is null and :file is null) or file = :file) and ((package_name is null and :package_name is null) or package_name = :package_name) and ((package_version is null and :package_version is null) or package_version = :package_version) and ((installed_name is null and :installed_name is null) or installed_name = :installed_name) and ((other_location is null and :other_location is null) 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 (qModuleId `mappend` select_ ["mu.docs", "mu.fixities", "mu.id"] [] [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 (qSymbol `mappend` select_ [] ["exports as e"] ["e.module_id == ?", "e.symbol_id == s.id"])) (Only mid)
+			inames <- query @_ @(Only Text) "select distinct module_name from imports where module_id == ?;" (Only mid)
+			return $ Module {
+				_moduleId = mid',
+				_moduleDocs = mdocs,
+				_moduleImports = map fromOnly inames,
+				_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 (qModuleId `mappend` select_ ["mu.docs", "mu.fixities", "mu.id"] [] [fromString $ "mu.id in (" ++ selectExpr ++ ")"])) args
+	forM ms $ \(mid' :. (mdocs, mfixities, mid)) -> do
+		syms <- query @_ @Symbol (toQuery (qSymbol `mappend` select_ [] ["exports as e"] ["e.module_id == ?", "e.symbol_id == s.id"])) (Only mid)
+		inames <- query @_ @(Only Text) "select distinct module_name from imports where module_id == ?;" (Only mid)
+		return $ Module {
+			_moduleId = mid',
+			_moduleDocs = mdocs,
+			_moduleImports = map fromOnly inames,
+			_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 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 $ select_ ["lib.modules"] ["libraries as lib"] [] `mappend` qBuildInfo `mappend` where_ [
+		"lib.build_info_id == bi.id",
+		"lib.project_id == ?"])
+			(Only pid)
+
+	exes <- query (toQuery $ select_ ["exe.name", "exe.path"] ["executables as exe"] [] `mappend` qBuildInfo `mappend` where_ [
+		"exe.build_info_id == bi.id",
+		"exe.project_id == ?"])
+			(Only pid)
+
+	tests <- query (toQuery $ select_ ["tst.name", "tst.enabled", "tst.main"] ["tests as tst"] [] `mappend` qBuildInfo `mappend` 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
+
+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

@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Database.SQLite.Instances (
+	JSON(..)
+	) where
+
+import Control.Lens ((^.), (^?), _Just)
+import Data.Aeson as A
+import Data.Maybe
+import Data.Foldable
+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 Text.Format
+
+import System.Directory.Paths
+import HsDev.Symbols.Location
+import HsDev.Symbols.Types
+import HsDev.Tools.Ghc.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
+		other <- field
+
+		maybe (fail $ "Can't parse module location: {}" ~~ show (file, cabal, dirs, pname, pver, iname, other)) return $ msum [
+			FileModule <$> file <*> pure (project <$> cabal),
+			InstalledModule <$> maybe (pure []) fromJSON' dirs <*> (ModulePackage <$> pname <*> pver) <*> iname,
+			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 ^? otherLocationName]
+
+instance FromRow ModuleId where
+	fromRow = ModuleId <$> field <*> fromRow
+
+instance ToRow ModuleId where
+	toRow mid = toField (mid ^. moduleName) : toRow (mid ^. moduleLocation)
+
+instance FromRow SymbolId where
+	fromRow = SymbolId <$> field <*> fromRow
+
+instance ToRow SymbolId where
+	toRow (SymbolId nm mid) = toField nm : toRow mid
+
+instance FromRow Symbol where
+	fromRow = Symbol <$> fromRow <*> field <*> pos <*> infoP where
+		pos = do
+			line <- field
+			column <- field
+			return $ Position <$> line <*> column
+		infoP = do
+			what <- str' <$> field
+			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
+		str' :: String -> String
+		str' = id
+
+instance ToRow Symbol where
+	toRow sym = concat [
+		toRow (sym ^. symbolId),
+		[toField $ sym ^. symbolDocs],
+		maybe [SQLNull, SQLNull] toRow (sym ^. symbolPosition),
+		info]
+		where
+			info = [
+				toField $ symbolType sym,
+				toField $ sym ^? symbolInfo . functionType . _Just,
+				toField $ msum [sym ^? symbolInfo . parentClass, sym ^? symbolInfo . parentType],
+				toField $ toJSON $ sym ^? symbolInfo . selectorConstructors,
+				toField $ toJSON $ sym ^? symbolInfo . typeArgs,
+				toField $ toJSON $ sym ^? symbolInfo . typeContext,
+				toField $ sym ^? symbolInfo . familyAssociate . _Just,
+				toField $ sym ^? symbolInfo . patternType . _Just,
+				toField $ sym ^? symbolInfo . patternConstructor]
+
+instance FromRow Project where
+	fromRow = do
+		name <- field
+		cabal <- field
+		ver <- field
+		return $ Project name (takeDir cabal) cabal $ Just $ ProjectDescription ver Nothing [] []
+
+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 FromRow SymbolUsage where
+	fromRow = SymbolUsage <$> fromRow <*> fromRow <*> fromRow
+
+instance FromRow Inspection where
+	fromRow = do
+		tm <- field
+		opts <- field
+		case (tm, opts) of
+			(Nothing, Nothing) -> return InspectionNone
+			(_, Just opts') -> InspectionAt (maybe 0 (fromRational . (toRational :: Double -> Rational)) 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 (fromRational (toRational tm) :: Double),
+		toField $ toJSON opts]
+
+instance FromRow TypedExpr where
+	fromRow = TypedExpr <$> field <*> field
+
+instance ToRow TypedExpr where
+	toRow (TypedExpr e t) = [toField e, toField t]

@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module HsDev.Database.SQLite.Schema (
+	schema, commands
+	) where
+
+import qualified Data.Text as T
+import Data.String
+import Database.SQLite.Simple (Query)
+
+import HsDev.Database.SQLite.Schema.TH
+
+schema :: T.Text
+schema = T.pack $schemaExp
+
+commands :: [Query]
+commands =
+	map (fromString . T.unpack) $
+	filter (not . T.null) $
+	map T.strip $ T.splitOn ";" schema

@@ -0,0 +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 |]

@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}
+
+module HsDev.Database.SQLite.Select (
+	Select(..), select_, where_, buildQuery, toQuery,
+	qSymbolId, qSymbol, qModuleLocation, qModuleId, qBuildInfo
+	) where
+
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import Database.SQLite.Simple
+import Text.Format
+
+data Select = Select {
+	selectColumns :: [Text],
+	selectTables :: [Text],
+	selectConditions :: [Text] }
+		deriving (Eq, Ord, Read, Show)
+
+instance Monoid Select 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_ :: [Text] -> [Text] -> [Text] -> Select
+select_ = Select
+
+where_ :: [Text] -> Select
+where_ = select_ [] []
+
+buildQuery :: Select -> 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 -> Query
+toQuery = fromString . buildQuery
+
+qSymbolId :: Select
+qSymbolId = select_
+	[
+		"s.name",
+		"m.name",
+		"m.file",
+		"m.cabal",
+		"m.install_dirs",
+		"m.package_name",
+		"m.package_version",
+		"m.installed_name",
+		"m.other_location"]
+	["modules as m", "symbols as s"]
+	["m.id == s.module_id"]
+
+qSymbol :: Select
+qSymbol = qSymbolId `mappend` select_ cols [] [] where
+	cols = [
+		"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 :: Select
+qModuleLocation = select_
+	[
+		"ml.file",
+		"ml.cabal",
+		"ml.install_dirs",
+		"ml.package_name",
+		"ml.package_version",
+		"ml.installed_name",
+		"ml.other_location"]
+	["modules as ml"]
+	[]
+
+qModuleId :: Select
+qModuleId = select_
+	[
+		"mu.name",
+		"mu.file",
+		"mu.cabal",
+		"mu.install_dirs",
+		"mu.package_name",
+		"mu.package_version",
+		"mu.installed_name",
+		"mu.other_location"]
+	["modules as mu"]
+	[]
+
+qBuildInfo :: Select
+qBuildInfo = select_
+	[
+		"bi.depends",
+		"bi.language",
+		"bi.extensions",
+		"bi.ghc_options",
+		"bi.source_dirs",
+		"bi.other_modules"
+	]
+	["build_infos as bi"]
+	[]

@@ -0,0 +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 100 100000) $ \e -> sqlError e `elem` [ErrorBusy, ErrorLocked]
+
+-- | Don't retry
+noRetry :: Retries
+noRetry = Retries [] (const False)
+
+-- | Retry forever
+retryForever :: Int -> Retries
+retryForever interval = def { retriesIntervals = repeat interval }
+
+-- | Retry with interval N times
+retryN :: Int -> Int -> Retries
+retryN interval times = def { retriesIntervals = replicate times interval }
+
+-- | Run actions inside transaction
+withTransaction :: (MonadIO m, MonadMask m) => Connection -> TransactionType -> Retries -> m a -> m a
+withTransaction conn t rs act = mask $ \restore -> do
+	mretry restore (beginTransaction conn t)
+	(restore act <* mretry restore (commitTransaction conn)) `onException` rollbackTransaction conn
+	where
+		mretry restore' fn = mretry' (retriesIntervals rs) where
+			mretry' [] = fn
+			mretry' (tm:tms) = catch @_ @SQLError fn $ \e -> if
+				| retriesError rs e -> do
+						_ <- restore' $ liftIO $ threadDelay tm
+						mretry' tms
+				| otherwise -> throwM e
+
+-- | Begin transaction
+beginTransaction :: MonadIO m => Connection -> TransactionType -> m ()
+beginTransaction conn t = liftIO $ SQL.execute_ conn $ case t of
+	Deferred -> "begin transaction;"
+	Immediate -> "begin immediate transaction;"
+	Exclusive -> "begin exclusive transaction;"
+
+-- | Commit transaction
+commitTransaction :: MonadIO m => Connection -> m ()
+commitTransaction conn = liftIO $ SQL.execute_ conn "commit transaction;"
+
+-- | Rollback transaction
+rollbackTransaction :: MonadIO m => Connection -> m ()
+rollbackTransaction conn = liftIO $ SQL.execute_ conn "rollback transaction;"
+
+-- | Run transaction in @SessionMonad@
+transaction :: SessionMonad m => TransactionType -> Retries -> m a -> m a
+transaction t rs act = do
+	conn <- serverSqlDatabase
+	withTransaction conn t rs act
+
+-- | Transaction with default retries config
+transaction_ :: SessionMonad m => TransactionType -> m a -> m a
+transaction_ t = transaction t def
+
+-- | Retry operation
+retry :: (MonadIO m, MonadCatch m) => Retries -> m a -> m a
+retry rs = retry' (retriesIntervals rs) where
+	retry' [] fn = fn
+	retry' (tm:tms) fn = catch @_ @SQLError fn $ \e -> if
+		| retriesError rs e -> do
+			liftIO $ threadDelay tm
+			retry' tms fn
+		| otherwise -> throwM e
+
+-- | Retry with default params
+retry_ :: (MonadIO m, MonadCatch m) => m a -> m a
+retry_ = retry def

@@ -1,447 +1,601 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Database.Update (-	Status(..), Progress(..), Task(..), isStatus,-	UpdateOptions(..),--	UpdateM(..),-	runUpdate,--	postStatus, waiter, updater, loadCache, getCache, runTask, runTasks,-	readDB,--	scanModule, scanModules, scanFile, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanProjectFile, scanProjectStack, scanProject, scanDirectory, scanContents,-	scanDocs, inferModTypes,-	scan,-	updateEvent, processEvent,--	module HsDev.Database.Update.Types,--	module HsDev.Watcher,--	module Control.Monad.Except-	) where--import Control.Applicative ((<|>))-import Control.Arrow-import Control.Concurrent.Lifted (fork)-import Control.DeepSeq-import Control.Lens (preview, _Just, view, over, set, _1, mapMOf_, each, (^..), _head, _Right)-import Control.Monad.Catch (catch)-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Writer-import Data.Aeson-import Data.Aeson.Types-import Data.Foldable (toList)-import qualified Data.Map as M-import Data.Maybe (mapMaybe, isJust, fromMaybe)-import qualified Data.Text as T (unpack)-import System.Directory (canonicalizePath, doesFileExist)-import System.FilePath-import qualified System.Log.Simple as Log--import HsDev.Error-import qualified HsDev.Cache.Structured as Cache-import HsDev.Database-import HsDev.Database.Async hiding (Event)-import HsDev.Display-import HsDev.Inspect (inspectDocs, inspectDocsGhc)-import HsDev.Project-import HsDev.Sandbox-import HsDev.Stack-import HsDev.Symbols-import HsDev.Tools.Ghc.Session hiding (wait)-import HsDev.Tools.Ghc.Types (inferTypes)-import HsDev.Tools.HDocs-import qualified HsDev.Scan as S-import HsDev.Scan.Browse-import HsDev.Util (isParent, ordNub)-import qualified HsDev.Util as Util (withCurrentDirectory)-import HsDev.Server.Types (commandNotify, serverWriteCache, serverReadCache)-import HsDev.Server.Message-import HsDev.Database.Update.Types-import HsDev.Watcher-import Text.Format--onStatus :: UpdateMonad m => m ()-onStatus = asks (view updateTasks) >>= commandNotify . Notification . toJSON . reverse--childTask :: UpdateMonad m => Task -> m a -> m a-childTask t = local (over updateTasks (t:))--isStatus :: Value -> Bool-isStatus = isJust . parseMaybe (parseJSON :: Value -> Parser Task)--runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a-runUpdate uopts act = Log.scope "update" $ do-	(r, updatedMods) <- runWriterT (runUpdateM act' `runReaderT` uopts)-	db <- askSession sessionDatabase-	wait db-	dbval <- liftIO $ readAsync db-	let-		dbs = ordNub $ mapMaybe (preview modulePackageDb) updatedMods-		projs = ordNub $ mapMaybe (preview $ moduleProject . _Just) updatedMods-		stand = any moduleStandalone updatedMods--		modifiedDb = mconcat $ concat [-			map (`packageDbDB` dbval) dbs,-			map (`projectDB` dbval) projs,-			[standaloneDB dbval | stand]]-	serverWriteCache modifiedDb-	return r-	where-		act' = do-			(r, mlocs') <- liftM (second $ filter (isJust . preview moduleFile)) $ listen act-			db <- askSession sessionDatabase-			wait db-			let-				getMods :: (MonadIO m) => m [InspectedModule]-				getMods = do-					db' <- liftIO $ readAsync db-					return $ filter ((`elem` mlocs') . view inspectedId) $ toList $ databaseModules db'-			when (view updateDocs uopts) $ do-				Log.sendLog Log.Trace "forking inspecting source docs"-				void $ fork (getMods >>= waiter . mapM_ scanDocs_)-			when (view updateInfer uopts) $ do-				Log.sendLog Log.Trace "forking inferring types"-				void $ fork (getMods >>= waiter . mapM_ inferModTypes_)-			return r-		scanDocs_ :: UpdateMonad m => InspectedModule -> m ()-		scanDocs_ im = do-			im' <- (S.scanModify (\opts _ -> liftIO . inspectDocs opts) im) <|> return im-			updater $ fromModule im'-		inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()-		inferModTypes_ im = do-			-- TODO: locate sandbox-			s <- getSession-			im' <- (S.scanModify (infer' s) im) <|> return im-			updater $ fromModule im'-		infer' :: UpdateMonad m => Session -> [String] -> PackageDbStack -> Module -> m Module-		infer' s opts _ m = case preview (moduleLocation . moduleFile) m of-			Nothing -> return m-			Just _ -> liftIO $ inWorker (sessionGhc s) $ do-				targetSession opts m-				inferTypes opts m Nothing---- | Post status-postStatus :: UpdateMonad m => Task -> m ()-postStatus t = childTask t onStatus---- | Wait DB to complete actions-waiter :: UpdateMonad m => m () -> m ()-waiter act = do-	db <- askSession sessionDatabase-	act-	wait db---- | Update task result to database-updater :: UpdateMonad m => Database -> m ()-updater db' = do-	db <- askSession sessionDatabase-	update db $ return $!! db'-	tell $!! map (view moduleLocation) $ allModules db'---- | Clear obsolete data from database-cleaner :: UpdateMonad m => m Database -> m ()-cleaner act = do-	db <- askSession sessionDatabase-	db' <- act-	clear db $ return $!! db'---- | Get data from cache without updating DB-loadCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> m Database-loadCache act = do-	mdat <- serverReadCache act-	return $ fromMaybe mempty mdat---- | Load data from cache if not loaded yet and wait-getCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> (Database -> Database) -> m Database-getCache act check = do-	dbval <- liftM check readDB-	if nullDatabase dbval-		then do-			db <- loadCache act-			waiter $ updater db-			return db-		else-			return dbval---- | 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 ()] -> m ()-runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where-	total = length ts-	taskNum n = local setProgress where-		setProgress = set (updateTasks . _head . taskProgress) (Just (Progress n total))-	noErr v = v `mplus` return ()---- | Get database value-readDB :: SessionMonad m => m Database-readDB = askSession sessionDatabase >>= liftIO . readAsync---- | Scan module-scanModule :: UpdateMonad m => [String] -> ModuleLocation -> Maybe String -> m ()-scanModule opts mloc mcts = runTask "scanning" mloc $ Log.scope "module" $ do-	defs <- askSession sessionDefines-	im <- S.scanModule defs opts mloc mcts-	updater $ fromModule im-	_ <- return $ view inspectionResult im-	return ()---- | Scan modules-scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()-scanModules opts ms = runTasks $-	[scanProjectFile opts p >> return () | p <- ps] ++-	[scanModule (opts ++ mopts) m mcts | (m, mopts, mcts) <- ms]-	where-		ps = ordNub $ mapMaybe (toProj . view _1) ms-		toProj (FileModule _ p) = fmap (view projectCabal) p-		toProj _ = Nothing---- | Scan source file-scanFile :: UpdateMonad m => [String] -> FilePath -> m ()-scanFile opts fpath = scanFileContents opts fpath Nothing---- | Scan source file with contents-scanFileContents :: UpdateMonad m => [String] -> FilePath -> Maybe String -> m ()-scanFileContents opts fpath mcts = Log.scope "file" $ hsdevLiftIO $ do-	dbval <- readDB-	fpath' <- liftIO $ canonicalizePath fpath-	ex <- liftIO $ doesFileExist fpath'-	mlocs <- if ex-		then do-			mloc <- case lookupFile fpath' dbval of-				Just m -> return $ view moduleLocation m-				Nothing -> do-					mproj <- liftIO $ locateProject fpath'-					return $ FileModule fpath' mproj-			return [(mloc, [], mcts)]-		else return []-	mapMOf_ (each . _1) (watch . flip watchModule) mlocs-	scan-		(Cache.loadFiles (== fpath'))-		(filterDB (inFile fpath') (const False) . standaloneDB)-		mlocs-		opts-		(scanModules opts)-	where-		inFile f = maybe False (== f) . preview (moduleIdLocation . moduleFile)---- | Scan cabal modules, doesn't rescan if already scanned-scanCabal :: UpdateMonad m => [String] -> m ()-scanCabal opts = Log.scope "cabal" $ do-	dbval <- readDB-	let-		scannedDbs = databasePackageDbs dbval-		unscannedDbs = filter ((`notElem` scannedDbs) . topPackageDb) $ reverse $ packageDbStacks userDb-	if null unscannedDbs-		then Log.sendLog Log.Trace $ "cabal (global-db and user-db) already scanned"-		else runTasks $ map (scanPackageDb opts) unscannedDbs---- | 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 $ buildDeps Nothing,-	runTask "configuring" sbox $ void $ Util.withCurrentDirectory dir $ configure Nothing]-	where-		dir = takeDirectory 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-	dbval <- readDB-	prepareSandbox sbox-	pdbs <- sandboxPackageDbStack sbox-	let-		scannedDbs = databasePackageDbs dbval-		unscannedDbs = filter ((`notElem` scannedDbs) . topPackageDb) $ reverse $ packageDbStacks pdbs-	if null unscannedDbs-		then Log.sendLog Log.Trace $ "sandbox already scanned"-		else runTasks $ map (scanPackageDb opts) unscannedDbs---- | 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-	watch (\w -> watchPackageDb w pdbs opts)-	mlocs <- liftM-		(filter (\mloc -> preview modulePackageDb mloc == Just (topPackageDb pdbs))) $-		listModules opts pdbs-	scan (Cache.loadPackageDb (topPackageDb pdbs)) (packageDbDB (topPackageDb pdbs)) ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do-		ms <- browseModules opts pdbs (mlocs' ^.. each . _1)-		docs <- liftIO $ hsdevLiftWith (ToolError "hdocs") $ hdocsCabal pdbs opts-		updater $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms-	where-		setDocs' :: Map String (Map String String) -> Module -> Module-		setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (T.unpack $ view moduleName m) docs---- | Scan project file-scanProjectFile :: UpdateMonad m => [String] -> FilePath -> m Project-scanProjectFile opts cabal = runTask "scanning" cabal $ do-	proj <- S.scanProjectFile opts cabal-	updater $ fromProject proj-	return proj---- | Scan project and related package-db stack-scanProjectStack :: UpdateMonad m => [String] -> FilePath -> 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] -> FilePath -> m ()-scanProject opts cabal = runTask "scanning" (project cabal) $ Log.scope "project" $ do-	proj <- scanProjectFile opts cabal-	watch (\w -> watchProject w proj opts)-	S.ScanContents _ [(_, sources)] _ <- S.enumProject proj-	scan (Cache.loadProject $ view projectCabal proj) (projectDB proj) sources opts $ scanModules opts---- | Scan directory for source files and projects-scanDirectory :: UpdateMonad m => [String] -> FilePath -> m ()-scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do-	S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory 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-	scan (Cache.loadFiles (dir `isParent`)) (filterDB inDir (const False) . standaloneDB) standSrcs opts $ scanModules opts-	where-		inDir = maybe False (dir `isParent`) . preview (moduleIdLocation . moduleFile)--scanContents :: UpdateMonad m => [String] -> S.ScanContents -> m ()-scanContents opts (S.ScanContents standSrcs projSrcs pdbss) = do-	dbval <- readDB-	let-		projs = databaseProjects dbval ^.. each . projectCabal-		pdbs = databasePackageDbs dbval-		files = allModules (standaloneDB dbval) ^.. each . moduleLocation . moduleFile-		srcs = standSrcs ^.. each . _1 . moduleFile-		inSrcs src = src `elem` srcs && src `notElem` files-		inFiles = maybe False inSrcs . preview (moduleIdLocation . moduleFile)-	mapMOf_ (each . _1 . projectCabal) (\p -> Log.sendLog Log.Trace ("scanning project: {}" ~~ p)) projSrcs-	runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs, view projectCabal p `notElem` projs]-	mapMOf_ (each . _1 . moduleFile) (\f -> Log.sendLog Log.Trace ("scanning file: {}" ~~ f)) standSrcs-	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs-	scan (Cache.loadFiles inSrcs) (filterDB inFiles (const False) . standaloneDB) standSrcs opts $ scanModules opts-	mapMOf_ each (\s -> Log.sendLog Log.Trace ("scanning package-db: {}" ~~ topPackageDb s)) pdbss-	runTasks [scanPackageDb opts pdbs' | pdbs' <- pdbss, topPackageDb pdbs' `notElem` pdbs]---- | Scan docs for inspected modules-scanDocs :: UpdateMonad m => [InspectedModule] -> m ()-scanDocs ims = do-	-- w <- liftIO $ ghcWorker ["-haddock"] (return ())-	-- w <- askSession sessionGhc-	runTasks $ map scanDocs' ims-	where-		scanDocs' im-			| not $ hasTag RefinedDocsTag im = runTask "scanning docs" (view inspectedId im) $ Log.scope "docs" $ do-				Log.sendLog Log.Trace $ "Scanning docs for {}" ~~  view inspectedId im-				im' <- (liftM (setTag RefinedDocsTag) $ S.scanModify doScan im)-					<|> return im-				Log.sendLog Log.Trace $ "Docs for {} updated: documented {} declarations" ~~-					view inspectedId im' ~~-					length (im' ^.. inspectionResult . _Right . moduleDeclarations . each . declarationDocs . _Just)-				updater $ fromModule im'-			| otherwise = Log.sendLog Log.Trace $ "Docs for {} already scanned" ~~ view inspectedId im-		doScan _ _ m = do-			w <- askSession sessionGhc-			liftIO $ inWorker w $ do-				opts' <- getModuleOpts [] m-				haddockSession opts'-				liftGhc $ inspectDocsGhc opts' m--inferModTypes :: UpdateMonad m => [InspectedModule] -> m ()-inferModTypes = runTasks . map inferModTypes' where-	inferModTypes' im-		| not $ hasTag InferredTypesTag im = runTask "inferring types" (view inspectedId im) $ Log.scope "docs" $ do-			w <- askSession sessionGhc-			Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view inspectedId im-			im' <- (liftM (setTag InferredTypesTag) $-				S.scanModify (\opts _ m -> liftIO (inWorker w (targetSession opts m >> inferTypes opts m Nothing))) im)-				<|> return im-			Log.sendLog Log.Trace $ "Types for {} inferred" ~~ view inspectedId im-			updater $ fromModule im'-		| otherwise = Log.sendLog Log.Trace $ "Types for {} already inferred" ~~ view inspectedId im---- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules.-scan :: UpdateMonad m-	=> (FilePath -> ExceptT String IO Structured)-	-- ^ Read data from cache-	-> (Database -> Database)-	-- ^ Get data from database-	-> [S.ModuleToScan]-	-- ^ Actual modules. Other modules will be removed from database-	-> [String]-	-- ^ Extra scan options-	-> ([S.ModuleToScan] -> m ())-	-- ^ Function to update changed modules-	-> m ()-scan cache' part' mlocs opts act = Log.scope "scan" $ do-	dbval <- getCache cache' part'-	let-		obsolete = filterDB (\m -> view moduleIdLocation m `notElem` (mlocs ^.. each . _1)) (const False) dbval-	changed <- liftIO $ S.changedModules dbval opts mlocs-	cleaner $ return obsolete-	act changed--updateEvent :: ServerMonadBase m => Watched -> Event -> UpdateM m ()-updateEvent (WatchedProject proj projOpts) e-	| isSource e = do-		Log.sendLog Log.Info $ "File '{file}' in project {proj} changed"-			~~ ("file" ~% view eventPath e)-			~~ ("proj" ~% view projectName proj)-		dbval <- readDB-		let-			opts = fromMaybe [] $ do-				m <- lookupFile (view eventPath e) dbval-				preview (inspection . inspectionOpts) $ getInspected dbval m-		scanFile opts $ view eventPath e-	| isCabal e = do-		Log.sendLog Log.Info $ "Project {proj} changed"-			~~ ("proj" ~% view projectName proj)-		scanProject projOpts $ view projectCabal proj-	| otherwise = return ()-updateEvent (WatchedPackageDb pdbs opts) e-	| isConf e = do-		Log.sendLog Log.Info $ "Package db {package} changed"-			~~ ("package" ~% topPackageDb pdbs)-		scanPackageDb opts pdbs-	| otherwise = return ()-updateEvent WatchedModule e-	| isSource e = do-		Log.sendLog Log.Info $ "Module {file} changed"-			~~ ("file" ~% view eventPath e)-		dbval <- readDB-		let-			opts = fromMaybe [] $ do-				m <- lookupFile (view eventPath e) dbval-				preview (inspection . inspectionOpts) $ getInspected dbval m-		scanFile opts $ view eventPath e-	| otherwise = return ()--processEvent :: UpdateOptions -> Watched -> Event -> ClientM IO ()-processEvent uopts w e = runUpdate uopts $ updateEvent w e--watch :: SessionMonad m => (Watcher -> IO ()) -> m ()-watch f = do-	w <- askSession sessionWatcher-	liftIO $ f w+{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses, RankNTypes, TypeOperators #-}
+{-# 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,
+
+	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 hiding ((.=))
+import Control.Monad.Catch (catch, handle, MonadThrow)
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State (get, modify, evalStateT)
+import Data.Aeson
+import Data.List (intercalate)
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Maybe
+import Data.Text (Text)
+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 (wait, 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')
+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:))
+
+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
+
+-- | 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
+		pdbs <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj
+		case mproj of
+			Just proj -> sendUpdateAction $ SQLite.updateProject proj (Just pdbs)
+			Nothing -> return ()
+		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
+				case (mfcts ^? _Just . _1) of
+					Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm
+					Nothing -> return ()
+				let
+					resetInspection = maybe id (set preloadedTime . fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1
+					mcts' = mplus mcts (mfcts ^? _Just . _2)
+				p <- liftIO $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mloc mcts'
+				return $ resetInspection p
+
+		ploaded <- runTasks (map pload ms')
+		mlocs' <- forM ploaded $ \p -> do
+			let
+				mloc = p ^. preloadedId . moduleLocation
+				inspectedMod = Inspected (p ^. preloadedTime) mloc (tag OnlyHeaderTag) $ Right $ p ^. asModule
+			sendUpdateAction $ Log.scope "preloaded" $ SQLite.updateModule inspectedMod
+			return mloc
+		updater mlocs'
+
+		(sqlMods', sqlAenv') <- do
+			let
+				mprojectDeps = SQLite.buildQuery $ SQLite.select_
+					["ps.module_id"]
+					["projects_modules_scope as ps"]
+					["ps.cabal is ?"]
+			sqlMods' <- SQLite.loadModules mprojectDeps (SQLite.Only $ mproj ^? _Just . projectCabal)
+			return (sqlMods', mconcat (map moduleAnalyzeEnv sqlMods'))
+
+		Log.sendLog Log.Trace $ "resolving environment: {} modules" ~~ length sqlMods'
+		case order ploaded of
+			Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err)
+			Right ordered -> do
+				ms'' <- flip evalStateT sqlAenv' $ runTasks (map inspect' ordered)
+				mlocs'' <- forM ms'' $ \im -> do
+					sendUpdateAction $ Log.scope "resolved" $ SQLite.updateModule im
+					return $ im ^. inspectedKey
+				updater mlocs''
+				where
+					inspect' pmod = runTask "scanning" (pmod ^. preloadedId . moduleLocation) $ Log.scope "module" $ do
+						aenv <- get
+						m <- either (hsdevError . InspectError) eval $ analyzePreloaded aenv pmod
+						modify (mappend (moduleAnalyzeEnv m))
+						return $ Inspected (pmod ^. preloadedTime) (m ^. moduleId . moduleLocation) mempty (Right m)
+	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.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) (map (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,
+	runTask "configuring" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.configure 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.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 $ do
+					mapM_ SQLite.updateModule 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.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 $ do
+					mapM_ SQLite.updateModule 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
+	sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj (Just pdbs)
+	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'
+			sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj' (Just pdbs)
+			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.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 $ \mlocs' -> do
+		scanModules opts mlocs'
+
+		-- 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.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.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 $ 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
+				opts' <- getModuleOpts [] m'
+				currentSession >>= maybe (return ()) (const clearTargets)
+				-- Calling haddock with targets set sometimes cause errors
+				haddockSession opts'
+				readModuleDocs opts' m'
+			sendUpdateAction $ 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 $ do
+		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' <- 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 == ?;" (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'
+
+		mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile)
+		types' <- inSessionGhc $ do
+			opts' <- getModuleOpts [] m'
+			targetSession opts' m'
+			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" $ 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
+
+watch :: SessionMonad m => (Watcher -> IO ()) -> m ()
+watch f = do
+	w <- askSession sessionWatcher
+	liftIO $ f w

@@ -1,8 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ConstraintKinds, FlexibleContexts, TemplateHaskell #-}
 
 module HsDev.Database.Update.Types (
-	Status(..), Progress(..), Task(..), UpdateOptions(..), UpdateM(..), UpdateMonad,
-	taskName, taskStatus, taskSubjectType, taskSubjectName, taskProgress, updateTasks, updateGhcOpts, updateDocs, updateInfer,
+	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
@@ -17,13 +20,17 @@ 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 qualified System.Log.Simple.Monad as Log
 
-import HsDev.Server.Types (ServerMonadBase, Session(..), CommandOptions(..), SessionMonad(..), askSession, CommandMonad(..), ClientM(..))
+import Control.Concurrent.Worker
+import HsDev.Database.SQLite
+import HsDev.Server.Types hiding (Command(..))
 import HsDev.Symbols
 import HsDev.Types
-import HsDev.Util ((.::))
+import HsDev.Util ((.::), logAll)
 
 data Status = StatusWorking | StatusOk | StatusError HsDevError
 
@@ -34,8 +41,8 @@ 
 instance FromJSON Status where
 	parseJSON v = msum $ map ($ v) [
-		withText "status" $ \t -> guard (t == "working") *> return StatusWorking,
-		withText "status" $ \t -> guard (t == "ok") *> return StatusOk,
+		withText "status" $ \t -> guard (t == "working") $> StatusWorking,
+		withText "status" $ \t -> guard (t == "ok") $> StatusOk,
 		liftM StatusError . parseJSON,
 		fail "invalid status"]
 
@@ -87,11 +94,36 @@ 
 makeLenses ''UpdateOptions
 
-type UpdateMonad m = (CommandMonad m, MonadReader UpdateOptions m, MonadWriter [ModuleLocation] m)
+data UpdateState = UpdateState {
+	_updateOptions :: UpdateOptions,
+	_updateWorker :: Worker (ServerM IO) }
 
-newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateOptions (WriterT [ModuleLocation] (ClientM m)) a }
-	deriving (Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask, Functor, MonadReader UpdateOptions, MonadWriter [ModuleLocation])
+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") enterTransaction logAll) (liftIO . joinWorker) $ \w ->
+		fn (UpdateState uopts w)
+	where
+		enterTransaction act = do
+			Log.sendLog Log.Trace "entering sqlite 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
+	s <- Log.askScope
+	liftIO $ inWorker w $ Log.localLog (Log.subLog mempty s) $ 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
 
@@ -101,6 +133,7 @@ 
 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
@@ -109,6 +142,6 @@ 	liftBase = UpdateM . liftBase
 
 instance MonadBaseControl b m => MonadBaseControl b (UpdateM m) where
-	type StM (UpdateM m) a = StM (ReaderT UpdateOptions (WriterT [ModuleLocation] (ClientM m))) a
+	type StM (UpdateM m) a = StM (ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m))) a
 	liftBaseWith f = UpdateM $ liftBaseWith (\f' -> f (f' . runUpdateM))
 	restoreM = UpdateM . restoreM

@@ -1,55 +1,78 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module HsDev.Display (-	Display(..)-	) where--import Control.Lens (view)-import Data.Maybe (fromMaybe)--import Text.Format--import HsDev.PackageDb-import HsDev.Project-import HsDev.Sandbox-import HsDev.Symbols.Location--class Display a where-	display :: a -> String-	displayType :: a -> String--instance Display PackageDb where-	display GlobalDb = "global-db"-	display UserDb = "user-db"-	display (PackageDb p) = "package-db " ++ p-	displayType _ = "package-db"--instance Display ModuleLocation where-	display (FileModule f _) = f-	display (InstalledModule _ _ n) = n-	display (ModuleSource s) = fromMaybe "" s-	displayType _ = "module"--instance Display Project where-	display = view projectName-	displayType _ = "project"--instance Display Sandbox where-	display (Sandbox _ fpath) = fpath-	displayType (Sandbox CabalSandbox _) = "cabal-sandbox"-	displayType (Sandbox StackWork _) = "stack-work"--instance Display FilePath where-	display = id-	displayType _ = "path"--instance Formattable PackageDb where-	formattable = formattable . display--instance Formattable ModuleLocation where-	formattable = formattable . display--instance Formattable Project where+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Display (
+	Display(..)
+	) where
+
+import Control.Lens (view)
+import Data.List (intercalate)
+import Data.Text.Lens (unpacked)
+
+import Text.Format
+
+import System.Directory.Paths
+import HsDev.PackageDb
+import HsDev.Project
+import HsDev.Sandbox
+import HsDev.Symbols.Location
+import HsDev.Symbols.Types
+
+class Display a where
+	display :: a -> String
+	displayType :: a -> String
+
+instance Display PackageDb where
+	display GlobalDb = "global-db"
+	display UserDb = "user-db"
+	display (PackageDb p) = "package-db " ++ display p
+	displayType _ = "package-db"
+
+instance Display PackageDbStack where
+	display = intercalate "/" . map display . packageDbs
+	displayType _ = "package-db-stack"
+
+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 Display ModuleTag where
+	display InferredTypesTag = "types"
+	display RefinedDocsTag = "docs"
+	display OnlyHeaderTag = "header"
+	displayType _ = "module-tag"
+
+instance Display Project where
+	display = view (projectName . unpacked)
+	displayType _ = "project"
+
+instance Display Sandbox where
+	display (Sandbox _ fpath) = display fpath
+	displayType (Sandbox CabalSandbox _) = "cabal-sandbox"
+	displayType (Sandbox StackWork _) = "stack-work"
+
+instance Display FilePath where
+	display = id
+	displayType _ = "path"
+
+instance Display Path where
+	display = view path
+	displayType _ = "path"
+
+instance Formattable PackageDb where
+	formattable = formattable . display
+
+instance Formattable PackageDbStack where
+	formattable = formattable . display
+
+instance Formattable ModuleLocation where
+	formattable = formattable . display
+
+instance Formattable Project where
+	formattable = formattable . display
+
+instance Formattable Sandbox where
 	formattable = formattable . display-

@@ -1,63 +1,53 @@-{-# LANGUAGE FlexibleContexts #-}--module HsDev.Error (-	hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevExcept, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore,-	hsdevHandle, hsdevLog,--	module HsDev.Types-	) where--import Prelude hiding (log)--import Control.Exception (IOException)-import Control.Monad.Catch-import Control.Monad.Except-import Data.String (fromString)-import System.Log.Simple (MonadLog, sendLog, Level)--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--hsdevExcept :: MonadCatch m => m a -> ExceptT HsDevError m a-hsdevExcept = ExceptT . hsdevCatch---- | 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---- | Log hsdev exception and rethrow-hsdevLog :: MonadLog m => Level -> m a -> m a-hsdevLog lev act = hsdevCatch act >>= either logError return where-	logError e = sendLog lev (fromString $ show e) >> hsdevError e+{-# 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

@@ -1,467 +1,450 @@-{-# LANGUAGE TypeSynonymInstances #-}--module HsDev.Inspect (-	analyzeModule, inspectDocsChunk, inspectDocs, inspectDocsGhc,-	inspectContents, contentsInspection,-	inspectFile, fileInspection,-	projectDirs, projectSources,-	inspectProject,-	getDefines,-	preprocess, preprocess_,--	module Control.Monad.Except-	) where--import Control.Arrow-import Control.Applicative-import Control.DeepSeq-import qualified Control.Exception as E-import Control.Lens (view, preview, set, over)-import Control.Lens.At (ix)-import Control.Monad-import Control.Monad.Except-import Data.Char (isSpace)-import Data.Function (on)-import Data.List-import Data.Map (Map)-import Data.Maybe (fromMaybe, mapMaybe, catMaybes, listToMaybe, isJust)-import Data.Ord (comparing)-import Data.String (IsString, fromString)-import Data.Text (Text)-import qualified Data.Text as T (unpack)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime)-import qualified Data.Map as M-import qualified Language.Haskell.Exts as H-import qualified Language.Preprocessor.Cpphs as Cpphs-import qualified System.Directory as Dir-import System.FilePath-import Data.Generics.Uniplate.Data-import HDocs.Haddock--import HsDev.Error-import HsDev.Symbols-import HsDev.Tools.Base-import HsDev.Tools.Ghc.Worker ()-import HsDev.Tools.HDocs (hdocsy, hdocs, hdocsProcess)-import HsDev.Util---- | Analize source contents-analyzeModule :: [String] -> Maybe FilePath -> String -> Either String Module-analyzeModule exts file source = case H.parseFileContentsWithMode (parseMode file exts) source' of-	H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason-	H.ParseOk (H.Module _ (Just (H.ModuleHead _ (H.ModuleName _ mname) _ mexports)) _ imports declarations) -> Right Module {-		_moduleName = fromString mname,-		_moduleDocs =  Nothing,-		_moduleLocation = ModuleSource Nothing,-		_moduleExports = fmap (concatMap getExports . getSpec) mexports,-		_moduleImports = map getImport imports,-		_moduleDeclarations = sortDeclarations $ getDecls declarations }-	_ -> Left "Unknown module"-	where-		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces-		source' = map untab source-		untab '\t' = ' '-		untab ch = ch-		getSpec (H.ExportSpecList _ es) = es---- | Analize source contents-analyzeModule_ :: [String] -> Maybe FilePath -> String -> Either String Module-analyzeModule_ exts file source = do-	mname <- parseModuleName source'-	return Module {-		_moduleName = fromString mname,-		_moduleDocs = Nothing,-		_moduleLocation = ModuleSource Nothing,-		_moduleExports = do-			H.PragmasAndModuleHead _ _ mhead <- parseModuleHead' source'-			H.ModuleHead _ _ _ mexports <- mhead-			H.ExportSpecList _ exports <- mexports-			return $ concatMap getExports exports,-		_moduleImports = map getImport $ mapMaybe (uncurry parseImport') parts,-		_moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts }-	where-		parts :: [(Int, String)]-		parts = zip offsets (map unlines parts') where-			parts' :: [[String]]-			parts' = unfoldr break' $ lines source'-			offsets = scanl (+) 0 $ map length parts'-		break' :: [String] -> Maybe ([String], [String])-		break' [] = Nothing-		break' (l:ls) = Just $ first (l:) $ span (maybe True isSpace . listToMaybe) ls--		parseModuleName :: String -> Either String String-		parseModuleName cts = maybe (Left "match fail") Right $ do-			g <- matchRx "^module\\s+([\\w\\.]+)" cts-			g 1--		parseDecl' :: Int -> String -> Maybe (H.Decl H.SrcSpanInfo)-		parseDecl' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $-			H.parseDeclWithMode (parseMode file exts) cts--		parseImport' :: Int -> String -> Maybe (H.ImportDecl H.SrcSpanInfo)-		parseImport' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $-			H.parseImportDeclWithMode (parseMode file exts) cts--		parseModuleHead' :: String -> Maybe (H.PragmasAndModuleHead H.SrcSpanInfo)-		parseModuleHead' = maybeResult . fmap H.unNonGreedy . H.parseWithMode (parseMode file exts)--		maybeResult :: H.ParseResult a -> Maybe a-		maybeResult (H.ParseFailed _ _) = Nothing-		maybeResult (H.ParseOk r) = Just r--		addOffset :: Int -> H.SrcSpan -> H.SrcSpan-		addOffset offset src = src { H.srcSpanStartLine = H.srcSpanStartLine src + offset, H.srcSpanEndLine = H.srcSpanEndLine src + offset }--		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces-		source' = map untab source-		untab '\t' = ' '-		untab ch = ch--parseMode :: Maybe FilePath -> [String] -> H.ParseMode-parseMode file exts = H.defaultParseMode {-	H.parseFilename = fromMaybe (H.parseFilename H.defaultParseMode) file,-	H.baseLanguage = H.Haskell2010,-	H.extensions = H.glasgowExts ++ map H.parseExtension exts,-	H.fixities = Just H.baseFixities }---- | Get exports-getExports :: H.ExportSpec H.SrcSpanInfo -> [Export]-getExports (H.EModuleContents _ (H.ModuleName _ m)) = [ExportModule $ fromString m]-getExports (H.EVar _ n) = [uncurry ExportName (identOfQName n) ThingNothing]-getExports (H.EAbs _ _ n) = [uncurry ExportName (identOfQName n) ThingNothing]-getExports (H.EThingWith _ _ n ns) = [uncurry ExportName (identOfQName n) $ ThingWith (map toStr ns)] where-	toStr :: H.CName H.SrcSpanInfo -> Text-	toStr (H.VarName _ cn) = identOfName cn-	toStr (H.ConName _ cn) = identOfName cn---- | Get import-getImport :: H.ImportDecl H.SrcSpanInfo -> Import-getImport d = Import-	(mname (H.importModule d))-	(H.importQualified d)-	(mname <$> H.importAs d)-	(importLst <$> H.importSpecs d)-	(Just $ toPosition $ H.ann d)-	where-		mname (H.ModuleName _ n) = fromString n-		importLst (H.ImportSpecList _ hiding specs) = ImportList hiding $ map impSpec specs-		impSpec (H.IVar _ n) = ImportSpec (identOfName n) ThingNothing-		impSpec (H.IAbs _ _ n) = ImportSpec (identOfName n) ThingNothing-		impSpec (H.IThingAll _ n) = ImportSpec (identOfName n) ThingAll-		impSpec (H.IThingWith _ n ns) = ImportSpec (identOfName n) $ ThingWith $ map identOfName (concatMap childrenBi ns :: [H.Name H.SrcSpanInfo])---- | Decl declarations-getDecls :: [H.Decl H.SrcSpanInfo] -> [Declaration]-getDecls decls =-	map mergeDecls .-	groupBy ((==) `on` view declarationName) .-	sortBy (comparing (view declarationName)) $-	concatMap getDecl decls ++ concatMap getDef decls-	where-		mergeDecls :: [Declaration] -> Declaration-		mergeDecls [] = error "Impossible"-		mergeDecls ds = Declaration-			(view declarationName $ head ds)-			Nothing-			Nothing-			(msum $ map (view declarationDocs) ds)-			(minimum <$> mapM (view declarationPosition) ds)-			(foldr1 mergeInfos $ map (view declaration) ds)--		mergeInfos :: DeclarationInfo -> DeclarationInfo -> DeclarationInfo-		mergeInfos (Function ln ld lr) (Function rn rd rr) = Function (ln `mplus` rn) (ld ++ rd) (lr `mplus` rr)-		mergeInfos l _ = l---- | Get local binds-getLocalDecls :: H.Decl H.SrcSpanInfo -> [Declaration]-getLocalDecls decl' = concatMap getDecls' binds' where-	binds' :: [H.Binds H.SrcSpanInfo]-	binds' = universeBi decl'-	getDecls' :: H.Binds H.SrcSpanInfo -> [Declaration]-	getDecls' (H.BDecls _ decls) = getDecls decls-	getDecls' _ = []---- | Get declaration and child declarations-getDecl :: H.Decl H.SrcSpanInfo -> [Declaration]-getDecl decl' = case decl' of-	H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ oneLinePrint typeSignature) [] Nothing) | n <- names]-	H.TypeDecl loc h _ -> [mkType loc (tyName h) Type (tyArgs h) `withDef` decl']-	H.DataDecl loc dataOrNew mctx h cons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getConDecl (tyName h) (tyArgs h)) cons-	H.GDataDecl loc dataOrNew mctx h _ gcons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getGConDecl) gcons-	H.ClassDecl loc ctx h _ _ -> [mkType loc (tyName h) (Class `withCtx` ctx) (tyArgs h) `withDef` decl']-	_ -> []-	where-		mkType :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> (TypeInfo -> DeclarationInfo) -> [H.TyVarBind H.SrcSpanInfo] -> Declaration-		mkType loc n ctor' args = setPosition loc $ decl (identOfName n) $ ctor' $ TypeInfo Nothing (map oneLinePrint args) Nothing []--		withDef :: H.Pretty a => Declaration -> a -> Declaration-		withDef tyDecl' tyDef = set (declaration . typeInfo . typeInfoDefinition) (Just $ prettyPrint tyDef) tyDecl'--		withCtx :: (TypeInfo -> DeclarationInfo) -> Maybe (H.Context H.SrcSpanInfo) -> TypeInfo -> DeclarationInfo-		withCtx ctor' mctx = ctor' . set typeInfoContext (fmap makeCtx mctx)--		ctor :: H.DataOrNew H.SrcSpanInfo -> TypeInfo -> DeclarationInfo-		ctor (H.DataType _) = Data-		ctor (H.NewType _) = NewType--		makeCtx ctx = fromString $ oneLinePrint ctx--		addRel :: H.Name H.SrcSpanInfo -> Declaration -> Declaration-		addRel n = set (declaration . related) (Just $ identOfName n)--		tyName :: H.DeclHead H.SrcSpanInfo -> H.Name H.SrcSpanInfo-		tyName (H.DHead _ n) = n-		tyName (H.DHInfix _ _ n) = n-		tyName (H.DHParen _ h) = tyName h-		tyName (H.DHApp _ h _) = tyName h--		tyArgs :: H.DeclHead H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo]-		tyArgs = universeBi---- | Get constructor and record fields declarations-getConDecl :: H.Name H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo] -> H.QualConDecl H.SrcSpanInfo -> [Declaration]-getConDecl t as (H.QualConDecl loc _ _ cdecl) = case cdecl of-	H.ConDecl _ n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ cts `tyFun` dataRes) [] Nothing)]-	H.InfixConDecl _ ct n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ (ct : [cts]) `tyFun` dataRes) [] Nothing)]-	H.RecDecl _ n fields -> mkFun loc n (Function (Just $ oneLinePrint $ map tyField fields `tyFun` dataRes) [] Nothing) : concatMap (getRec loc dataRes) fields-	where-		dataRes :: H.Type H.SrcSpanInfo-		dataRes = foldr (H.TyApp loc . H.TyVar loc . nameOf) (H.TyCon loc (H.UnQual loc t)) as where-			nameOf :: H.TyVarBind H.SrcSpanInfo -> H.Name H.SrcSpanInfo-			nameOf (H.KindedVar _ n' _) = n'-			nameOf (H.UnkindedVar _ n') = n'--tyField :: H.FieldDecl H.SrcSpanInfo -> H.Type H.SrcSpanInfo-tyField (H.FieldDecl _ _ t) = t---- | Get GADT constructor and record fields declarations-getGConDecl :: H.GadtDecl H.SrcSpanInfo -> [Declaration]-getGConDecl (H.GadtDecl loc n mfields r) = mkFun loc n (Function (Just $ oneLinePrint $ map tyField (fromMaybe [] mfields) `tyFun` r) [] Nothing) : concatMap (getRec loc r) (fromMaybe [] mfields)---- | Get record field declaration-getRec :: H.SrcSpanInfo -> H.Type H.SrcSpanInfo -> H.FieldDecl H.SrcSpanInfo -> [Declaration]-getRec loc t (H.FieldDecl _ ns rt) = [mkFun loc n (Function (Just $ oneLinePrint $ H.TyFun loc t rt) [] Nothing) | n <- ns]---- | Get definitions-getDef :: H.Decl H.SrcSpanInfo -> [Declaration]-getDef (H.FunBind _ []) = []-getDef d@(H.FunBind _ (m : _)) = [setPosition (H.ann m) $ decl (identOfName $ identOfMatch m) fun] where-	identOfMatch (H.Match _ n _ _ _) = n-	identOfMatch (H.InfixMatch _ _ n _ _ _) = n-	fun = Function Nothing (getLocalDecls d) Nothing-getDef d@(H.PatBind loc pat _ _) = map (\name -> setPosition loc (decl (identOfName name) (Function Nothing (getLocalDecls d) Nothing))) (names pat) where-	names :: H.Pat H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]-	names (H.PVar _ n) = [n]-	names (H.PNPlusK _ n _) = [n]-	names (H.PInfixApp _ l _ r) = names l ++ names r-	names (H.PApp _ _ ns) = concatMap names ns-	names (H.PTuple _ _ ns) = concatMap names ns-	names (H.PList _ ns) = concatMap names ns-	names (H.PParen _ n) = names n-	names (H.PRec _ _ pf) = concatMap fieldNames pf-	names (H.PAsPat _ n ns) = n : names ns-	names (H.PWildCard _) = []-	names (H.PIrrPat _ n) = names n-	names (H.PatTypeSig _ n _) = names n-	names (H.PViewPat _ _ n) = names n-	names (H.PBangPat _ n) = names n-	names _ = []--	fieldNames :: H.PatField H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]-	fieldNames (H.PFieldPat _ _ n) = names n-	fieldNames (H.PFieldPun _ n) = case n of-		H.Qual _ _ n' -> [n']-		H.UnQual _ n' -> [n']-		_ -> []-	fieldNames (H.PFieldWildcard _) = []-getDef _ = []---- | Make function declaration by location, name and function type-mkFun :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> DeclarationInfo -> Declaration-mkFun loc n = setPosition loc . decl (identOfName n)---- | Make function from arguments and result------ @[a, b, c...] `tyFun` r == a `TyFun` b `TyFun` c ... `TyFun` r@-tyFun :: [H.Type H.SrcSpanInfo] -> H.Type H.SrcSpanInfo -> H.Type H.SrcSpanInfo-tyFun as' r' = foldr (H.TyFun H.noSrcSpan) r' as'---- | Get name of qualified name-identOfQName :: H.QName H.SrcSpanInfo -> (Maybe Text, Text)-identOfQName (H.Qual _ (H.ModuleName _ mname) name) = (Just $ fromString mname, identOfName name)-identOfQName (H.UnQual _ name) = (Nothing, identOfName name)-identOfQName (H.Special _ sname) = (Nothing, fromString $ H.prettyPrint sname)---- | Get name of @H.Name@-identOfName :: H.Name H.SrcSpanInfo -> Text-identOfName name = fromString $ case name of-	H.Ident _ s -> s-	H.Symbol _ s -> s---- | 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---- | Print something-prettyPrint :: (H.Pretty a, IsString s) => a -> s-prettyPrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.PageMode }) mode' where-	mode' = H.PPHsMode {-		H.classIndent = 4,-		H.doIndent = 4,-		H.multiIfIndent = 4,-		H.caseIndent = 4,-		H.letIndent = 4,-		H.whereIndent = 4,-		H.onsideIndent = 2,-		H.spacing = False,-		H.layout = H.PPOffsideRule,-		H.linePragmas = False }---- | Convert @H.SrcSpanInfo@ to @Position-toPosition :: H.SrcSpanInfo -> Position-toPosition s = Position (H.startLine s) (H.startColumn s)---- | Set @Declaration@ position-setPosition :: H.SrcSpanInfo -> Declaration -> Declaration-setPosition loc = set declarationPosition (Just $ toPosition loc)---- | Adds documentation to declaration-addDoc :: Map String String -> Declaration -> Declaration-addDoc docsMap decl' = set declarationDocs (preview (ix (view declarationName decl')) docsMap') decl' 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 moduleDeclarations (map $ addDoc docsMap)---- | Extract files docs and set them to declarations-inspectDocsChunk :: [String] -> [Module] -> IO [Module]-inspectDocsChunk opts ms = hsdevLiftIOWith (ToolError "hdocs") $ do-	docsMaps <- hdocsy (map (view moduleLocation) ms) opts-	return $ zipWith addDocs docsMaps ms---- | Extract file docs and set them to module declarations-inspectDocs :: [String] -> Module -> IO Module-inspectDocs opts m = do-	let-		hdocsWorkaround = False-	docsMap <- if hdocsWorkaround-		then hdocsProcess (fromMaybe (T.unpack $ view moduleName m) (preview (moduleLocation . moduleFile) m)) opts-		else liftM Just $ hdocs (view moduleLocation m) opts-	return $ maybe id addDocs docsMap m---- | Like @inspectDocs@, but in @Ghc@ monad-inspectDocsGhc :: [String] -> Module -> Ghc Module-inspectDocsGhc opts m = case view moduleLocation m of-	FileModule fpath _ -> do-		docsMap <- liftM (fmap (formatDocs . snd) . listToMaybe) $ hsdevLift $ readSourcesGhc opts [fpath]-		return $ maybe id addDocs docsMap m-	_ -> hsdevError $ ModuleNotSource (view moduleLocation m)---- | Inspect contents-inspectContents :: String -> [(String, String)] -> [String] -> String -> ExceptT String IO InspectedModule-inspectContents name defines opts cts = inspect (ModuleSource $ Just name) (contentsInspection cts opts) $ do-	cts' <- lift $ preprocess_ defines exts name cts-	analyzed <- ExceptT $ return $ analyzeModule exts (Just name) cts' <|> analyzeModule_ exts (Just name) cts'-	return $ set moduleLocation (ModuleSource $ Just name) analyzed-	where-		exts = mapMaybe flagExtension opts--contentsInspection :: String -> [String] -> ExceptT String IO Inspection-contentsInspection _ _ = return InspectionNone -- crc or smth---- | Inspect file-inspectFile :: [(String, String)] -> [String] -> FilePath -> Maybe String -> IO InspectedModule-inspectFile defines opts file mcts = hsdevLiftIO $ do-	proj <- locateProject file-	absFilename <- Dir.canonicalizePath file-	ex <- Dir.doesFileExist absFilename-	unless ex $ hsdevError $ FileNotFound absFilename-	inspect (FileModule absFilename proj) ((if isJust mcts then fileContentsInspection else fileInspection) absFilename opts) $ do-		-- docsMap <- liftE $ if hdocsWorkaround-		-- 	then hdocsProcess absFilename opts-		-- 	else liftM Just $ hdocs (FileModule absFilename Nothing) opts-		forced <- hsdevLiftWith InspectError $ ExceptT $ E.handle onError $ do-			analyzed <- liftM (\s -> analyzeModule exts (Just absFilename) s <|> analyzeModule_ exts (Just absFilename) s) $-				maybe (readFileUtf8 absFilename >>= preprocess_ defines exts file) return mcts-			force analyzed `deepseq` return analyzed-		-- return $ setLoc absFilename proj . maybe id addDocs docsMap $ forced-		return $ set moduleLocation (FileModule absFilename proj) forced-	where-		onError :: E.ErrorCall -> IO (Either String Module)-		onError = return . Left . show--		exts = mapMaybe flagExtension opts---- | File inspection data-fileInspection :: FilePath -> [String] -> IO Inspection-fileInspection f opts = do-	tm <- Dir.getModificationTime f-	return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ sort $ ordNub opts---- | File contents inspection data-fileContentsInspection :: FilePath -> [String] -> IO Inspection-fileContentsInspection _ opts = do-	tm <- getPOSIXTime-	return $ InspectionAt tm $ sort $ ordNub opts---- | Enumerate project dirs-projectDirs :: Project -> IO [Extensions FilePath]-projectDirs p = do-	p' <- loadProject p-	return $ ordNub $ map (fmap (normalise . (view projectPath p' </>))) $ maybe [] sourceDirs $ view projectDescription p'---- | Enumerate project source files-projectSources :: Project -> IO [Extensions FilePath]-projectSources p = do-	dirs <- projectDirs p-	let-		enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory-		dirs' = map (view entity) dirs-	-- enum inner projects and dont consider them as part of this project-	subProjs <- liftM (delete (view projectPath p) . ordNub . concat) $ triesMap (enumCabals) dirs'-	let-		enumHs = liftM (filter thisProjectSource) . traverseDirectory-		thisProjectSource h = haskellSource h && not (any (`isParent` h) subProjs)-	liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (enumHs)) dirs---- | Inspect project-inspectProject :: [(String, String)] -> [String] -> Project -> IO (Project, [InspectedModule])-inspectProject defines opts p = hsdevLiftIO $ do-	p' <- loadProject p-	srcs <- projectSources p'-	modules <- mapM inspectFile' srcs-	return (p', catMaybes modules)-	where-		inspectFile' exts = liftM return (inspectFile defines (opts ++ extensionsOpts exts) (view entity exts) Nothing) <|> return Nothing---- | 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) $ lines cts-	where-		rx = "#define ([^\\s]+) (.*)"-		onIO :: E.IOException -> IO [(String, String)]-		onIO _ = return []--preprocess :: [(String, String)] -> FilePath -> String -> IO String-preprocess defines fpath cts = do-	cts' <- E.catch (Cpphs.cppIfdef fpath defines [] Cpphs.defaultBoolOptions cts) onIOError-	return $ unlines $ map snd cts'-	where-		onIOError :: E.IOException -> IO [(Cpphs.Posn, String)]-		onIOError _ = return []--preprocess_ :: [(String, String)] -> [String] -> FilePath -> String -> IO String-preprocess_ defines exts fpath cts-	| hasCPP = preprocess defines fpath cts-	| otherwise = return cts-	where-		exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions cts)-		hasCPP = H.EnableExtension H.CPP `elem` exts'+{-# LANGUAGE CPP, TypeSynonymInstances, ImplicitParams, TemplateHaskell #-}
+
+module HsDev.Inspect (
+	Preloaded(..), preloadedId, preloadedMode, preloadedModule, asModule, preloadedTime, preloaded, 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 Control.Monad.Except
+	) where
+
+import Control.DeepSeq
+import qualified Control.Exception as E
+import Control.Lens
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Except
+import Data.Data (Data)
+import Data.Function (on)
+import Data.List
+import Data.Map.Strict (Map)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Ord (comparing)
+import Data.String (IsString, fromString)
+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 Data.Generics.Uniplate.Data
+
+import HsDev.Display ()
+import HsDev.Error
+import HsDev.Symbols
+import HsDev.Symbols.Name (fromModuleName_)
+import HsDev.Symbols.Resolve (refineSymbol, refineTable, RefineTable, symbolUniqId)
+import HsDev.Symbols.Parsed hiding (file)
+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
+
+-- | Preloaded module with contents and extensions
+data Preloaded = Preloaded {
+	_preloadedId :: ModuleId,
+	_preloadedMode :: H.ParseMode,
+	_preloadedModule :: H.Module H.SrcSpanInfo,
+	-- ^ Loaded module head without declarations
+	_preloadedTime :: Inspection,
+	_preloaded :: Text }
+
+instance NFData Preloaded where
+	rnf (Preloaded mid _ _ insp cts) = rnf mid `seq` rnf insp `seq` rnf cts
+
+asModule :: Lens' Preloaded Module
+asModule = lens g' s' where
+	g' p = Module {
+		_moduleId = _preloadedId p,
+		_moduleDocs = Nothing,
+		_moduleImports = map (fromModuleName_ . void . H.importModule) 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) }
+
+-- | Preload module - load head and imports to get actual extensions and dependencies
+preload :: Text -> [(String, String)] -> [String] -> ModuleLocation -> Maybe Text -> IO Preloaded
+preload name defines opts mloc@(FileModule fpath mproj) Nothing = do
+	cts <- readFileUtf8 (view path fpath)
+	insp <- fileInspection fpath opts
+	let
+		srcExts = fromMaybe (takeDir fpath `withExtensions` mempty) $ do
+			proj <- mproj
+			findSourceDir proj fpath
+	p' <- preload name defines (opts ++ extensionsOpts srcExts) mloc (Just cts)
+	return $ p' { _preloadedTime = insp }
+preload _ _ _ mloc Nothing = hsdevError $ InspectError $
+	format "preload called non-sourced module: {}" ~~ mloc
+preload name defines opts mloc (Just 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')
+	when (H.isNullSpan $ H.srcInfoSpan l) $ hsdevError $ InspectError
+		(format "Error parsing module head and imports, file {}" ~~ view path fpath)
+	mname <- case mhead of
+		Just (H.ModuleHead _ (H.ModuleName _ nm) _ _) -> return $ fromString nm
+		_ -> hsdevError $ InspectError $ (format "Parsing module head and imports results in empty module name, file {}" ~~ view path fpath)
+	insp <- fileContentsInspection opts
+	return $ Preloaded {
+		_preloadedId = ModuleId mname mloc,
+		_preloadedMode = pmode,
+		_preloadedModule = H.Module l mhead mpragmas mimps [],
+		_preloadedTime = insp,
+		_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 (fromModuleName_ . void . H.importModule) 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) } }
+
+-- | 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
+
+-- | 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
+	docsMap <- if hdocsWorkaround
+		then liftIO $ hdocsProcess (fromMaybe (T.unpack $ view (moduleId . moduleName) m) (preview (moduleId . moduleLocation . moduleFile . path) m)) opts
+		else liftM Just $ hdocs (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 -> ExceptT String IO InspectedModule
+inspectContents name defines opts cts = inspect (OtherLocation name) (contentsInspection cts opts) $ do
+	p <- lift $ preload name defines opts (OtherLocation name) (Just cts)
+	analyzed <- ExceptT $ return $ analyzePreloaded mempty p
+	return $ set (moduleId . moduleLocation) (OtherLocation name) analyzed
+
+contentsInspection :: Text -> [String] -> ExceptT 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
+	inspect (FileModule absFilename mproj) (sourceInspection absFilename mcts opts) $ do
+		-- docsMap <- liftE $ if hdocsWorkaround
+		-- 	then hdocsProcess absFilename opts
+		-- 	else liftM Just $ hdocs (FileModule absFilename Nothing) opts
+		forced <- hsdevLiftWith InspectError $ ExceptT $ E.handle onError $ do
+			p <- preload absFilename defines opts (FileModule absFilename mproj) mcts
+			return $!! analyzePreloaded mempty p
+		-- return $ setLoc absFilename mproj . maybe id addDocs docsMap $ forced
+		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'
+
+dropScope :: Functor f => f (N.Scoped l) -> f l
+dropScope = fmap (\(N.Scoped _ a) -> a)
+
+makeLenses ''Preloaded
+makeLenses ''AnalyzeEnv