diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2013, Alexandr `Voidex` Ruchkin - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Alexandr `Voidex` Ruchkin nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2013, Alexandr `Voidex` Ruchkin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexandr `Voidex` Ruchkin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/data/hsdev.sql b/data/hsdev.sql --- a/data/hsdev.sql +++ b/data/hsdev.sql @@ -1,360 +1,360 @@ --- system table for various options, for now only version -create table hsdev ( - option text, - value json -); - --- packages per package-db -create table package_dbs ( - package_db text not null, -- global, user or path - package_name text not null, - package_version text not null -); - -create index package_names_index on package_dbs (package_db, package_name); - --- same as `package_dbs`, but only latest version of package left -create view latest_packages ( - package_db, - package_name, - package_version -) as -select package_db, package_name, max(package_version) -from package_dbs -group by package_db, package_name; - --- sandboxes -create table sandboxes ( - type text not null, -- cabal/stack - path text not null, -- sandbox path, should include `.cabal-sandbox`/`.stack-work` - package_db_stack json -- list of package-db of sandbox -); - -create unique index sandboxes_path_index on sandboxes (path); - --- source projects -create table projects ( - id integer primary key autoincrement, - name text not null, - cabal text not null, -- path to `.cabal` file - version text, - build_tool text not null, -- cabal/stack - package_db_stack json -- list of package-db -); - -create unique index projects_id_index on projects (id); -create unique index projects_cabal_index on projects (cabal); - --- project's library targets -create table libraries ( - project_id integer not null, - modules json not null, -- list of modules - build_info_id integer not null -); - -create unique index libraries_ids_index on libraries (project_id, build_info_id); - --- project's executables targets -create table executables ( - project_id integer not null, - name text not null, - path text not null, - build_info_id integer not null -); - -create unique index executables_ids_index on executables (project_id, build_info_id); - --- project's tests targets -create table tests ( - project_id integer not null, - name text not null, - enabled integer not null, - main text, - build_info_id integer not null -); - -create unique index tests_ids_index on tests (project_id, build_info_id); - --- map from project to build-info for all targets -create view targets ( - project_id, - build_info_id -) as -select project_id, build_info_id from libraries -union -select project_id, build_info_id from executables -union -select project_id, build_info_id from tests; - --- target build-info -create table build_infos( - id integer primary key autoincrement, - depends json not null, -- list of dependencies - language text, - extensions json not null, -- list of extensions - ghc_options json not null, -- list of ghc-options - source_dirs json not null, -- list of source directories - other_modules json not null -- list of other modules -); - -create unique index build_infos_id_index on build_infos (id); - --- project dependent packages -create view projects_deps ( - cabal, - package_db, - package_name, - package_version -) as -select distinct p.cabal, ps.package_db, ps.package_name, ps.package_version -from projects as p, json_each(p.package_db_stack) as pdb_stack, build_infos as b, json_each(b.depends) as deps, targets as t, latest_packages as ps -where - (p.id == t.project_id) and - (b.id == t.build_info_id) and - (deps.value <> p.name) and - (ps.package_name == deps.value) and - (ps.package_db == pdb_stack.value); - --- packages in scope of project --- `cabal` may be null for standalone files, in this case all 'user-db' is in scope -create view projects_modules_scope ( - cabal, - module_id -) as -select pdbs.cabal, m.id -from projects_deps as pdbs, modules as m -where - (m.package_name == pdbs.package_name) and - (m.package_version == pdbs.package_version) and - m.exposed -union -select p.cabal, m.id -from projects as p, modules as m -where (m.cabal == p.cabal) -union -select null, m.id -from modules as m, latest_packages as ps -where - (m.package_name == ps.package_name) and - (m.package_version == ps.package_version) and - m.exposed and - (ps.package_db in ('user-db', 'global-db')); - --- symbols -create table symbols ( - id integer primary key autoincrement, - name text not null, - module_id integer not null, -- definition module - docs text, - line integer, -- line of definition - column integer, -- column of definition - what text not null, -- kind of symbol: function, method, ... - type text, -- type of function/method/... - parent text, -- parent of selector/method/... - constructors json, -- list of constructors for selector - args json, -- list of arguments for types - context json, -- list of contexts for types - associate text, -- associates for families - pat_type text, - pat_constructor text -); - -create unique index symbols_id_index on symbols (id); -create unique index symbols_index on symbols (module_id, name, what); - --- modules -create table modules ( - id integer primary key autoincrement, - -- source module location - file text, -- source file - cabal text, -- related project's `.cabal` - -- installed module location - install_dirs json, -- list of paths - package_name text, -- package name of module - package_version text, -- package version - installed_name text, -- if not null, should be equal to name - exposed integer, -- is module exposed or hidden - -- some other location - other_location text, -- anything - - name text, - docs text, - fixities json, -- list of fixities - tags json, -- dict of tags, value not used, tag is set if present; used by hsdev to mark if types was inferred or docs scanned - inspection_error text, - inspection_time real, - inspection_opts json -- list of flags -); - -create unique index modules_id_index on modules (id); -create index modules_name_index on modules (name); -create unique index modules_file_index on modules (file) where file is not null; -create unique index modules_installed_index on modules (package_name, package_version, installed_name) where - package_name is not null and - package_version is not null and - installed_name is not null; -create unique index modules_other_locations_index on modules (other_location) where other_location is not null; - --- module import statements -create table imports ( - module_id integer not null, - line integer not null, -- line number of import - column integer not null, -- column of impoty - module_name text not null, -- import module name - qualified integer not null, -- is import qualified - alias text, -- imported with `as` - hiding integer, -- is list hiding - import_list json, -- list of import specs, null if not specified - import_module_id -- `id` of imported module -); - -create unique index imports_position_index on imports (module_id, line, column); - --- symbols bringed into scope by import, with qualifier -create view imported_scopes as -select i.*, q.value as qualifier, s.name as name, s.id as symbol_id -from imports as i, json_each(case when i.qualified then json_array(ifnull(i.alias, i.module_name)) else json_array(ifnull(i.alias, i.module_name), null) end) as q, symbols as s, exports as e -where - e.module_id == i.import_module_id and - e.symbol_id == s.id and - (i.import_list is null or (s.name in (select json_extract(import_list_item.value, '$.name') from json_each(i.import_list) as import_list_item) == not i.hiding)); - --- module exports -create table exports ( - module_id integer not null, - symbol_id integer not null -); - -create index exports_module_id_index on exports (module_id); - --- source file module's symbols in scope -create table scopes ( - module_id integer not null, - qualifier text, - name text not null, - symbol_id integer not null -); - -create index scopes_name_index on scopes (module_id, name); - --- like `scopes`, but with column `completion` with fully qualified name -create view completions ( - module_id, - completion, - qualifier, - symbol_id -) as -select id, (case when sc.qualifier is null then sc.name else sc.qualifier || '.' || sc.name end) as full_name, sc.qualifier, sc.symbol_id -from modules as m, scopes as sc -where (m.id == sc.module_id); - --- resolved names in module -create table names ( - module_id integer not null, - qualifier text, -- name qualifier - name text not null, -- name - line integer not null, -- line of name - column integer not null, -- column of name - line_to integer not null, -- line of name end - column_to integer not null, -- column of name end - def_line integer, -- name definition line, for local names - def_column integer, -- name definition column, for local names - inferred_type text, -- inferred name type, set by hsdev - resolved_module text, -- resolved module name, for global and top-level names - resolved_name text, -- resolved name, for global and top-level names - resolved_what text, -- resolved symbol kind - resolve_error text, - symbol_id integer -- resolved symbol id -); - -create unique index names_position_index on names (module_id, line, column, line_to, column_to); -create index names_name_index on names (module_id, name); - --- like `names`, but with definition position set for both local and global names -create view definitions ( - module_id, - name, - line, - column, - line_to, - column_to, - def_module_id, - def_line, - def_column, - local -) as -select module_id, name, line, column, line_to, column_to, module_id, def_line, def_column, 1 -from names -where def_line is not null and def_column is not null -union -select n.module_id, n.resolved_name, n.line, n.column, n.line_to, n.column_to, s.module_id, s.line, s.column, 0 -from names as n, modules as srcm, modules as m, symbols as s -where - (n.module_id == srcm.id) and - (n.symbol_id == s.id) and - (m.name == n.resolved_module) and - (s.module_id == m.id) and - (s.name == n.resolved_name); - --- sources dependencies relations -create view sources_depends ( - module_id, - module_file, - depends_id, - depends_file -) as -select m.id, m.file, im.id, im.file -from modules as im, imports as i, modules as m, projects_modules_scope as ps -where - (m.cabal is ps.cabal) and - (ps.module_id == im.id) and - (i.module_id == m.id) and - (im.name == i.module_name) and - (m.file is not null) and - (im.file is not null); - --- expressions types -create table types ( - module_id integer not null, - line integer not null, -- line of expression - column integer not null, -- column of expression - line_to integer not null, -- line of expression end - column_to integer not null, -- column of expression end - expr text not null, -- expression contents - type text not null -- expression type -); - -create unique index types_position_index on types (module_id, line, column, line_to, column_to); - --- modified file contents, hsdev will use it in commands whenever it is newer than file -create table file_contents ( - file text not null, -- file path - contents text not null, -- file contents - mtime real not null -- posix modification time -); - -create unique index file_contents_index on file_contents (file); - --- table with last time of loading module -create table load_times ( - module_id integer not null, -- module affected - load_time real not null -- timestamp -); - -create unique index load_times_module_id_index on load_times (module_id); - --- table with ghc warnings on file --- sequential call to load module won't actually reload file and won't produce warnings --- but we want to see them again -create table messages ( - module_id integer not null, - line integer not null, - column integer not null, - line_to integer not null, - column_to integer not null, - severity text, - message text not null, - suggestion text -); - -create index messages_module_id_index on messages (module_id); +-- system table for various options, for now only version +create table hsdev ( + option text, + value json +); + +-- packages per package-db +create table package_dbs ( + package_db text not null, -- global, user or path + package_name text not null, + package_version text not null +); + +create index package_names_index on package_dbs (package_db, package_name); + +-- same as `package_dbs`, but only latest version of package left +create view latest_packages ( + package_db, + package_name, + package_version +) as +select package_db, package_name, max(package_version) +from package_dbs +group by package_db, package_name; + +-- sandboxes +create table sandboxes ( + type text not null, -- cabal/stack + path text not null, -- sandbox path, should include `.cabal-sandbox`/`.stack-work` + package_db_stack json -- list of package-db of sandbox +); + +create unique index sandboxes_path_index on sandboxes (path); + +-- source projects +create table projects ( + id integer primary key autoincrement, + name text not null, + cabal text not null, -- path to `.cabal` file + version text, + build_tool text not null, -- cabal/stack + package_db_stack json -- list of package-db +); + +create unique index projects_id_index on projects (id); +create unique index projects_cabal_index on projects (cabal); + +-- project's library targets +create table libraries ( + project_id integer not null, + modules json not null, -- list of modules + build_info_id integer not null +); + +create unique index libraries_ids_index on libraries (project_id, build_info_id); + +-- project's executables targets +create table executables ( + project_id integer not null, + name text not null, + path text not null, + build_info_id integer not null +); + +create unique index executables_ids_index on executables (project_id, build_info_id); + +-- project's tests targets +create table tests ( + project_id integer not null, + name text not null, + enabled integer not null, + main text, + build_info_id integer not null +); + +create unique index tests_ids_index on tests (project_id, build_info_id); + +-- map from project to build-info for all targets +create view targets ( + project_id, + build_info_id +) as +select project_id, build_info_id from libraries +union +select project_id, build_info_id from executables +union +select project_id, build_info_id from tests; + +-- target build-info +create table build_infos( + id integer primary key autoincrement, + depends json not null, -- list of dependencies + language text, + extensions json not null, -- list of extensions + ghc_options json not null, -- list of ghc-options + source_dirs json not null, -- list of source directories + other_modules json not null -- list of other modules +); + +create unique index build_infos_id_index on build_infos (id); + +-- project dependent packages +create view projects_deps ( + cabal, + package_db, + package_name, + package_version +) as +select distinct p.cabal, ps.package_db, ps.package_name, ps.package_version +from projects as p, json_each(p.package_db_stack) as pdb_stack, build_infos as b, json_each(b.depends) as deps, targets as t, latest_packages as ps +where + (p.id == t.project_id) and + (b.id == t.build_info_id) and + (deps.value <> p.name) and + (ps.package_name == deps.value) and + (ps.package_db == pdb_stack.value); + +-- packages in scope of project +-- `cabal` may be null for standalone files, in this case all 'user-db' is in scope +create view projects_modules_scope ( + cabal, + module_id +) as +select pdbs.cabal, m.id +from projects_deps as pdbs, modules as m +where + (m.package_name == pdbs.package_name) and + (m.package_version == pdbs.package_version) and + m.exposed +union +select p.cabal, m.id +from projects as p, modules as m +where (m.cabal == p.cabal) +union +select null, m.id +from modules as m, latest_packages as ps +where + (m.package_name == ps.package_name) and + (m.package_version == ps.package_version) and + m.exposed and + (ps.package_db in ('user-db', 'global-db')); + +-- symbols +create table symbols ( + id integer primary key autoincrement, + name text not null, + module_id integer not null, -- definition module + docs text, + line integer, -- line of definition + column integer, -- column of definition + what text not null, -- kind of symbol: function, method, ... + type text, -- type of function/method/... + parent text, -- parent of selector/method/... + constructors json, -- list of constructors for selector + args json, -- list of arguments for types + context json, -- list of contexts for types + associate text, -- associates for families + pat_type text, + pat_constructor text +); + +create unique index symbols_id_index on symbols (id); +create unique index symbols_index on symbols (module_id, name, what); + +-- modules +create table modules ( + id integer primary key autoincrement, + -- source module location + file text, -- source file + cabal text, -- related project's `.cabal` + -- installed module location + install_dirs json, -- list of paths + package_name text, -- package name of module + package_version text, -- package version + installed_name text, -- if not null, should be equal to name + exposed integer, -- is module exposed or hidden + -- some other location + other_location text, -- anything + + name text, + docs text, + fixities json, -- list of fixities + tags json, -- dict of tags, value not used, tag is set if present; used by hsdev to mark if types was inferred or docs scanned + inspection_error text, + inspection_time real, + inspection_opts json -- list of flags +); + +create unique index modules_id_index on modules (id); +create index modules_name_index on modules (name); +create unique index modules_file_index on modules (file) where file is not null; +create unique index modules_installed_index on modules (package_name, package_version, installed_name) where + package_name is not null and + package_version is not null and + installed_name is not null; +create unique index modules_other_locations_index on modules (other_location) where other_location is not null; + +-- module import statements +create table imports ( + module_id integer not null, + line integer not null, -- line number of import + column integer not null, -- column of impoty + module_name text not null, -- import module name + qualified integer not null, -- is import qualified + alias text, -- imported with `as` + hiding integer, -- is list hiding + import_list json, -- list of import specs, null if not specified + import_module_id -- `id` of imported module +); + +create unique index imports_position_index on imports (module_id, line, column); + +-- symbols bringed into scope by import, with qualifier +create view imported_scopes as +select i.*, q.value as qualifier, s.name as name, s.id as symbol_id +from imports as i, json_each(case when i.qualified then json_array(ifnull(i.alias, i.module_name)) else json_array(ifnull(i.alias, i.module_name), null) end) as q, symbols as s, exports as e +where + e.module_id == i.import_module_id and + e.symbol_id == s.id and + (i.import_list is null or (s.name in (select json_extract(import_list_item.value, '$.name') from json_each(i.import_list) as import_list_item) == not i.hiding)); + +-- module exports +create table exports ( + module_id integer not null, + symbol_id integer not null +); + +create index exports_module_id_index on exports (module_id); + +-- source file module's symbols in scope +create table scopes ( + module_id integer not null, + qualifier text, + name text not null, + symbol_id integer not null +); + +create index scopes_name_index on scopes (module_id, name); + +-- like `scopes`, but with column `completion` with fully qualified name +create view completions ( + module_id, + completion, + qualifier, + symbol_id +) as +select id, (case when sc.qualifier is null then sc.name else sc.qualifier || '.' || sc.name end) as full_name, sc.qualifier, sc.symbol_id +from modules as m, scopes as sc +where (m.id == sc.module_id); + +-- resolved names in module +create table names ( + module_id integer not null, + qualifier text, -- name qualifier + name text not null, -- name + line integer not null, -- line of name + column integer not null, -- column of name + line_to integer not null, -- line of name end + column_to integer not null, -- column of name end + def_line integer, -- name definition line, for local names + def_column integer, -- name definition column, for local names + inferred_type text, -- inferred name type, set by hsdev + resolved_module text, -- resolved module name, for global and top-level names + resolved_name text, -- resolved name, for global and top-level names + resolved_what text, -- resolved symbol kind + resolve_error text, + symbol_id integer -- resolved symbol id +); + +create unique index names_position_index on names (module_id, line, column, line_to, column_to); +create index names_name_index on names (module_id, name); + +-- like `names`, but with definition position set for both local and global names +create view definitions ( + module_id, + name, + line, + column, + line_to, + column_to, + def_module_id, + def_line, + def_column, + local +) as +select module_id, name, line, column, line_to, column_to, module_id, def_line, def_column, 1 +from names +where def_line is not null and def_column is not null +union +select n.module_id, n.resolved_name, n.line, n.column, n.line_to, n.column_to, s.module_id, s.line, s.column, 0 +from names as n, modules as srcm, modules as m, symbols as s +where + (n.module_id == srcm.id) and + (n.symbol_id == s.id) and + (m.name == n.resolved_module) and + (s.module_id == m.id) and + (s.name == n.resolved_name); + +-- sources dependencies relations +create view sources_depends ( + module_id, + module_file, + depends_id, + depends_file +) as +select m.id, m.file, im.id, im.file +from modules as im, imports as i, modules as m, projects_modules_scope as ps +where + (m.cabal is ps.cabal) and + (ps.module_id == im.id) and + (i.module_id == m.id) and + (im.name == i.module_name) and + (m.file is not null) and + (im.file is not null); + +-- expressions types +create table types ( + module_id integer not null, + line integer not null, -- line of expression + column integer not null, -- column of expression + line_to integer not null, -- line of expression end + column_to integer not null, -- column of expression end + expr text not null, -- expression contents + type text not null -- expression type +); + +create unique index types_position_index on types (module_id, line, column, line_to, column_to); + +-- modified file contents, hsdev will use it in commands whenever it is newer than file +create table file_contents ( + file text not null, -- file path + contents text not null, -- file contents + mtime real not null -- posix modification time +); + +create unique index file_contents_index on file_contents (file); + +-- table with last time of loading module +create table load_times ( + module_id integer not null, -- module affected + load_time real not null -- timestamp +); + +create unique index load_times_module_id_index on load_times (module_id); + +-- table with ghc warnings on file +-- sequential call to load module won't actually reload file and won't produce warnings +-- but we want to see them again +create table messages ( + module_id integer not null, + line integer not null, + column integer not null, + line_to integer not null, + column_to integer not null, + severity text, + message text not null, + suggestion text +); + +create index messages_module_id_index on messages (module_id); diff --git a/hsdev.cabal b/hsdev.cabal --- a/hsdev.cabal +++ b/hsdev.cabal @@ -1,261 +1,261 @@ -name: hsdev -version: 0.3.3.0 -synopsis: Haskell development library -description: - Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc. -homepage: https://github.com/mvoidex/hsdev -license: BSD3 -license-file: LICENSE -author: Alexandr `Voidex` Ruchkin -maintainer: voidex@live.com --- copyright: -category: Development -build-type: Simple -cabal-version: >=1.8 -extra-source-files: - tests/test-package/*.hs - tests/test-package/test-package.cabal - tests/data/base.sql - tests/data/ModuleTwo.modified.hs - tests/data/ModuleTwo.broken.hs - data/hsdev.sql - -source-repository head - type: git - location: git://github.com/mvoidex/hsdev.git - -flag docs - description: build with haddock/hdocs to support scanning docs - default: True - -flag hlint - description: build with hlint to support linting - default: True - -library - hs-source-dirs: src - ghc-options: -Wall -fno-warn-tabs - - if !flag(docs) - cpp-options: -DNODOCS - - if !flag(hlint) - cpp-options: -DNOHLINT - - exposed-modules: - Control.Apply.Util - Control.Concurrent.FiniteChan - Control.Concurrent.Worker - Control.Concurrent.Util - Data.Deps - Data.Help - Data.Lisp - Data.Maybe.JustIf - Data.LookupTable - HsDev - HsDev.Client.Commands - HsDev.Database.SQLite - HsDev.Database.SQLite.Instances - HsDev.Database.SQLite.Schema - HsDev.Database.SQLite.Schema.TH - HsDev.Database.SQLite.Select - HsDev.Database.SQLite.Transaction - HsDev.Database.Update - HsDev.Database.Update.Types - HsDev.Display - HsDev.Error - HsDev.Inspect - HsDev.Inspect.Definitions - HsDev.Inspect.Order - HsDev.Inspect.Resolve - HsDev.Inspect.Types - HsDev.PackageDb - HsDev.PackageDb.Types - HsDev.Project - HsDev.Project.Compat - HsDev.Project.Types - HsDev.Scan - HsDev.Scan.Browse - HsDev.Server.Base - HsDev.Server.Commands - HsDev.Server.Message - HsDev.Server.Message.Lisp - HsDev.Server.Types - HsDev.Sandbox - HsDev.Stack - HsDev.Symbols - HsDev.Symbols.Name - HsDev.Symbols.Class - HsDev.Symbols.HaskellNames - HsDev.Symbols.Location - HsDev.Symbols.Documented - HsDev.Symbols.Resolve - HsDev.Symbols.Parsed - HsDev.Symbols.Types - HsDev.Tools.AutoFix - HsDev.Tools.Base - HsDev.Tools.Cabal - HsDev.Tools.ClearImports - HsDev.Tools.Ghc.Base - HsDev.Tools.Ghc.Check - HsDev.Tools.Ghc.Compat - HsDev.Tools.Ghc.MGhc - HsDev.Tools.Ghc.Prelude - HsDev.Tools.Ghc.Repl - HsDev.Tools.Ghc.Session - HsDev.Tools.Ghc.System - HsDev.Tools.Ghc.Types - HsDev.Tools.Ghc.Worker - HsDev.Tools.Hayoo - HsDev.Tools.HDocs - HsDev.Tools.HLint - HsDev.Tools.Refact - HsDev.Tools.Tabs - HsDev.Tools.Types - HsDev.Types - HsDev.Util - HsDev.Version - HsDev.Watcher - HsDev.Watcher.Types - System.Directory.Paths - System.Directory.Watcher - - if os(windows) - build-depends: - Win32 >= 2.3.0 - exposed-modules: - System.Win32.PowerShell - System.Win32.FileMapping.NamePool - System.Win32.FileMapping.Memory - else - build-depends: - unix >= 2.7.2.0 && < 2.8 - - if impl(ghc >= 8.6) && impl(ghc < 8.7) - build-depends: - ghc == 8.6.*, - Cabal == 2.4.* - - if impl(ghc >= 8.4) && impl(ghc < 8.5) - build-depends: - ghc == 8.4.*, - Cabal == 2.2.0.1 - - if impl(ghc >= 8.2) && impl(ghc < 8.3) - build-depends: - ghc == 8.2.*, - Cabal == 2.0.1.1 - - if impl(ghc >= 8.0) && impl(ghc < 8.2) - build-depends: - ghc >= 8.0.0 && < 8.1.0, - Cabal >= 1.24.2.0 && < 2.0 - - if flag(docs) - build-depends: - hdocs >= 0.5.2, - haddock-api >= 2.17.4, - haddock-library >= 1.4.3 && < 1.8 - - if flag(hlint) - build-depends: - hlint >= 2.0.11 && < 2.2 - - -- Build dependency lower bound is set for GHC 8.0.1. - -- Upper bound is set for GHC 8.4 - build-depends: - base >= 4.9 && < 5, - aeson >= 1.2.4.0 && < 1.5, - aeson-pretty >= 0.8.2 && < 0.9, - array >= 0.5.1.1 && < 0.6, - async >= 2.1.1.1 && < 2.3, - attoparsec >= 0.13.1.0 && < 0.14, - bytestring >= 0.10.8.1 && < 0.11, - containers >= 0.5.7.1 && < 0.7, - cpphs >= 1.20.5 && < 1.21, - data-default >= 0.7.1.1 && < 0.8, - deepseq >= 1.4.2.0 && < 1.5, - direct-sqlite >= 2.3.19 && < 2.4, - directory >= 1.2.6.2 && < 1.4, - exceptions >= 0.8.3 && < 0.11, - filepath >= 1.4.1.0 && < 1.5, - fsnotify >= 0.2.1 && < 0.4, - ghc-boot >= 8.0.1 && < 8.7, - ghc-paths >= 0.1.0.9 && < 0.2, - haskell-names >= 0.9.1 && < 0.10.0, - haskell-src-exts >= 1.19.1 && < 1.22.0, - hformat >= 0.1.0.1 && < 0.4, - hlint >= 2.0.11 && < 2.2, - http-client >= 0.5 && < 0.7, - lens >= 4.14 && < 4.18, - lifted-base >= 0.2.3.10 && < 0.3, - mmorph >= 1.0.9 && < 1.2, - monad-control >= 1.0.1.0 && < 1.1, - monad-loops >= 0.4.3 && < 0.5, - mtl >= 2.2.1 && < 2.3, - network >= 3.0 && < 3.1, - network-uri >= 2.6 && < 2.7, - optparse-applicative >= 0.12.1.0 && < 0.15, - process >= 1.4.2.0 && < 1.7, - regex-pcre-builtin >= 0.94.4 && < 0.95, - scientific >= 0.3.4.9 && < 0.4, - simple-log >= 0.9.9 && < 0.10, - sqlite-simple >= 0.4.13.0 && < 0.5, - stm >= 2.4 && < 2.6, - syb >= 0.6 && < 0.8, - template-haskell >= 2.11.0 && < 2.15, - text >= 1.2.2.2 && < 1.3, - text-region >= 0.1.0.1 && < 0.4, - time >= 1.6.0.1 && < 1.9, - transformers >= 0.5.2.0 && < 0.6, - transformers-base >= 0.4.4 && < 0.5, - uniplate >= 1.6.12 && < 1.7, - unordered-containers >= 0.2.8.0 && < 0.3, - vector >= 0.11.0.0 && < 0.13 - -executable hsdev - main-is: hsdev.hs - hs-source-dirs: tools - ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4" - - build-depends: - hsdev, - base >= 4.9 && < 5, - aeson >= 1.2.4.0 && < 1.5, - aeson-pretty >= 0.8.2 && < 0.9, - bytestring >= 0.10.8.1 && < 0.11, - containers >= 0.5.7.1 && < 0.7, - deepseq >= 1.4.2.0 && < 1.5, - directory >= 1.2.6.2 && < 1.4, - exceptions >= 0.8.3 && < 0.11, - filepath >= 1.4.1.0 && < 1.5, - monad-loops >= 0.4.3 && < 0.5, - mtl >= 2.2.1 && < 2.3, - network >= 3.0 && < 3.1, - optparse-applicative >= 0.12.1.0 && < 0.15, - process >= 1.4.2.0 && < 1.7, - text >= 1.2.2.2 && < 1.3, - transformers >= 0.5.2.0 && < 0.6, - unordered-containers >= 0.2.8.0 && < 0.3 - -test-suite test - main-is: Test.hs - hs-source-dirs: tests - ghc-options: -threaded -Wall -fno-warn-tabs - type: exitcode-stdio-1.0 - build-depends: - hsdev, - base >= 4.9 && < 5, - aeson >= 1.2.4.0 && < 1.5, - lens-aeson >= 1.0 && < 1.1, - async >= 2.1.1.1 && < 2.3, - containers >= 0.5.7.1 && < 0.7, - data-default >= 0.7.1.1 && < 0.8, - deepseq >= 1.4.2.0 && < 1.5, - directory >= 1.2.6.2 && < 1.4, - filepath >= 1.4.1.0 && < 1.5, - hformat >= 0.1.0.1 && < 0.4, - hspec >= 2.2.4, - lens >= 4.14 && < 4.18, - mtl >= 2.2.1 && < 2.3, - text >= 1.2.2.2 && < 1.3 +name: hsdev +version: 0.3.3.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 + tests/data/base.sql + tests/data/ModuleTwo.modified.hs + tests/data/ModuleTwo.broken.hs + data/hsdev.sql + +source-repository head + type: git + location: git://github.com/mvoidex/hsdev.git + +flag docs + description: build with haddock/hdocs to support scanning docs + default: True + +flag hlint + description: build with hlint to support linting + default: True + +library + hs-source-dirs: src + ghc-options: -Wall -fno-warn-tabs + + if !flag(docs) + cpp-options: -DNODOCS + + if !flag(hlint) + cpp-options: -DNOHLINT + + exposed-modules: + Control.Apply.Util + Control.Concurrent.FiniteChan + Control.Concurrent.Worker + Control.Concurrent.Util + Data.Deps + Data.Help + Data.Lisp + Data.Maybe.JustIf + Data.LookupTable + HsDev + HsDev.Client.Commands + HsDev.Database.SQLite + HsDev.Database.SQLite.Instances + HsDev.Database.SQLite.Schema + HsDev.Database.SQLite.Schema.TH + HsDev.Database.SQLite.Select + HsDev.Database.SQLite.Transaction + HsDev.Database.Update + HsDev.Database.Update.Types + HsDev.Display + HsDev.Error + HsDev.Inspect + HsDev.Inspect.Definitions + HsDev.Inspect.Order + HsDev.Inspect.Resolve + HsDev.Inspect.Types + HsDev.PackageDb + HsDev.PackageDb.Types + HsDev.Project + HsDev.Project.Compat + HsDev.Project.Types + HsDev.Scan + HsDev.Scan.Browse + HsDev.Server.Base + HsDev.Server.Commands + HsDev.Server.Message + HsDev.Server.Message.Lisp + HsDev.Server.Types + HsDev.Sandbox + HsDev.Stack + HsDev.Symbols + HsDev.Symbols.Name + HsDev.Symbols.Class + HsDev.Symbols.HaskellNames + HsDev.Symbols.Location + HsDev.Symbols.Documented + HsDev.Symbols.Resolve + HsDev.Symbols.Parsed + HsDev.Symbols.Types + HsDev.Tools.AutoFix + HsDev.Tools.Base + HsDev.Tools.Cabal + HsDev.Tools.ClearImports + HsDev.Tools.Ghc.Base + HsDev.Tools.Ghc.Check + HsDev.Tools.Ghc.Compat + HsDev.Tools.Ghc.MGhc + HsDev.Tools.Ghc.Prelude + HsDev.Tools.Ghc.Repl + HsDev.Tools.Ghc.Session + HsDev.Tools.Ghc.System + HsDev.Tools.Ghc.Types + HsDev.Tools.Ghc.Worker + HsDev.Tools.Hayoo + HsDev.Tools.HDocs + HsDev.Tools.HLint + HsDev.Tools.Refact + HsDev.Tools.Tabs + HsDev.Tools.Types + HsDev.Types + HsDev.Util + HsDev.Version + HsDev.Watcher + HsDev.Watcher.Types + System.Directory.Paths + System.Directory.Watcher + + if os(windows) + build-depends: + Win32 >= 2.3.0 + exposed-modules: + System.Win32.PowerShell + System.Win32.FileMapping.NamePool + System.Win32.FileMapping.Memory + else + build-depends: + unix >= 2.7.2.0 && < 2.8 + + if impl(ghc >= 8.6) && impl(ghc < 8.7) + build-depends: + ghc == 8.6.*, + Cabal == 2.4.* + + if impl(ghc >= 8.4) && impl(ghc < 8.5) + build-depends: + ghc == 8.4.*, + Cabal == 2.2.0.1 + + if impl(ghc >= 8.2) && impl(ghc < 8.3) + build-depends: + ghc == 8.2.*, + Cabal == 2.0.1.1 + + if impl(ghc >= 8.0) && impl(ghc < 8.2) + build-depends: + ghc >= 8.0.0 && < 8.1.0, + Cabal >= 1.24.2.0 && < 2.0 + + if flag(docs) + build-depends: + hdocs >= 0.5.2, + haddock-api >= 2.17.4, + haddock-library >= 1.4.3 && < 1.8 + + if flag(hlint) + build-depends: + hlint >= 2.0.11 && < 2.2 + + -- Build dependency lower bound is set for GHC 8.0.1. + -- Upper bound is set for GHC 8.4 + build-depends: + base >= 4.9 && < 5, + aeson >= 1.2.4.0 && < 1.5, + aeson-pretty >= 0.8.2 && < 0.9, + array >= 0.5.1.1 && < 0.6, + async >= 2.1.1.1 && < 2.3, + attoparsec >= 0.13.1.0 && < 0.14, + bytestring >= 0.10.8.1 && < 0.11, + containers >= 0.5.7.1 && < 0.7, + cpphs >= 1.20.5 && < 1.21, + data-default >= 0.7.1.1 && < 0.8, + deepseq >= 1.4.2.0 && < 1.5, + direct-sqlite >= 2.3.19 && < 2.4, + directory >= 1.2.6.2 && < 1.4, + exceptions >= 0.8.3 && < 0.11, + filepath >= 1.4.1.0 && < 1.5, + fsnotify >= 0.2.1 && < 0.4, + ghc-boot >= 8.0.1 && < 8.7, + ghc-paths >= 0.1.0.9 && < 0.2, + haskell-names >= 0.9.1 && < 0.10.0, + haskell-src-exts >= 1.19.1 && < 1.22.0, + hformat >= 0.1.0.1 && < 0.4, + hlint >= 2.0.11 && < 2.2, + http-client >= 0.5 && < 0.7, + lens >= 4.14 && < 4.18, + lifted-base >= 0.2.3.10 && < 0.3, + mmorph >= 1.0.9 && < 1.2, + monad-control >= 1.0.1.0 && < 1.1, + monad-loops >= 0.4.3 && < 0.5, + mtl >= 2.2.1 && < 2.3, + network >= 3.0 && < 3.1, + network-uri >= 2.6 && < 2.7, + optparse-applicative >= 0.12.1.0 && < 0.15, + process >= 1.4.2.0 && < 1.7, + regex-pcre-builtin >= 0.94.4 && < 0.95, + scientific >= 0.3.4.9 && < 0.4, + simple-log >= 0.9.9 && < 0.10, + sqlite-simple >= 0.4.13.0 && < 0.5, + stm >= 2.4 && < 2.6, + syb >= 0.6 && < 0.8, + template-haskell >= 2.11.0 && < 2.15, + text >= 1.2.2.2 && < 1.3, + text-region >= 0.1.0.1 && < 0.4, + time >= 1.6.0.1 && < 1.9, + transformers >= 0.5.2.0 && < 0.6, + transformers-base >= 0.4.4 && < 0.5, + uniplate >= 1.6.12 && < 1.7, + unordered-containers >= 0.2.8.0 && < 0.3, + vector >= 0.11.0.0 && < 0.13 + +executable hsdev + main-is: hsdev.hs + hs-source-dirs: tools + ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4" + + build-depends: + hsdev, + base >= 4.9 && < 5, + aeson >= 1.2.4.0 && < 1.5, + aeson-pretty >= 0.8.2 && < 0.9, + bytestring >= 0.10.8.1 && < 0.11, + containers >= 0.5.7.1 && < 0.7, + deepseq >= 1.4.2.0 && < 1.5, + directory >= 1.2.6.2 && < 1.4, + exceptions >= 0.8.3 && < 0.11, + filepath >= 1.4.1.0 && < 1.5, + monad-loops >= 0.4.3 && < 0.5, + mtl >= 2.2.1 && < 2.3, + network >= 3.0 && < 3.1, + optparse-applicative >= 0.12.1.0 && < 0.15, + process >= 1.4.2.0 && < 1.7, + text >= 1.2.2.2 && < 1.3, + transformers >= 0.5.2.0 && < 0.6, + unordered-containers >= 0.2.8.0 && < 0.3 + +test-suite test + main-is: Test.hs + hs-source-dirs: tests + ghc-options: -threaded -Wall -fno-warn-tabs + type: exitcode-stdio-1.0 + build-depends: + hsdev, + base >= 4.9 && < 5, + aeson >= 1.2.4.0 && < 1.5, + lens-aeson >= 1.0 && < 1.1, + async >= 2.1.1.1 && < 2.3, + containers >= 0.5.7.1 && < 0.7, + data-default >= 0.7.1.1 && < 0.8, + deepseq >= 1.4.2.0 && < 1.5, + directory >= 1.2.6.2 && < 1.4, + filepath >= 1.4.1.0 && < 1.5, + hformat >= 0.1.0.1 && < 0.4, + hspec >= 2.2.4, + lens >= 4.14 && < 4.18, + mtl >= 2.2.1 && < 2.3, + text >= 1.2.2.2 && < 1.3 diff --git a/src/Control/Apply/Util.hs b/src/Control/Apply/Util.hs --- a/src/Control/Apply/Util.hs +++ b/src/Control/Apply/Util.hs @@ -1,9 +1,9 @@ -module Control.Apply.Util ( - (&), chain - ) where - -(&) :: a -> (a -> b) -> b -(&) = flip ($) - -chain :: [a -> a] -> a -> a -chain = foldr (.) id +module Control.Apply.Util ( + (&), chain + ) where + +(&) :: a -> (a -> b) -> b +(&) = flip ($) + +chain :: [a -> a] -> a -> a +chain = foldr (.) id diff --git a/src/Control/Concurrent/FiniteChan.hs b/src/Control/Concurrent/FiniteChan.hs --- a/src/Control/Concurrent/FiniteChan.hs +++ b/src/Control/Concurrent/FiniteChan.hs @@ -1,57 +1,57 @@ -module Control.Concurrent.FiniteChan ( - Chan, - newChan, openedChan, closedChan, doneChan, sendChan, getChan, closeChan, stopChan - ) where - -import Control.Monad (void, when, liftM2) -import Control.Monad.Loops -import Control.Concurrent.STM - --- | 'Chan' is stoppable channel -data Chan a = Chan { - chanOpened :: TMVar Bool, - chanQueue :: TQueue a } - --- -- | Create new channel -newChan :: IO (Chan a) -newChan = liftM2 Chan (newTMVarIO True) newTQueueIO - --- | Is channel opened -openedChan :: Chan a -> IO Bool -openedChan = atomically . readTMVar . chanOpened - --- | Is channel closed -closedChan :: Chan a -> IO Bool -closedChan = fmap not . openedChan - --- | Is channel closed and all data consumed -doneChan :: Chan a -> IO Bool -doneChan ch = atomically $ do - o <- readTMVar $ chanOpened ch - e <- isEmptyTQueue (chanQueue ch) - return $ not o && e - --- | Write data to channel if it is open -sendChan :: Chan a -> a -> IO Bool -sendChan ch v = atomically $ do - o <- readTMVar $ chanOpened ch - when o $ writeTQueue (chanQueue ch) v - return o - --- | Get data from channel -getChan :: Chan a -> IO (Maybe a) -getChan ch = atomically $ do - o <- readTMVar $ chanOpened ch - if o - then fmap Just (readTQueue (chanQueue ch)) - else tryReadTQueue (chanQueue ch) - --- | Close channel -closeChan :: Chan a -> IO () -closeChan ch = atomically $ void $ swapTMVar (chanOpened ch) False - --- | Close channel and read all messages -stopChan :: Chan a -> IO [a] -stopChan ch = do - closeChan ch - whileJust (getChan ch) return +module Control.Concurrent.FiniteChan ( + Chan, + newChan, openedChan, closedChan, doneChan, sendChan, getChan, closeChan, stopChan + ) where + +import Control.Monad (void, when, liftM2) +import Control.Monad.Loops +import Control.Concurrent.STM + +-- | 'Chan' is stoppable channel +data Chan a = Chan { + chanOpened :: TMVar Bool, + chanQueue :: TQueue a } + +-- -- | Create new channel +newChan :: IO (Chan a) +newChan = liftM2 Chan (newTMVarIO True) newTQueueIO + +-- | Is channel opened +openedChan :: Chan a -> IO Bool +openedChan = atomically . readTMVar . chanOpened + +-- | Is channel closed +closedChan :: Chan a -> IO Bool +closedChan = fmap not . openedChan + +-- | Is channel closed and all data consumed +doneChan :: Chan a -> IO Bool +doneChan ch = atomically $ do + o <- readTMVar $ chanOpened ch + e <- isEmptyTQueue (chanQueue ch) + return $ not o && e + +-- | Write data to channel if it is open +sendChan :: Chan a -> a -> IO Bool +sendChan ch v = atomically $ do + o <- readTMVar $ chanOpened ch + when o $ writeTQueue (chanQueue ch) v + return o + +-- | Get data from channel +getChan :: Chan a -> IO (Maybe a) +getChan ch = atomically $ do + o <- readTMVar $ chanOpened ch + if o + then fmap Just (readTQueue (chanQueue ch)) + else tryReadTQueue (chanQueue ch) + +-- | Close channel +closeChan :: Chan a -> IO () +closeChan ch = atomically $ void $ swapTMVar (chanOpened ch) False + +-- | Close channel and read all messages +stopChan :: Chan a -> IO [a] +stopChan ch = do + closeChan ch + whileJust (getChan ch) return diff --git a/src/Control/Concurrent/Util.hs b/src/Control/Concurrent/Util.hs --- a/src/Control/Concurrent/Util.hs +++ b/src/Control/Concurrent/Util.hs @@ -1,22 +1,22 @@ -module Control.Concurrent.Util ( - fork, timeout, sync - ) where - -import Control.Concurrent -import Control.Concurrent.Async -import Control.Monad -import Control.Monad.IO.Class - -fork :: MonadIO m => IO () -> m () -fork = liftIO . void . forkIO - -timeout :: Int -> IO a -> IO (Maybe a) -timeout 0 act = liftM Just act -timeout tm act = liftM (either Just (const Nothing)) $ race act (threadDelay tm) - -sync :: MonadIO m => (IO () -> m a) -> m a -sync act = do - syncVar <- liftIO newEmptyMVar - r <- act $ putMVar syncVar () - liftIO $ takeMVar syncVar - return r +module Control.Concurrent.Util ( + fork, timeout, sync + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.IO.Class + +fork :: MonadIO m => IO () -> m () +fork = liftIO . void . forkIO + +timeout :: Int -> IO a -> IO (Maybe a) +timeout 0 act = liftM Just act +timeout tm act = liftM (either Just (const Nothing)) $ race act (threadDelay tm) + +sync :: MonadIO m => (IO () -> m a) -> m a +sync act = do + syncVar <- liftIO newEmptyMVar + r <- act $ putMVar syncVar () + liftIO $ takeMVar syncVar + return r diff --git a/src/Control/Concurrent/Worker.hs b/src/Control/Concurrent/Worker.hs --- a/src/Control/Concurrent/Worker.hs +++ b/src/Control/Concurrent/Worker.hs @@ -1,92 +1,92 @@ -{-# LANGUAGE RankNTypes #-} - -module Control.Concurrent.Worker ( - Worker(..), WorkerStopped(..), - startWorker, workerAlive, workerDone, - sendTask, stopWorker, joinWorker, syncTask, - inWorkerWith, inWorker, - - module Control.Concurrent.Async - ) where - -import Control.Concurrent.MVar -import Control.Monad.IO.Class -import Control.Monad.Catch -import Control.Monad.Except -import Data.Maybe (isNothing) -import Data.Typeable - -import Control.Concurrent.FiniteChan -import Control.Concurrent.Async - -data Worker m = Worker { - workerChan :: Chan (Async (), m ()), - workerTask :: MVar (Async ()) } - -data WorkerStopped = WorkerStopped deriving (Show, Typeable) - -instance Exception WorkerStopped - --- | Create new worker -startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m) -startWorker run initialize handleErrs = do - ch <- newChan - taskVar <- newEmptyMVar - let - job = onException (run $ initialize go) $ do - closeChan ch - abort - go = do - t <- fmap snd <$> liftIO (getChan ch) - maybe (return ()) (\f' -> handleErrs f' >> go) t - abort = do - a <- fmap fst <$> liftIO (getChan ch) - maybe (return ()) (\a' -> liftIO (cancel a') >> abort) a - async job >>= putMVar taskVar - return $ Worker ch taskVar - --- | Check whether worker alive -workerAlive :: Worker m -> IO Bool -workerAlive w = do - task <- readMVar $ workerTask w - isNothing <$> poll task - -workerDone :: Worker m -> IO Bool -workerDone = doneChan . workerChan - -sendTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a) -sendTask w act = mfix $ \async' -> do - var <- newEmptyMVar - let - act' = (act >>= liftIO . putMVar var . Right) `catch` onErr - onErr :: MonadIO m => SomeException -> m () - onErr = liftIO . putMVar var . Left - f = do - p <- sendChan (workerChan w) (void async', void act') - unless p $ putMVar var (Left $ SomeException WorkerStopped) - r <- takeMVar var - either throwM return r - async f - --- | Close worker channel -stopWorker :: Worker m -> IO () -stopWorker = closeChan . workerChan - --- | Stop worker and wait for it -joinWorker :: Worker m -> IO () -joinWorker w = do - stopWorker w - async' <- readMVar $ workerTask w - void $ waitCatch async' - --- | Send empty task and wait until worker run it -syncTask :: (MonadCatch m, MonadIO m) => Worker m -> IO () -syncTask w = sendTask w (return ()) >>= void . wait - --- | Run action in worker and wait for result -inWorkerWith :: (MonadIO m, MonadCatch m, MonadIO n) => (SomeException -> n a) -> Worker m -> m a -> n a -inWorkerWith err w act = liftIO (sendTask w act) >>= (liftIO . waitCatch >=> either err return) - --- | Run action in worker and wait for result -inWorker :: (MonadIO m, MonadCatch m) => Worker m -> m a -> IO a -inWorker w act = sendTask w act >>= liftIO . wait +{-# LANGUAGE RankNTypes #-} + +module Control.Concurrent.Worker ( + Worker(..), WorkerStopped(..), + startWorker, workerAlive, workerDone, + sendTask, stopWorker, joinWorker, syncTask, + inWorkerWith, inWorker, + + module Control.Concurrent.Async + ) where + +import Control.Concurrent.MVar +import Control.Monad.IO.Class +import Control.Monad.Catch +import Control.Monad.Except +import Data.Maybe (isNothing) +import Data.Typeable + +import Control.Concurrent.FiniteChan +import Control.Concurrent.Async + +data Worker m = Worker { + workerChan :: Chan (Async (), m ()), + workerTask :: MVar (Async ()) } + +data WorkerStopped = WorkerStopped deriving (Show, Typeable) + +instance Exception WorkerStopped + +-- | Create new worker +startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m) +startWorker run initialize handleErrs = do + ch <- newChan + taskVar <- newEmptyMVar + let + job = onException (run $ initialize go) $ do + closeChan ch + abort + go = do + t <- fmap snd <$> liftIO (getChan ch) + maybe (return ()) (\f' -> handleErrs f' >> go) t + abort = do + a <- fmap fst <$> liftIO (getChan ch) + maybe (return ()) (\a' -> liftIO (cancel a') >> abort) a + async job >>= putMVar taskVar + return $ Worker ch taskVar + +-- | Check whether worker alive +workerAlive :: Worker m -> IO Bool +workerAlive w = do + task <- readMVar $ workerTask w + isNothing <$> poll task + +workerDone :: Worker m -> IO Bool +workerDone = doneChan . workerChan + +sendTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a) +sendTask w act = mfix $ \async' -> do + var <- newEmptyMVar + let + act' = (act >>= liftIO . putMVar var . Right) `catch` onErr + onErr :: MonadIO m => SomeException -> m () + onErr = liftIO . putMVar var . Left + f = do + p <- sendChan (workerChan w) (void async', void act') + unless p $ putMVar var (Left $ SomeException WorkerStopped) + r <- takeMVar var + either throwM return r + async f + +-- | Close worker channel +stopWorker :: Worker m -> IO () +stopWorker = closeChan . workerChan + +-- | Stop worker and wait for it +joinWorker :: Worker m -> IO () +joinWorker w = do + stopWorker w + async' <- readMVar $ workerTask w + void $ waitCatch async' + +-- | Send empty task and wait until worker run it +syncTask :: (MonadCatch m, MonadIO m) => Worker m -> IO () +syncTask w = sendTask w (return ()) >>= void . wait + +-- | Run action in worker and wait for result +inWorkerWith :: (MonadIO m, MonadCatch m, MonadIO n) => (SomeException -> n a) -> Worker m -> m a -> n a +inWorkerWith err w act = liftIO (sendTask w act) >>= (liftIO . waitCatch >=> either err return) + +-- | Run action in worker and wait for result +inWorker :: (MonadIO m, MonadCatch m) => Worker m -> m a -> IO a +inWorker w act = sendTask w act >>= liftIO . wait diff --git a/src/Data/Deps.hs b/src/Data/Deps.hs --- a/src/Data/Deps.hs +++ b/src/Data/Deps.hs @@ -1,105 +1,105 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - -module Data.Deps ( - Deps(..), depsMap, - mapDeps, - dep, deps, - inverse, - DepsError(..), flatten, - selfDepend, - linearize - ) where - -import Control.Lens -import Control.Monad.State -import Control.Monad.Except -import Data.List (nub, intercalate) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Semigroup -import Data.Maybe (fromMaybe) - --- | Dependency map -newtype Deps a = Deps { - _depsMap :: Map a [a] } - -depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b]) -depsMap = lens _depsMap (const Deps) - -instance Ord a => Semigroup (Deps a) where - Deps l <> Deps r = Deps $ M.unionWith nubConcat l r - -instance Ord a => Monoid (Deps a) where - mempty = Deps mempty - mappend (Deps l) (Deps r) = Deps $ M.unionWith nubConcat l r - -instance Show a => Show (Deps a) where - show (Deps ds) = unlines [show d ++ " -> " ++ intercalate ", " (map show s) | (d, s) <- M.toList ds] - -type instance Index (Deps a) = a -type instance IxValue (Deps a) = [a] - -instance Ord a => Ixed (Deps a) where - ix k = depsMap . ix k - -instance Ord a => At (Deps a) where - at k = depsMap . at k - -mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b -mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap - --- | Make single dependency -dep :: a -> a -> Deps a -dep x y = deps x [y] - --- | Make dependency for one target, note that order of dependencies is matter -deps :: a -> [a] -> Deps a -deps x ys = Deps $ M.singleton x ys - --- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it -inverse :: Ord a => Deps a -> Deps a -inverse = mconcat . map (uncurry dep) . concatMap inverse' . M.toList . _depsMap where - inverse' :: (a, [a]) -> [(a, a)] - inverse' (m, ds) = zip ds (repeat m) - -newtype DepsError a = - CyclicDeps [a] - -- ^ Dependency cycle, list is cycle, where last item depends on first - deriving (Eq, Ord, Read) - -instance Show a => Show (DepsError a) where - show (CyclicDeps c) = "dependencies forms a cycle: " ++ concat [show d ++ " -> " | d <- c] ++ "..." - --- | Flatten dependencies so that there will be no indirect dependencies -flatten :: Ord a => Deps a -> Either (DepsError a) (Deps a) -flatten s@(Deps ds) = fmap snd . flip execStateT mempty . mapM_ (flatten' s) . M.keys $ ds where - flatten' :: Ord a => Deps a -> a -> StateT ([a], Deps a) (Either (DepsError a)) [a] - flatten' s' n = do - path <- gets (view _1) - when (preview (reversed . each) path == Just n) $ throwError (CyclicDeps $ reverse path) - d <- gets (preview $ _2 . ix n) - case d of - Just d' -> return d' - Nothing -> pushPath n $ do - d'' <- (nub . concat . (++ [deps'])) <$> mapM (flatten' s') deps' - modify (over _2 $ mappend (deps n d'')) - return d'' - where - deps' = fromMaybe [] $ preview (ix n) s' - pushPath :: MonadState ([a], Deps a) m => a -> m b -> m b - pushPath p act = do - modify (over _1 (p:)) - r <- act - modify (over _1 tail) - return r - -selfDepend :: Deps a -> Deps a -selfDepend = Deps . M.mapWithKey (\s d -> d ++ [s]) . _depsMap - --- | Linearize dependencies so that all items can be processed in this order, --- i.e. for each item all its dependencies goes before -linearize :: Ord a => Deps a -> Either (DepsError a) [a] -linearize = fmap (nub . concat . toListOf (depsMap . each) . selfDepend) . flatten - -nubConcat :: Ord a => [a] -> [a] -> [a] -nubConcat xs ys = nub $ xs ++ ys +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Data.Deps ( + Deps(..), depsMap, + mapDeps, + dep, deps, + inverse, + DepsError(..), flatten, + selfDepend, + linearize + ) where + +import Control.Lens +import Control.Monad.State +import Control.Monad.Except +import Data.List (nub, intercalate) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Semigroup +import Data.Maybe (fromMaybe) + +-- | Dependency map +newtype Deps a = Deps { + _depsMap :: Map a [a] } + +depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b]) +depsMap = lens _depsMap (const Deps) + +instance Ord a => Semigroup (Deps a) where + Deps l <> Deps r = Deps $ M.unionWith nubConcat l r + +instance Ord a => Monoid (Deps a) where + mempty = Deps mempty + mappend (Deps l) (Deps r) = Deps $ M.unionWith nubConcat l r + +instance Show a => Show (Deps a) where + show (Deps ds) = unlines [show d ++ " -> " ++ intercalate ", " (map show s) | (d, s) <- M.toList ds] + +type instance Index (Deps a) = a +type instance IxValue (Deps a) = [a] + +instance Ord a => Ixed (Deps a) where + ix k = depsMap . ix k + +instance Ord a => At (Deps a) where + at k = depsMap . at k + +mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b +mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap + +-- | Make single dependency +dep :: a -> a -> Deps a +dep x y = deps x [y] + +-- | Make dependency for one target, note that order of dependencies is matter +deps :: a -> [a] -> Deps a +deps x ys = Deps $ M.singleton x ys + +-- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it +inverse :: Ord a => Deps a -> Deps a +inverse = mconcat . map (uncurry dep) . concatMap inverse' . M.toList . _depsMap where + inverse' :: (a, [a]) -> [(a, a)] + inverse' (m, ds) = zip ds (repeat m) + +newtype DepsError a = + CyclicDeps [a] + -- ^ Dependency cycle, list is cycle, where last item depends on first + deriving (Eq, Ord, Read) + +instance Show a => Show (DepsError a) where + show (CyclicDeps c) = "dependencies forms a cycle: " ++ concat [show d ++ " -> " | d <- c] ++ "..." + +-- | Flatten dependencies so that there will be no indirect dependencies +flatten :: Ord a => Deps a -> Either (DepsError a) (Deps a) +flatten s@(Deps ds) = fmap snd . flip execStateT mempty . mapM_ (flatten' s) . M.keys $ ds where + flatten' :: Ord a => Deps a -> a -> StateT ([a], Deps a) (Either (DepsError a)) [a] + flatten' s' n = do + path <- gets (view _1) + when (preview (reversed . each) path == Just n) $ throwError (CyclicDeps $ reverse path) + d <- gets (preview $ _2 . ix n) + case d of + Just d' -> return d' + Nothing -> pushPath n $ do + d'' <- (nub . concat . (++ [deps'])) <$> mapM (flatten' s') deps' + modify (over _2 $ mappend (deps n d'')) + return d'' + where + deps' = fromMaybe [] $ preview (ix n) s' + pushPath :: MonadState ([a], Deps a) m => a -> m b -> m b + pushPath p act = do + modify (over _1 (p:)) + r <- act + modify (over _1 tail) + return r + +selfDepend :: Deps a -> Deps a +selfDepend = Deps . M.mapWithKey (\s d -> d ++ [s]) . _depsMap + +-- | Linearize dependencies so that all items can be processed in this order, +-- i.e. for each item all its dependencies goes before +linearize :: Ord a => Deps a -> Either (DepsError a) [a] +linearize = fmap (nub . concat . toListOf (depsMap . each) . selfDepend) . flatten + +nubConcat :: Ord a => [a] -> [a] -> [a] +nubConcat xs ys = nub $ xs ++ ys diff --git a/src/Data/Help.hs b/src/Data/Help.hs --- a/src/Data/Help.hs +++ b/src/Data/Help.hs @@ -1,24 +1,24 @@ -module Data.Help ( - Help(..), - indent, indentHelp, detailed, indented - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -class Help a where - brief :: a -> Text - help :: a -> [Text] - -indent :: Text -> Text -indent = T.cons '\t' - -indentHelp :: [Text] -> [Text] -indentHelp [] = [] -indentHelp (h:hs) = h : map indent hs - -detailed :: Help a => a -> [Text] -detailed v = brief v : help v - -indented :: Help a => a -> [Text] -indented = indentHelp . detailed +module Data.Help ( + Help(..), + indent, indentHelp, detailed, indented + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +class Help a where + brief :: a -> Text + help :: a -> [Text] + +indent :: Text -> Text +indent = T.cons '\t' + +indentHelp :: [Text] -> [Text] +indentHelp [] = [] +indentHelp (h:hs) = h : map indent hs + +detailed :: Help a => a -> [Text] +detailed v = brief v : help v + +indented :: Help a => a -> [Text] +indented = indentHelp . detailed diff --git a/src/Data/Lisp.hs b/src/Data/Lisp.hs --- a/src/Data/Lisp.hs +++ b/src/Data/Lisp.hs @@ -1,126 +1,126 @@ -module Data.Lisp ( - Lisp(..), - lisp, - encodeLisp, decodeLisp - ) where - -import Prelude hiding (String, Bool) -import qualified Prelude as P (String, Bool) - -import Data.Aeson (ToJSON(..), FromJSON(..), (.=)) -import qualified Data.Aeson as A -import Data.Aeson.Types (parseMaybe, parseEither) -import Data.ByteString.Lazy (ByteString) -import Data.Char (isAlpha, isDigit) -import Data.Either (partitionEithers) -import qualified Data.HashMap.Strict as HM -import Data.List (unfoldr) -import Data.Scientific -import Data.String (fromString) -import qualified Data.Text as T (unpack) -import qualified Data.Text.Lazy as LT (pack, unpack) -import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8, decodeUtf8) -import qualified Text.ParserCombinators.ReadP as R -import Text.Read (readMaybe) -import qualified Data.Vector as V - -data Lisp = - Null | - Bool P.Bool | - Symbol P.String | - String P.String | - Number Scientific | - List [Lisp] - deriving (Eq) - -readable :: Read a => Int -> R.ReadP a -readable = R.readS_to_P . readsPrec - -lisp :: Int -> R.ReadP Lisp -lisp n = R.choice [ - do - s <- symbol - return $ case s of - "null" -> Null - "true" -> Bool True - "false" -> Bool False - _ -> Symbol s, - fmap String string, - fmap Number number, - fmap List list] - where - symbol :: R.ReadP P.String - symbol = concat <$> sequence [ - R.option [] (pure <$> R.char ':'), - pure <$> R.satisfy isAlpha, - R.munch (\ch -> isAlpha ch || isDigit ch || ch == '-')] - - string :: R.ReadP P.String - string = (R.<++ R.pfail) $ do - ('\"':_) <- R.look - readable n - - number :: R.ReadP Scientific - number = do - s <- R.munch1 (\ch -> isDigit ch || ch `elem` ['e', 'E', '.', '+', '-']) - maybe R.pfail return $ readMaybe s - - list :: R.ReadP [Lisp] - list = R.between (R.char '(') (R.char ')') $ R.sepBy (lisp n) R.skipSpaces - -instance Read Lisp where - readsPrec = R.readP_to_S . lisp - -instance Show Lisp where - show Null = "null" - show (Bool b) - | b = "true" - | otherwise = "false" - show (Symbol s) = s - show (String s) = show s - show (Number n) = either show show (floatingOrInteger n :: Either Double Integer) - show (List vs) = "(" ++ unwords (map show vs) ++ ")" - -instance ToJSON Lisp where - toJSON Null = toJSON A.Null - toJSON (Bool b) = toJSON b - toJSON (Symbol s) = toJSON s - toJSON (String s) = toJSON s - toJSON (Number n) = toJSON n - toJSON (List vs) - | null keywords = toJSON $ map toJSON vals - | null vals = keywordsObject - | otherwise = toJSON $ map toJSON vals ++ [keywordsObject] - where - (vals, keywords) = partitionEithers $ unfoldr cutKeyword vs - keywordsObject = A.object [fromString (dropColon k) .= v | (k, v) <- keywords] - - dropColon :: P.String -> P.String - dropColon (':' : s) = s - dropColon s = s - - cutKeyword :: [Lisp] -> Maybe (Either Lisp (P.String, Lisp), [Lisp]) - cutKeyword [] = Nothing - cutKeyword (Symbol s : []) = Just (Right (s, Null), []) - cutKeyword (Symbol s : Symbol h : hs) = Just (Right (s, Null), Symbol h : hs) - cutKeyword (Symbol s : h : hs) = Just (Right (s, h), hs) - cutKeyword (h : hs) = Just (Left h, hs) - -instance FromJSON Lisp where - parseJSON A.Null = return Null - parseJSON (A.Bool b) = return $ Bool b - parseJSON (A.String s) = return $ String $ T.unpack s - parseJSON (A.Number n) = return $ Number n - parseJSON (A.Array vs) = fmap List $ mapM parseJSON $ V.toList vs - parseJSON (A.Object obj) = fmap (List . concat) $ mapM (\(k, v) -> sequence [pure $ Symbol (':' : T.unpack k), parseJSON v]) $ HM.toList obj - -decodeLisp :: FromJSON a => ByteString -> Either P.String a -decodeLisp str = do - sexp <- maybe (Left "Not a s-exp") Right . readMaybe . LT.unpack . LT.decodeUtf8 $ str - parseEither parseJSON $ toJSON (sexp :: Lisp) - -encodeLisp :: ToJSON a => a -> ByteString -encodeLisp r = LT.encodeUtf8 . LT.pack $ maybe - "(:error \"can't convert to s-exp\")" - (show :: Lisp -> P.String) - (parseMaybe parseJSON (toJSON r)) +module Data.Lisp ( + Lisp(..), + lisp, + encodeLisp, decodeLisp + ) where + +import Prelude hiding (String, Bool) +import qualified Prelude as P (String, Bool) + +import Data.Aeson (ToJSON(..), FromJSON(..), (.=)) +import qualified Data.Aeson as A +import Data.Aeson.Types (parseMaybe, parseEither) +import Data.ByteString.Lazy (ByteString) +import Data.Char (isAlpha, isDigit) +import Data.Either (partitionEithers) +import qualified Data.HashMap.Strict as HM +import Data.List (unfoldr) +import Data.Scientific +import Data.String (fromString) +import qualified Data.Text as T (unpack) +import qualified Data.Text.Lazy as LT (pack, unpack) +import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8, decodeUtf8) +import qualified Text.ParserCombinators.ReadP as R +import Text.Read (readMaybe) +import qualified Data.Vector as V + +data Lisp = + Null | + Bool P.Bool | + Symbol P.String | + String P.String | + Number Scientific | + List [Lisp] + deriving (Eq) + +readable :: Read a => Int -> R.ReadP a +readable = R.readS_to_P . readsPrec + +lisp :: Int -> R.ReadP Lisp +lisp n = R.choice [ + do + s <- symbol + return $ case s of + "null" -> Null + "true" -> Bool True + "false" -> Bool False + _ -> Symbol s, + fmap String string, + fmap Number number, + fmap List list] + where + symbol :: R.ReadP P.String + symbol = concat <$> sequence [ + R.option [] (pure <$> R.char ':'), + pure <$> R.satisfy isAlpha, + R.munch (\ch -> isAlpha ch || isDigit ch || ch == '-')] + + string :: R.ReadP P.String + string = (R.<++ R.pfail) $ do + ('\"':_) <- R.look + readable n + + number :: R.ReadP Scientific + number = do + s <- R.munch1 (\ch -> isDigit ch || ch `elem` ['e', 'E', '.', '+', '-']) + maybe R.pfail return $ readMaybe s + + list :: R.ReadP [Lisp] + list = R.between (R.char '(') (R.char ')') $ R.sepBy (lisp n) R.skipSpaces + +instance Read Lisp where + readsPrec = R.readP_to_S . lisp + +instance Show Lisp where + show Null = "null" + show (Bool b) + | b = "true" + | otherwise = "false" + show (Symbol s) = s + show (String s) = show s + show (Number n) = either show show (floatingOrInteger n :: Either Double Integer) + show (List vs) = "(" ++ unwords (map show vs) ++ ")" + +instance ToJSON Lisp where + toJSON Null = toJSON A.Null + toJSON (Bool b) = toJSON b + toJSON (Symbol s) = toJSON s + toJSON (String s) = toJSON s + toJSON (Number n) = toJSON n + toJSON (List vs) + | null keywords = toJSON $ map toJSON vals + | null vals = keywordsObject + | otherwise = toJSON $ map toJSON vals ++ [keywordsObject] + where + (vals, keywords) = partitionEithers $ unfoldr cutKeyword vs + keywordsObject = A.object [fromString (dropColon k) .= v | (k, v) <- keywords] + + dropColon :: P.String -> P.String + dropColon (':' : s) = s + dropColon s = s + + cutKeyword :: [Lisp] -> Maybe (Either Lisp (P.String, Lisp), [Lisp]) + cutKeyword [] = Nothing + cutKeyword (Symbol s : []) = Just (Right (s, Null), []) + cutKeyword (Symbol s : Symbol h : hs) = Just (Right (s, Null), Symbol h : hs) + cutKeyword (Symbol s : h : hs) = Just (Right (s, h), hs) + cutKeyword (h : hs) = Just (Left h, hs) + +instance FromJSON Lisp where + parseJSON A.Null = return Null + parseJSON (A.Bool b) = return $ Bool b + parseJSON (A.String s) = return $ String $ T.unpack s + parseJSON (A.Number n) = return $ Number n + parseJSON (A.Array vs) = fmap List $ mapM parseJSON $ V.toList vs + parseJSON (A.Object obj) = fmap (List . concat) $ mapM (\(k, v) -> sequence [pure $ Symbol (':' : T.unpack k), parseJSON v]) $ HM.toList obj + +decodeLisp :: FromJSON a => ByteString -> Either P.String a +decodeLisp str = do + sexp <- maybe (Left "Not a s-exp") Right . readMaybe . LT.unpack . LT.decodeUtf8 $ str + parseEither parseJSON $ toJSON (sexp :: Lisp) + +encodeLisp :: ToJSON a => a -> ByteString +encodeLisp r = LT.encodeUtf8 . LT.pack $ maybe + "(:error \"can't convert to s-exp\")" + (show :: Lisp -> P.String) + (parseMaybe parseJSON (toJSON r)) diff --git a/src/Data/LookupTable.hs b/src/Data/LookupTable.hs --- a/src/Data/LookupTable.hs +++ b/src/Data/LookupTable.hs @@ -1,65 +1,65 @@ -module Data.LookupTable ( - LookupTable, - newLookupTable, - lookupTable, lookupTableM, cacheInTableM, - hasLookupTable, - cachedInTable, - insertTable, insertTableM, storeInTable, storeInTableM - ) where - -import Control.Monad.IO.Class -import Control.Concurrent.MVar -import Data.Map (Map) -import qualified Data.Map as M - --- | k-v table -type LookupTable k v = MVar (Map k v) - -newLookupTable :: (Ord k, MonadIO m) => m (LookupTable k v) -newLookupTable = liftIO $ newMVar mempty - --- | Lookup, or insert if not exists -lookupTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v -lookupTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> case M.lookup key tbl' of - Just value' -> return (tbl', value') - Nothing -> return (M.insert key value tbl', value) - --- | Lookup, or insert if not exists -lookupTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v -lookupTableM key mvalue tbl = do - mv <- hasLookupTable key tbl - case mv of - Just value -> return value - Nothing -> do - value <- mvalue - lookupTable key value tbl - --- | @lookupTableM@ with swapped args -cacheInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v -cacheInTableM tbl key mvalue = lookupTableM key mvalue tbl - --- | Just check existable -hasLookupTable :: (Ord k, MonadIO m) => k -> LookupTable k v -> m (Maybe v) -hasLookupTable key tbl = liftIO $ withMVar tbl $ return . M.lookup key - --- | Make function caching results in @LookupTable@ -cachedInTable :: (Ord k, MonadIO m) => LookupTable k v -> (k -> m v) -> k -> m v -cachedInTable tbl fn key = cacheInTableM tbl key (fn key) - --- | Insert value into table and return it -insertTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v -insertTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> return (M.insert key value tbl', value) - --- | Insert value into table and return it -insertTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v -insertTableM key mvalue tbl = do - value <- mvalue - insertTable key value tbl - --- | @insertTable@ with flipped args -storeInTable :: (Ord k, MonadIO m) => LookupTable k v -> k -> v -> m v -storeInTable tbl key value = insertTable key value tbl - --- | @insertTable@ with flipped args -storeInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v -storeInTableM tbl key mvalue = insertTableM key mvalue tbl +module Data.LookupTable ( + LookupTable, + newLookupTable, + lookupTable, lookupTableM, cacheInTableM, + hasLookupTable, + cachedInTable, + insertTable, insertTableM, storeInTable, storeInTableM + ) where + +import Control.Monad.IO.Class +import Control.Concurrent.MVar +import Data.Map (Map) +import qualified Data.Map as M + +-- | k-v table +type LookupTable k v = MVar (Map k v) + +newLookupTable :: (Ord k, MonadIO m) => m (LookupTable k v) +newLookupTable = liftIO $ newMVar mempty + +-- | Lookup, or insert if not exists +lookupTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v +lookupTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> case M.lookup key tbl' of + Just value' -> return (tbl', value') + Nothing -> return (M.insert key value tbl', value) + +-- | Lookup, or insert if not exists +lookupTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v +lookupTableM key mvalue tbl = do + mv <- hasLookupTable key tbl + case mv of + Just value -> return value + Nothing -> do + value <- mvalue + lookupTable key value tbl + +-- | @lookupTableM@ with swapped args +cacheInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v +cacheInTableM tbl key mvalue = lookupTableM key mvalue tbl + +-- | Just check existable +hasLookupTable :: (Ord k, MonadIO m) => k -> LookupTable k v -> m (Maybe v) +hasLookupTable key tbl = liftIO $ withMVar tbl $ return . M.lookup key + +-- | Make function caching results in @LookupTable@ +cachedInTable :: (Ord k, MonadIO m) => LookupTable k v -> (k -> m v) -> k -> m v +cachedInTable tbl fn key = cacheInTableM tbl key (fn key) + +-- | Insert value into table and return it +insertTable :: (Ord k, MonadIO m) => k -> v -> LookupTable k v -> m v +insertTable key value tbl = liftIO $ modifyMVar tbl $ \tbl' -> return (M.insert key value tbl', value) + +-- | Insert value into table and return it +insertTableM :: (Ord k, MonadIO m) => k -> m v -> LookupTable k v -> m v +insertTableM key mvalue tbl = do + value <- mvalue + insertTable key value tbl + +-- | @insertTable@ with flipped args +storeInTable :: (Ord k, MonadIO m) => LookupTable k v -> k -> v -> m v +storeInTable tbl key value = insertTable key value tbl + +-- | @insertTable@ with flipped args +storeInTableM :: (Ord k, MonadIO m) => LookupTable k v -> k -> m v -> m v +storeInTableM tbl key mvalue = insertTableM key mvalue tbl diff --git a/src/Data/Maybe/JustIf.hs b/src/Data/Maybe/JustIf.hs --- a/src/Data/Maybe/JustIf.hs +++ b/src/Data/Maybe/JustIf.hs @@ -1,19 +1,19 @@ -module Data.Maybe.JustIf ( - justIf, - whenJust, whenJustM - ) where - -import Control.Monad - --- | Return @Just@ if True -justIf :: a -> Bool -> Maybe a -x `justIf` True = Just x -_ `justIf` False = Nothing - --- | Calls function when value is @Just@ -whenJust :: Applicative m => Maybe a -> (a -> m b) -> m () -whenJust v fn = maybe (pure ()) (void . fn) v - --- | Calls function when monad returns @Just@ -whenJustM :: Monad m => m (Maybe a) -> (a -> m b) -> m () -whenJustM mv fn = mv >>= (`whenJust` fn) +module Data.Maybe.JustIf ( + justIf, + whenJust, whenJustM + ) where + +import Control.Monad + +-- | Return @Just@ if True +justIf :: a -> Bool -> Maybe a +x `justIf` True = Just x +_ `justIf` False = Nothing + +-- | Calls function when value is @Just@ +whenJust :: Applicative m => Maybe a -> (a -> m b) -> m () +whenJust v fn = maybe (pure ()) (void . fn) v + +-- | Calls function when monad returns @Just@ +whenJustM :: Monad m => m (Maybe a) -> (a -> m b) -> m () +whenJustM mv fn = mv >>= (`whenJust` fn) diff --git a/src/HsDev.hs b/src/HsDev.hs --- a/src/HsDev.hs +++ b/src/HsDev.hs @@ -1,31 +1,31 @@ -module HsDev ( - module Data.Default, - module System.Directory.Paths, - - module HsDev.Types, - module HsDev.Error, - module HsDev.Server.Base, - module HsDev.Server.Commands, - module HsDev.Client.Commands, - module HsDev.Inspect, - module HsDev.Project, - module HsDev.Scan, - module HsDev.Symbols, - module HsDev.Symbols.Resolve, - module HsDev.Util - ) where - -import Data.Default -import System.Directory.Paths - -import HsDev.Types -import HsDev.Error -import HsDev.Server.Base -import HsDev.Server.Commands -import HsDev.Client.Commands -import HsDev.Inspect -import HsDev.Project -import HsDev.Scan -import HsDev.Symbols -import HsDev.Symbols.Resolve -import HsDev.Util +module HsDev ( + module Data.Default, + module System.Directory.Paths, + + module HsDev.Types, + module HsDev.Error, + module HsDev.Server.Base, + module HsDev.Server.Commands, + module HsDev.Client.Commands, + module HsDev.Inspect, + module HsDev.Project, + module HsDev.Scan, + module HsDev.Symbols, + module HsDev.Symbols.Resolve, + module HsDev.Util + ) where + +import Data.Default +import System.Directory.Paths + +import HsDev.Types +import HsDev.Error +import HsDev.Server.Base +import HsDev.Server.Commands +import HsDev.Client.Commands +import HsDev.Inspect +import HsDev.Project +import HsDev.Scan +import HsDev.Symbols +import HsDev.Symbols.Resolve +import HsDev.Util diff --git a/src/HsDev/Client/Commands.hs b/src/HsDev/Client/Commands.hs --- a/src/HsDev/Client/Commands.hs +++ b/src/HsDev/Client/Commands.hs @@ -1,708 +1,708 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeOperators, TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module HsDev.Client.Commands ( - runClient, runCommand - ) where - -import Control.Arrow (second) -import Control.Concurrent.MVar -import Control.Exception (displayException) -import Control.Lens hiding ((.=), (<.>)) -import Control.Monad -import Control.Monad.Morph -import Control.Monad.Except -import Control.Monad.Reader -import qualified Control.Monad.State as State -import Control.Monad.Catch (try, catch, bracket, SomeException(..)) -import Data.Aeson hiding (Result, Error) -import Data.List -import Data.Maybe -import qualified Data.Map.Strict as M -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T (append, null) -import System.Directory -import System.FilePath -import qualified System.Log.Simple as Log -import qualified System.Log.Simple.Base as Log -import Text.Read (readMaybe) - -import Data.Maybe.JustIf -import qualified System.Directory.Watcher as W -import System.Directory.Paths -import Text.Format -import HsDev.Error -import HsDev.Database.SQLite as SQLite -import HsDev.Inspect (preload, asModule) -import HsDev.Scan (upToDate, getFileContents) -import HsDev.Server.Message as M -import HsDev.Server.Types -import HsDev.Sandbox hiding (findSandbox) -import qualified HsDev.Sandbox as S (findSandbox) -import HsDev.Symbols -import qualified HsDev.Tools.AutoFix as AutoFix -import qualified HsDev.Tools.Cabal as Cabal -import HsDev.Tools.Ghc.Session -import HsDev.Tools.Ghc.Worker (clearTargets) -import qualified HsDev.Tools.Ghc.Compat as Compat -import qualified HsDev.Tools.Ghc.Check as Check -import qualified HsDev.Tools.Ghc.Types as Types -import qualified HsDev.Tools.Hayoo as Hayoo -import qualified HsDev.Tools.HDocs as HDocs -import qualified HsDev.Tools.HLint as HLint -import qualified HsDev.Tools.Types as Tools -import HsDev.Util -import HsDev.Watcher - -import qualified HsDev.Database.Update as Update - -runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result -runClient copts = mapServerM toResult . runClientM where - toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result - toResult act = liftM errorToResult $ runReaderT (try (try act)) copts - mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b - mapServerM f = ServerM . mapReaderT f . runServerM - errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result - errorToResult = either (Error . UnhandledError . displayException) (either Error (Result . toJSON)) - -toValue :: (ToJSON a, Monad m) => m a -> m Value -toValue = fmap toJSON - -runCommand :: ServerMonadBase m => Command -> ClientM m Value -runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)] -runCommand (Listen (Just l)) = case Log.level (pack l) of - Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l - Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing) -runCommand (Listen Nothing) = toValue $ do - serverListen >>= mapM_ (commandNotify . Notification . toJSON) -runCommand (SetLogLevel l) = case Log.level (pack l) of - Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l - Just lev -> toValue $ do - lev' <- serverSetLogLevel lev - Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev - Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev -runCommand (Scan projs cabal sboxes fs paths' btool ghcs' docs' infer') = toValue $ do - sboxes' <- getSandboxes sboxes - updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [ - [Update.scanCabal ghcs' | cabal], - map (Update.scanSandbox ghcs') sboxes', - [Update.scanFiles (zip fs (repeat ghcs'))], - map (Update.scanProject ghcs' btool) projs, - map (Update.scanDirectory ghcs') paths'] -runCommand (ScanProject proj tool deps) = toValue $ updateProcess def [ - (if deps then Update.scanProjectStack else Update.scanProject) [] tool proj] -runCommand (ScanFile fpath tool scanProj deps) = toValue $ updateProcess def [ - Update.scanFile [] fpath tool scanProj deps] -runCommand (ScanPackageDbs pdbs) = toValue $ updateProcess def [ - Update.scanPackageDbStack [] pdbs] -runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts -runCommand (RefineDocs projs fs) - | HDocs.hdocsSupported = toValue $ do - projects <- traverse findProject projs - mods <- do - projMods <- liftM concat $ forM projects $ \proj -> do - ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.docs') is null" - (Only $ proj ^. projectCabal) - p <- SQLite.loadProject (proj ^. projectCabal) - return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms - fileMods <- liftM concat $ forM fs $ \f -> - loadModules "select id from modules where file == ? and json_extract(tags, '$.docs') is null" - (Only f) - return $ projMods ++ fileMods - updateProcess def [Update.scanDocs mods] - | otherwise = hsdevError $ OtherError "docs not supported" -runCommand (InferTypes projs fs) = toValue $ do - projects <- traverse findProject projs - mods <- do - projMods <- liftM concat $ forM projects $ \proj -> do - ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.types') is null" - (Only $ proj ^. projectCabal) - p <- SQLite.loadProject (proj ^. projectCabal) - return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms - fileMods <- liftM concat $ forM fs $ \f -> - loadModules "select id from modules where file == ? and json_extract(tags, '$.types') is null" - (Only f) - return $ projMods ++ fileMods - updateProcess def [Update.inferModTypes mods] -runCommand (Remove projs cabal sboxes files) = toValue $ withSqlConnection $ SQLite.transaction_ SQLite.Immediate $ do - let - -- We can safely remove package-db from db iff doesn't used by some of other package-dbs - -- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db - -- We also can't remove stack snapshot package-db if there are some local package-db not yet removed - canRemove pdbs = do - from' <- State.get - return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from' - -- Remove top of package-db stack if possible - removePackageDb' pdbs = do - can <- canRemove pdbs - when can $ do - State.modify (delete pdbs) - ms <- liftM (map fromOnly) $ query_ - "select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;" - removePackageDb (topPackageDb pdbs) - mapM_ SQLite.removeModule ms - whenJustM (askSession sessionWatcher) $ \w -> - liftIO $ unwatchPackageDb w $ topPackageDb pdbs - -- Remove package-db stack when possible - removePackageDbStack = mapM_ removePackageDb' . packageDbStacks - projects <- traverse findProject projs - sboxes' <- getSandboxes sboxes - forM_ projects $ \proj -> do - ms <- liftM (map fromOnly) $ query "select id from modules where cabal == ?;" (Only $ proj ^. projectCabal) - SQLite.removeProject proj - mapM_ SQLite.removeModule ms - whenJustM (askSession sessionWatcher) $ \w -> - liftIO $ unwatchProject w proj - - allPdbs <- liftM (map fromOnly) $ query_ @(Only PackageDb) "select package_db from package_dbs;" - dbPDbs <- inSessionGhc $ mapM restorePackageDbStack allPdbs - flip State.evalStateT dbPDbs $ do - when cabal $ removePackageDbStack userDb - forM_ sboxes' $ \sbox -> do - pdbs <- lift $ inSessionGhc $ sandboxPackageDbStack sbox - removePackageDbStack pdbs - - forM_ files $ \file -> do - ms <- query @_ @(ModuleId :. Only Int) - (toQuery $ mconcat [ - qModuleId, - select_ ["mu.id"], - where_ ["mu.file == ?"]]) - (Only file) - forM_ ms $ \(m :. Only i) -> do - SQLite.removeModule i - whenJustM (askSession sessionWatcher) $ \w -> - liftIO . unwatchModule w $ (m ^. moduleLocation) -runCommand RemoveAll = toValue $ do - SQLite.purge - whenJustM (askSession sessionWatcher) $ \w -> do - wdirs <- liftIO $ readMVar (W.watcherDirs w) - liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir -runCommand InfoPackages = toValue $ - query_ @ModulePackage "select package_name, package_version from package_dbs;" -runCommand InfoProjects = toValue $ do - ps <- query_ @(Only Path) "select cabal from projects;" - mapM (SQLite.loadProject . fromOnly) ps -runCommand InfoSandboxes = toValue $ do - rs <- query_ @(Only PackageDb) "select distinct package_db from package_dbs;" - return [pdb | Only pdb <- rs] -runCommand (InfoSymbol sq filters True _) = toValue $ do - let - (conds, params) = targetFilters "m" (Just "s") filters - queryNamed @SymbolId - (toQuery $ mconcat [ - qSymbolId, - where_ ["s.name like :pattern escape '\\'"], - where_ conds]) - ([":pattern" := likePattern sq] ++ params) -runCommand (InfoSymbol sq filters False _) = toValue $ do - let - (conds, params) = targetFilters "m" (Just "s") filters - queryNamed @Symbol - (toQuery $ mconcat [ - qSymbol, - where_ ["s.name like :pattern escape '\\'"], - where_ conds]) - ([":pattern" := likePattern sq] ++ params) -runCommand (InfoModule sq filters h _) = toValue $ do - let - (conds, params) = targetFilters "mu" Nothing filters - rs <- queryNamed @(Only Int :. ModuleId) - (toQuery $ mconcat [ - select_ ["mu.id"], - qModuleId, - where_ ["mu.name like :pattern escape '\\'"], - where_ conds]) - ([":pattern" := likePattern sq] ++ params) - if h - then return (toJSON $ map (\(_ :. m) -> m) rs) - else liftM toJSON $ forM rs $ \(Only mid :. mheader) -> do - [(docs, fixities)] <- query @_ @(Maybe Text, Maybe Value) "select m.docs, m.fixities from modules as m where (m.id == ?);" - (Only mid) - let - fixities' = fromMaybe [] (fixities >>= fromJSON') - imports' <- query @_ @Import (toQuery $ mconcat [ - qImport "i", - where_ ["i.module_id = ?"]]) - (Only mid) - exports' <- query @_ @Symbol (toQuery $ mconcat [ - qSymbol, - from_ ["exports as e"], - where_ ["e.module_id == ?", "e.symbol_id == s.id"]]) - (Only mid) - return $ Module mheader docs imports' exports' fixities' mempty Nothing -runCommand (InfoProject (Left projName)) = toValue $ findProject projName -runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject (view path projPath) -runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandboxes sandbox' -runCommand (Lookup nm fpath) = toValue $ - fmap (map (\(s :. m) -> ImportedSymbol s m)) $ query @_ @(Symbol :. ModuleId) (toQuery $ mconcat [ - qSymbol, - qModuleId, - from_ ["projects_modules_scope as pms", "modules as srcm", "exports as e"], - where_ [ - "pms.cabal is srcm.cabal", - "srcm.file = ?", - "pms.module_id = e.module_id", - "m.id = s.module_id", - "s.id = e.symbol_id", - "e.module_id = mu.id", - "s.name = ?"]]) - (fpath ^. path, nm) -runCommand (Whois nm fpath) = toValue $ do - let - q = nameModule $ toName nm - ident = nameIdent $ toName nm - query @_ @Symbol (toQuery $ mconcat [ - qSymbol, - from_ ["modules as srcm", "scopes as sc"], - where_ [ - "srcm.id == sc.module_id", - "s.id == sc.symbol_id", - "srcm.file == ?", - "sc.qualifier is ?", - "sc.name == ?"]]) - (fpath ^. path, q, ident) -runCommand (Whoat l c fpath) = toValue $ do - rs <- query @_ @Symbol (toQuery $ mconcat [ - qSymbol, - from_ ["names as n", "modules as srcm"], - where_ [ - "srcm.id == n.module_id", - "m.name == n.resolved_module", - "s.name == n.resolved_name", - "s.what == n.resolved_what", - "s.id == n.symbol_id", - "srcm.file == ?", - "(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]]) - (fpath ^. path, l, c) - locals <- do - defs <- query @_ @(ModuleId :. (Text, Int, Int, Maybe Text)) (toQuery $ mconcat [ - qModuleId, - select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type"], - from_ ["names as n"], - where_ [ - "mu.id == n.module_id", - "n.def_line is not null", - "n.def_column is not null", - "mu.file == ?", - "(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]]) - (fpath ^. path, l, c) - return [ - Symbol { - _symbolId = SymbolId nm mid, - _symbolDocs = Nothing, - _symbolPosition = Just (Position defLine defColumn), - _symbolInfo = Function ftype - } | (mid :. (nm, defLine, defColumn, ftype)) <- defs] - return $ rs ++ locals -runCommand (ResolveScopeModules sq fpath) = toValue $ do - pids <- query @_ @(Only (Maybe Path)) "select m.cabal from modules as m where (m.file == ?);" - (Only $ fpath ^. path) - case pids of - [] -> hsdevError $ OtherError $ "module at {} not found" ~~ fpath - [Only proj] -> query @_ @ModuleId (toQuery $ mconcat [ - qModuleId, - from_ ["projects_modules_scope as msc"], - where_ [ - "msc.module_id == mu.id", - "msc.cabal is ?", - "mu.name like ? escape '\\'"]]) - (proj, likePattern sq) - _ -> fail "Impossible happened: several projects for one module" -runCommand (ResolveScope sq fpath) = toValue $ - query @_ @(Scoped SymbolId) (toQuery $ mconcat [ - qSymbolId, - select_ ["sc.qualifier"], - from_ ["scopes as sc", "modules as srcm"], - where_ [ - "srcm.id == sc.module_id", - "sc.symbol_id == s.id", - "srcm.file == ?", - "s.name like ? escape '\\'"]]) - (fpath ^. path, likePattern sq) -runCommand (FindUsages l c fpath) = toValue $ do - us <- do - sids <- query @_ @(Only (Maybe Int)) (toQuery $ mconcat [ - select_ ["n.symbol_id"], - from_ ["names as n", "modules as srcm"], - where_ [ - "n.module_id == srcm.id", - "(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)", - "srcm.file = ?"]]) - (l, c, fpath) - when (length sids > 1) $ Log.sendLog Log.Warning $ "multiple symbols found at location {0}:{1}:{2}" ~~ fpath ~~ l ~~ c - let - msid = join $ fmap fromOnly $ listToMaybe sids - query @_ @SymbolUsage (toQuery $ mconcat [ - qSymbol, - select_ ["n.qualifier"], - qModuleId, - select_ ["n.line", "n.column", "n.line_to", "n.column_to"], - from_ ["names as n"], - where_ [ - "n.symbol_id == ?", - "s.id == n.symbol_id", - "mu.id == n.module_id"]]) - (Only msid) - locals <- do - defs <- query @_ @(ModuleId :. Only Text :. Position :. Only (Maybe Text) :. Region) (toQuery $ mconcat [ - qModuleId, - select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type", "n.line", "n.column", "n.line_to", "n.column_to"], - from_ ["names as n", "names as defn"], - where_ [ - "n.module_id = mu.id", - "n.def_line = defn.def_line", - "n.def_column = defn.def_column", - "defn.module_id = mu.id", - "(?, ?) between (defn.line, defn.column) and (defn.line_to, defn.column_to)", - "mu.file = ?"]]) - (l, c, fpath ^. path) - return $ do - (mid :. Only nm :. defPos :. Only ftype :. useRgn) <- defs - let - sym = Symbol { - _symbolId = SymbolId nm mid, - _symbolDocs = Nothing, - _symbolPosition = Just defPos, - _symbolInfo = Function ftype } - return $ SymbolUsage sym Nothing mid useRgn - return $ us ++ locals -runCommand (Complete input True fpath) = toValue $ - query @_ @Symbol (toQuery $ mconcat [ - qSymbol, - from_ ["modules as srcm", "exports as e"], - where_ [ - "e.module_id in (select srcm.id union select module_id from projects_modules_scope where (((cabal is null) and (srcm.cabal is null)) or (cabal == srcm.cabal)))", - "s.id == e.symbol_id", - "msrc.file == ?", - "s.name like ? escape '\\'"]]) - (fpath ^. path, likePattern (SearchQuery input SearchPrefix)) -runCommand (Complete input False fpath) = toValue $ - query @_ @(Scoped Symbol) (toQuery $ mconcat [ - qSymbol, - select_ ["c.qualifier"], - from_ ["completions as c", "modules as srcm"], - where_ [ - "c.module_id == srcm.id", - "c.symbol_id == s.id", - "srcm.file == ?", - "c.completion like ? escape '\\'"]]) - (fpath ^. path, likePattern (SearchQuery input SearchPrefix)) -runCommand (Hayoo hq p ps) = do - m <- askSession sessionHTTPManager - toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM - (mapMaybe Hayoo.hayooAsSymbol . Hayoo.resultResult) $ - liftIO $ hsdevLift $ Hayoo.hayoo m hq (Just i) -runCommand (CabalList packages') = toValue $ liftIO $ hsdevLift $ Cabal.cabalList $ map unpack packages' -runCommand (UnresolvedSymbols fs) = toValue $ liftM concat $ forM fs $ \f -> do - rs <- query @_ @(Maybe String, String, Int, Int) "select n.qualifier, n.name, n.line, n.column from modules as m, names as n where (m.id == n.module_id) and (m.file == ?) and (n.resolve_error is not null);" - (Only $ f ^. path) - return $ map (\(m, nm, line, column) -> object [ - "qualifier" .= m, - "name" .= nm, - "line" .= line, - "column" .= column]) rs -runCommand (Lint fs lints) = toValue $ liftM concat $ forM fs $ \fsrc -> do - FileSource f c <- actualFileContents fsrc - liftIO $ hsdevLift $ HLint.hlint lints (view path f) c -runCommand (Check fs ghcs' clear) = toValue $ Log.scope "check" $ - liftM concat $ mapM (runCheck ghcs' clear) fs -runCommand (CheckLint fs ghcs' lints clear) = toValue $ do - fs' <- mapM actualFileContents fs - checkMsgs <- liftM concat $ mapM (runCheck ghcs' clear) fs' - lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint lints (view path f) c) fs' - return $ checkMsgs ++ lintMsgs -runCommand (Types fs ghcs' clear) = toValue $ do - liftM concat $ forM fs $ \fsrc@(FileSource file msrc) -> do - mcached' <- getCached file msrc - FileSource _ msrc' <- actualFileContents fsrc - maybe (updateTypes file msrc') return mcached' - where - getCached :: ServerMonadBase m => Path -> Maybe Text -> ClientM m (Maybe [Tools.Note Types.TypedExpr]) - getCached _ (Just _) = return Nothing - getCached file' Nothing = do - actual' <- sourceUpToDate file' - mid <- query @_ @((Bool, Int) :. ModuleId) - (toQuery $ mconcat [ - select_ ["json_extract(tags, '$.types') is 1", "mu.id"], - qModuleId, - where_ ["mu.file = ?"]]) - (Only file') - when (length mid > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ file' - when (null mid) $ hsdevError $ NotInspected $ FileModule file' Nothing - let - [(hasTypes', mid') :. modId] = mid - if actual' && hasTypes' - then do - types' <- query @_ @(Region :. Types.TypedExpr) "select line, column, line_to, column_to, expr, type from types where module_id = ?;" (Only mid') - liftM Just $ forM types' $ \(rgn :. texpr) -> return Tools.Note { - Tools._noteSource = modId ^. moduleLocation, - Tools._noteRegion = rgn, - Tools._noteLevel = Nothing, - Tools._note = set Types.typedExpr Nothing texpr } - else return Nothing - - updateTypes file msrc = do - sess <- getSession - m <- setFileSourceSession ghcs' file - types' <- inSessionGhc $ do - when clear clearTargets - Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $ - Types.fileTypes m msrc - updateProcess def [Update.setModTypes (m ^. moduleId) types'] - return $ set (each . Tools.note . Types.typedExpr) Nothing types' -runCommand (AutoFix ns) = toValue $ return $ AutoFix.corrections ns -runCommand (Refactor ns rest isPure) = toValue $ do - files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns - let - runFix file = do - unless isPure $ do - liftIO $ readFileUtf8 (view path file) >>= writeFileUtf8 (view path file) . AutoFix.refact fixRefacts' - return newCorrs' - where - findCorrs :: Path -> [Tools.Note AutoFix.Refact] -> [Tools.Note AutoFix.Refact] - findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile)) - fixCorrs' = findCorrs file ns - upCorrs' = findCorrs file rest - fixRefacts' = fixCorrs' ^.. each . Tools.note - newCorrs' = AutoFix.update fixRefacts' upCorrs' - liftM concat $ mapM runFix files -runCommand (Rename nm newName fpath) = toValue $ do - m <- refineSourceModule fpath - let - mname = m ^. moduleId . moduleName - makeNote mloc r = Tools.Note { - Tools._noteSource = mloc, - Tools._noteRegion = r, - Tools._noteLevel = Nothing, - Tools._note = AutoFix.Refact "rename" (AutoFix.replace (AutoFix.fromRegion r) newName) } - - defRenames <- do - -- FIXME: Doesn't take scope into account. If you have modules with same names in different project, it will rename symbols from both - defRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and def_line is not null;" ( - mname, - nm) - return $ map (makeNote (m ^. moduleId . moduleLocation)) defRegions - - usageRenames <- do - -- FIXME: Same as above: doesn't take scope into account - usageRegions <- query @_ @(Only Path :. Region) "select m.file, n.line, n.column, n.line_to, n.column_to from names as n, modules as m where n.module_id == m.id and m.file is not null and n.resolved_module == ? and n.resolved_name == ?;" ( - mname, - nm) - return $ map (\(Only p :. r) -> makeNote (FileModule p Nothing) r) usageRegions - - return $ defRenames ++ usageRenames -runCommand (GhcEval exprs mfile) = toValue $ do - mfile' <- traverse actualFileContents mfile - case mfile' of - Nothing -> inSessionGhc ghciSession - Just (FileSource f mcts) -> do - m <- setFileSourceSession [] f - inSessionGhc $ interpretModule m mcts - inSessionGhc $ mapM (tryRepl . evaluate) exprs -runCommand (GhcType exprs mfile) = toValue $ do - mfile' <- traverse actualFileContents mfile - case mfile' of - Nothing -> inSessionGhc ghciSession - Just (FileSource f mcts) -> do - m <- setFileSourceSession [] f - inSessionGhc $ interpretModule m mcts - inSessionGhc $ mapM (tryRepl . expressionType) exprs -runCommand Langs = toValue $ return Compat.languages -runCommand Flags = toValue $ return ["-f" ++ prefix ++ f | - f <- Compat.flags, - prefix <- ["", "no-"]] -runCommand (Link hold) = toValue $ commandLink >> when hold commandHold -runCommand StopGhc = toValue $ do - inSessionGhc $ do - ms <- findSessionBy (const True) - forM_ ms $ \s -> do - Log.sendLog Log.Trace $ "stopping session: {}" ~~ view sessionKey s - deleteSession $ view sessionKey s -runCommand Exit = toValue serverExit - - -targetFilter :: Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam]) -targetFilter mtable _ (TargetProject proj) = ( - "{t}.cabal in (select cabal from projects where name == :project or cabal == :project)" ~~ ("t" ~% mtable), - [":project" := proj]) -targetFilter mtable _ (TargetFile f) = ("{t}.file == :file" ~~ ("t" ~% mtable), [":file" := f]) -targetFilter mtable Nothing (TargetModule nm) = ("{t}.name == :module_name" ~~ ("t" ~% mtable), [":module_name" := nm]) -targetFilter mtable (Just stable) (TargetModule nm) = ( - "({t}.name == :module_name) or ({s}.id in (select e.symbol_id from exports as e, modules as em where e.module_id == em.id and em.name == :module_name))" - ~~ ("t" ~% mtable) - ~~ ("s" ~% stable), - [":module_name" := nm]) -targetFilter mtable _ (TargetPackage p) = (tpl ~~ ("t" ~% mtable), params) where - pkg = fromMaybe (mkPackage p) (readMaybe (unpack p)) - tpl - | T.null (pkg ^. packageVersion) = "{t}.package_name == :package_name" - | otherwise = "{t}.package_name == :package_name and {t}.package_version == :package_version" - params - | T.null (pkg ^. packageVersion) = [pname] - | otherwise = [pname, pver] - pname = ":package_name" := (pkg ^. packageName) - pver = ":package_version" := (pkg ^. packageVersion) -targetFilter mtable _ TargetInstalled = ("{t}.package_name is not null" ~~ ("t" ~% mtable), []) -targetFilter mtable _ TargetSourced = ("{t}.file is not null" ~~ ("t" ~% mtable), []) -targetFilter mtable _ TargetStandalone = ("{t}.file is not null and {t}.cabal is null" ~~ ("t" ~% mtable), []) - -targetFilters :: Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam]) -targetFilters mtable stable = second concat . unzip . map (targetFilter mtable stable) - -likePattern :: SearchQuery -> Text -likePattern (SearchQuery input stype) = case stype of - SearchExact -> escapedInput - SearchPrefix -> escapedInput `T.append` "%" - SearchInfix -> "%" `T.append` escapedInput `T.append` "%" - SearchSuffix -> "%" `T.append` escapedInput - where - escapedInput = escapeLike input - -instance ToJSON Log.Message where - toJSON m = object [ - "time" .= Log.messageTime m, - "level" .= show (Log.messageLevel m), - "component" .= show (Log.messageComponent m), - "scope" .= show (Log.messageScope m), - "text" .= Log.messageText m] - -instance FromJSON Log.Message where - parseJSON = withObject "log-message" $ \v -> Log.Message <$> - (v .:: "time") <*> - ((v .:: "level") >>= maybe (fail "invalid level") return . readMaybe) <*> - (read <$> (v .:: "component")) <*> - (read <$> (v .:: "scope")) <*> - (v .:: "text") - - --- | Run check -runCheck :: CommandMonad m => [String] -> Bool -> FileSource -> m [Tools.Note Tools.OutputMessage] -runCheck ghcs' clear = actualFileContents >=> check' where - check' (FileSource file mcts) = Log.scope "run-check" $ do - Log.sendLog Log.Trace $ "setting file source session for {}" ~~ file - sess <- getSession - m <- setFileSourceSession ghcs' file - Log.sendLog Log.Trace "file source session set" - ns <- inSessionGhc $ do - when clear clearTargets - Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $ - Check.check m mcts - if null ns - then do - ns' <- Update.cachedWarnings [m ^. moduleId . moduleLocation] - unless (null ns') $ - Log.sendLog Log.Trace $ "returning {} cached warnings for {}" ~~ length ns' ~~ file - return ns' - else return ns - --- Helper functions - --- | Canonicalize paths -findPath :: (CommandMonad m, Paths a) => a -> m a -findPath = paths findPath' where - findPath' :: CommandMonad m => FilePath -> m FilePath - findPath' f = do - r <- commandRoot - liftIO $ canonicalizePath (normalise $ if isRelative f then r f else f) - --- | Find sandbox by path -findSandbox :: CommandMonad m => Path -> m Sandbox -findSandbox fpath = do - fpath' <- findPath fpath - sbox <- liftIO $ S.findSandbox fpath' - maybe (hsdevError $ FileNotFound fpath') return sbox - --- | Check if source file up to date -sourceUpToDate :: CommandMonad m => Path -> m Bool -sourceUpToDate fpath = do - fpath' <- findPath fpath - insps <- query @_ @Inspection "select inspection_time, inspection_opts from modules where file = ?;" (Only fpath') - when (length insps > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath' - maybe - (return False) - (upToDate (FileModule fpath' Nothing) []) - (listToMaybe insps) - --- | Get source file --- refineSourceFile :: CommandMonad m => Path -> m Path --- refineSourceFile fpath = do --- fpath' <- findPath fpath --- fs <- liftM (map fromOnly) $ query "select file from modules where file == ?;" (Only fpath') --- case fs of --- [] -> hsdevError (NotInspected $ FileModule fpath' Nothing) --- (f:_) -> do --- when (length fs > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath' --- return f - --- | Get module by source -refineSourceModule :: CommandMonad m => Path -> m Module -refineSourceModule fpath = do - fpath' <- findPath fpath - ids <- query "select id, cabal from modules where file == ?;" (Only fpath') - case ids of - [] -> hsdevError (NotInspected $ FileModule fpath' Nothing) - ((i, mcabal):_) -> do - when (length ids > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath' - m <- SQLite.loadModule i - case mcabal of - Nothing -> do - [insp] <- query @_ @Inspection "select inspection_time, inspection_opts from modules where id = ?;" (Only i) - fresh' <- upToDate (m ^. moduleId . moduleLocation) [] insp - if fresh' - then return m - else do - defs <- askSession sessionDefines - mcts <- fmap (fmap snd) $ getFileContents fpath' - ip' <- runInspect (m ^. moduleId . moduleLocation) $ preload (m ^. moduleId . moduleName) defs [] mcts - case ip' ^? inspected of - Just p' -> return $ set moduleImports (p' ^. asModule . moduleImports) m - Nothing -> return m - Just cabal' -> do - proj' <- SQLite.loadProject cabal' - return $ set (moduleId . moduleLocation . moduleProject) (Just proj') m - --- | Get file contents -actualFileContents :: CommandMonad m => FileSource -> m FileSource -actualFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath) -actualFileContents fcts = return fcts - --- | Set session by source -setFileSourceSession :: CommandMonad m => [String] -> Path -> m Module -setFileSourceSession opts fpath = do - m <- refineSourceModule fpath - inSessionGhc $ targetSession opts m - return m - --- | Ensure package exists --- refinePackage :: CommandMonad m => Text -> m Text --- refinePackage pkg = do --- [(Only exists)] <- query "select count(*) > 0 from package_dbs where package_name == ?;" (Only pkg) --- when (not exists) $ hsdevError (PackageNotFound pkg) --- return pkg - --- | Get list of enumerated sandboxes -getSandboxes :: CommandMonad m => [Path] -> m [Sandbox] -getSandboxes = traverse (findPath >=> findSandbox) - --- | Find project by name or path -findProject :: CommandMonad m => Text -> m Project -findProject proj = do - proj' <- liftM addCabal $ findPath proj - ps <- liftM (map fromOnly) $ query "select cabal from projects where (cabal == ?) or (name == ?);" (view path proj', proj) - case ps of - [] -> hsdevError $ ProjectNotFound proj - _ -> SQLite.loadProject (head ps) - where - addCabal p - | takeExtension (view path p) == ".cabal" = p - | otherwise = over path (\p' -> p' (takeBaseName p' <.> "cabal")) p - --- | Run DB update action -updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM IO ()] -> ClientM m () -updateProcess uopts acts = hoist liftIO $ do - copts <- getOptions - inSessionUpdater $ hoist (flip runReaderT copts) $ runClientM $ mapM_ (Update.runUpdate uopts . runAct) acts - where - runAct act = catch act onError - onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError) +{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeOperators, TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module HsDev.Client.Commands ( + runClient, runCommand + ) where + +import Control.Arrow (second) +import Control.Concurrent.MVar +import Control.Exception (displayException) +import Control.Lens hiding ((.=), (<.>)) +import Control.Monad +import Control.Monad.Morph +import Control.Monad.Except +import Control.Monad.Reader +import qualified Control.Monad.State as State +import Control.Monad.Catch (try, catch, bracket, SomeException(..)) +import Data.Aeson hiding (Result, Error) +import Data.List +import Data.Maybe +import qualified Data.Map.Strict as M +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T (append, null) +import System.Directory +import System.FilePath +import qualified System.Log.Simple as Log +import qualified System.Log.Simple.Base as Log +import Text.Read (readMaybe) + +import Data.Maybe.JustIf +import qualified System.Directory.Watcher as W +import System.Directory.Paths +import Text.Format +import HsDev.Error +import HsDev.Database.SQLite as SQLite +import HsDev.Inspect (preload, asModule) +import HsDev.Scan (upToDate, getFileContents) +import HsDev.Server.Message as M +import HsDev.Server.Types +import HsDev.Sandbox hiding (findSandbox) +import qualified HsDev.Sandbox as S (findSandbox) +import HsDev.Symbols +import qualified HsDev.Tools.AutoFix as AutoFix +import qualified HsDev.Tools.Cabal as Cabal +import HsDev.Tools.Ghc.Session +import HsDev.Tools.Ghc.Worker (clearTargets) +import qualified HsDev.Tools.Ghc.Compat as Compat +import qualified HsDev.Tools.Ghc.Check as Check +import qualified HsDev.Tools.Ghc.Types as Types +import qualified HsDev.Tools.Hayoo as Hayoo +import qualified HsDev.Tools.HDocs as HDocs +import qualified HsDev.Tools.HLint as HLint +import qualified HsDev.Tools.Types as Tools +import HsDev.Util +import HsDev.Watcher + +import qualified HsDev.Database.Update as Update + +runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result +runClient copts = mapServerM toResult . runClientM where + toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result + toResult act = liftM errorToResult $ runReaderT (try (try act)) copts + mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b + mapServerM f = ServerM . mapReaderT f . runServerM + errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result + errorToResult = either (Error . UnhandledError . displayException) (either Error (Result . toJSON)) + +toValue :: (ToJSON a, Monad m) => m a -> m Value +toValue = fmap toJSON + +runCommand :: ServerMonadBase m => Command -> ClientM m Value +runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)] +runCommand (Listen (Just l)) = case Log.level (pack l) of + Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l + Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing) +runCommand (Listen Nothing) = toValue $ do + serverListen >>= mapM_ (commandNotify . Notification . toJSON) +runCommand (SetLogLevel l) = case Log.level (pack l) of + Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l + Just lev -> toValue $ do + lev' <- serverSetLogLevel lev + Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev + Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev +runCommand (Scan projs cabal sboxes fs paths' btool ghcs' docs' infer') = toValue $ do + sboxes' <- getSandboxes sboxes + updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [ + [Update.scanCabal ghcs' | cabal], + map (Update.scanSandbox ghcs') sboxes', + [Update.scanFiles (zip fs (repeat ghcs'))], + map (Update.scanProject ghcs' btool) projs, + map (Update.scanDirectory ghcs') paths'] +runCommand (ScanProject proj tool deps) = toValue $ updateProcess def [ + (if deps then Update.scanProjectStack else Update.scanProject) [] tool proj] +runCommand (ScanFile fpath tool scanProj deps) = toValue $ updateProcess def [ + Update.scanFile [] fpath tool scanProj deps] +runCommand (ScanPackageDbs pdbs) = toValue $ updateProcess def [ + Update.scanPackageDbStack [] pdbs] +runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts +runCommand (RefineDocs projs fs) + | HDocs.hdocsSupported = toValue $ do + projects <- traverse findProject projs + mods <- do + projMods <- liftM concat $ forM projects $ \proj -> do + ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.docs') is null" + (Only $ proj ^. projectCabal) + p <- SQLite.loadProject (proj ^. projectCabal) + return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms + fileMods <- liftM concat $ forM fs $ \f -> + loadModules "select id from modules where file == ? and json_extract(tags, '$.docs') is null" + (Only f) + return $ projMods ++ fileMods + updateProcess def [Update.scanDocs mods] + | otherwise = hsdevError $ OtherError "docs not supported" +runCommand (InferTypes projs fs) = toValue $ do + projects <- traverse findProject projs + mods <- do + projMods <- liftM concat $ forM projects $ \proj -> do + ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.types') is null" + (Only $ proj ^. projectCabal) + p <- SQLite.loadProject (proj ^. projectCabal) + return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms + fileMods <- liftM concat $ forM fs $ \f -> + loadModules "select id from modules where file == ? and json_extract(tags, '$.types') is null" + (Only f) + return $ projMods ++ fileMods + updateProcess def [Update.inferModTypes mods] +runCommand (Remove projs cabal sboxes files) = toValue $ withSqlConnection $ SQLite.transaction_ SQLite.Immediate $ do + let + -- We can safely remove package-db from db iff doesn't used by some of other package-dbs + -- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db + -- We also can't remove stack snapshot package-db if there are some local package-db not yet removed + canRemove pdbs = do + from' <- State.get + return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from' + -- Remove top of package-db stack if possible + removePackageDb' pdbs = do + can <- canRemove pdbs + when can $ do + State.modify (delete pdbs) + ms <- liftM (map fromOnly) $ query_ + "select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;" + removePackageDb (topPackageDb pdbs) + mapM_ SQLite.removeModule ms + whenJustM (askSession sessionWatcher) $ \w -> + liftIO $ unwatchPackageDb w $ topPackageDb pdbs + -- Remove package-db stack when possible + removePackageDbStack = mapM_ removePackageDb' . packageDbStacks + projects <- traverse findProject projs + sboxes' <- getSandboxes sboxes + forM_ projects $ \proj -> do + ms <- liftM (map fromOnly) $ query "select id from modules where cabal == ?;" (Only $ proj ^. projectCabal) + SQLite.removeProject proj + mapM_ SQLite.removeModule ms + whenJustM (askSession sessionWatcher) $ \w -> + liftIO $ unwatchProject w proj + + allPdbs <- liftM (map fromOnly) $ query_ @(Only PackageDb) "select package_db from package_dbs;" + dbPDbs <- inSessionGhc $ mapM restorePackageDbStack allPdbs + flip State.evalStateT dbPDbs $ do + when cabal $ removePackageDbStack userDb + forM_ sboxes' $ \sbox -> do + pdbs <- lift $ inSessionGhc $ sandboxPackageDbStack sbox + removePackageDbStack pdbs + + forM_ files $ \file -> do + ms <- query @_ @(ModuleId :. Only Int) + (toQuery $ mconcat [ + qModuleId, + select_ ["mu.id"], + where_ ["mu.file == ?"]]) + (Only file) + forM_ ms $ \(m :. Only i) -> do + SQLite.removeModule i + whenJustM (askSession sessionWatcher) $ \w -> + liftIO . unwatchModule w $ (m ^. moduleLocation) +runCommand RemoveAll = toValue $ do + SQLite.purge + whenJustM (askSession sessionWatcher) $ \w -> do + wdirs <- liftIO $ readMVar (W.watcherDirs w) + liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir +runCommand InfoPackages = toValue $ + query_ @ModulePackage "select package_name, package_version from package_dbs;" +runCommand InfoProjects = toValue $ do + ps <- query_ @(Only Path) "select cabal from projects;" + mapM (SQLite.loadProject . fromOnly) ps +runCommand InfoSandboxes = toValue $ do + rs <- query_ @(Only PackageDb) "select distinct package_db from package_dbs;" + return [pdb | Only pdb <- rs] +runCommand (InfoSymbol sq filters True _) = toValue $ do + let + (conds, params) = targetFilters "m" (Just "s") filters + queryNamed @SymbolId + (toQuery $ mconcat [ + qSymbolId, + where_ ["s.name like :pattern escape '\\'"], + where_ conds]) + ([":pattern" := likePattern sq] ++ params) +runCommand (InfoSymbol sq filters False _) = toValue $ do + let + (conds, params) = targetFilters "m" (Just "s") filters + queryNamed @Symbol + (toQuery $ mconcat [ + qSymbol, + where_ ["s.name like :pattern escape '\\'"], + where_ conds]) + ([":pattern" := likePattern sq] ++ params) +runCommand (InfoModule sq filters h _) = toValue $ do + let + (conds, params) = targetFilters "mu" Nothing filters + rs <- queryNamed @(Only Int :. ModuleId) + (toQuery $ mconcat [ + select_ ["mu.id"], + qModuleId, + where_ ["mu.name like :pattern escape '\\'"], + where_ conds]) + ([":pattern" := likePattern sq] ++ params) + if h + then return (toJSON $ map (\(_ :. m) -> m) rs) + else liftM toJSON $ forM rs $ \(Only mid :. mheader) -> do + [(docs, fixities)] <- query @_ @(Maybe Text, Maybe Value) "select m.docs, m.fixities from modules as m where (m.id == ?);" + (Only mid) + let + fixities' = fromMaybe [] (fixities >>= fromJSON') + imports' <- query @_ @Import (toQuery $ mconcat [ + qImport "i", + where_ ["i.module_id = ?"]]) + (Only mid) + exports' <- query @_ @Symbol (toQuery $ mconcat [ + qSymbol, + from_ ["exports as e"], + where_ ["e.module_id == ?", "e.symbol_id == s.id"]]) + (Only mid) + return $ Module mheader docs imports' exports' fixities' mempty Nothing +runCommand (InfoProject (Left projName)) = toValue $ findProject projName +runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject (view path projPath) +runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandboxes sandbox' +runCommand (Lookup nm fpath) = toValue $ + fmap (map (\(s :. m) -> ImportedSymbol s m)) $ query @_ @(Symbol :. ModuleId) (toQuery $ mconcat [ + qSymbol, + qModuleId, + from_ ["projects_modules_scope as pms", "modules as srcm", "exports as e"], + where_ [ + "pms.cabal is srcm.cabal", + "srcm.file = ?", + "pms.module_id = e.module_id", + "m.id = s.module_id", + "s.id = e.symbol_id", + "e.module_id = mu.id", + "s.name = ?"]]) + (fpath ^. path, nm) +runCommand (Whois nm fpath) = toValue $ do + let + q = nameModule $ toName nm + ident = nameIdent $ toName nm + query @_ @Symbol (toQuery $ mconcat [ + qSymbol, + from_ ["modules as srcm", "scopes as sc"], + where_ [ + "srcm.id == sc.module_id", + "s.id == sc.symbol_id", + "srcm.file == ?", + "sc.qualifier is ?", + "sc.name == ?"]]) + (fpath ^. path, q, ident) +runCommand (Whoat l c fpath) = toValue $ do + rs <- query @_ @Symbol (toQuery $ mconcat [ + qSymbol, + from_ ["names as n", "modules as srcm"], + where_ [ + "srcm.id == n.module_id", + "m.name == n.resolved_module", + "s.name == n.resolved_name", + "s.what == n.resolved_what", + "s.id == n.symbol_id", + "srcm.file == ?", + "(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]]) + (fpath ^. path, l, c) + locals <- do + defs <- query @_ @(ModuleId :. (Text, Int, Int, Maybe Text)) (toQuery $ mconcat [ + qModuleId, + select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type"], + from_ ["names as n"], + where_ [ + "mu.id == n.module_id", + "n.def_line is not null", + "n.def_column is not null", + "mu.file == ?", + "(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]]) + (fpath ^. path, l, c) + return [ + Symbol { + _symbolId = SymbolId nm mid, + _symbolDocs = Nothing, + _symbolPosition = Just (Position defLine defColumn), + _symbolInfo = Function ftype + } | (mid :. (nm, defLine, defColumn, ftype)) <- defs] + return $ rs ++ locals +runCommand (ResolveScopeModules sq fpath) = toValue $ do + pids <- query @_ @(Only (Maybe Path)) "select m.cabal from modules as m where (m.file == ?);" + (Only $ fpath ^. path) + case pids of + [] -> hsdevError $ OtherError $ "module at {} not found" ~~ fpath + [Only proj] -> query @_ @ModuleId (toQuery $ mconcat [ + qModuleId, + from_ ["projects_modules_scope as msc"], + where_ [ + "msc.module_id == mu.id", + "msc.cabal is ?", + "mu.name like ? escape '\\'"]]) + (proj, likePattern sq) + _ -> fail "Impossible happened: several projects for one module" +runCommand (ResolveScope sq fpath) = toValue $ + query @_ @(Scoped SymbolId) (toQuery $ mconcat [ + qSymbolId, + select_ ["sc.qualifier"], + from_ ["scopes as sc", "modules as srcm"], + where_ [ + "srcm.id == sc.module_id", + "sc.symbol_id == s.id", + "srcm.file == ?", + "s.name like ? escape '\\'"]]) + (fpath ^. path, likePattern sq) +runCommand (FindUsages l c fpath) = toValue $ do + us <- do + sids <- query @_ @(Only (Maybe Int)) (toQuery $ mconcat [ + select_ ["n.symbol_id"], + from_ ["names as n", "modules as srcm"], + where_ [ + "n.module_id == srcm.id", + "(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)", + "srcm.file = ?"]]) + (l, c, fpath) + when (length sids > 1) $ Log.sendLog Log.Warning $ "multiple symbols found at location {0}:{1}:{2}" ~~ fpath ~~ l ~~ c + let + msid = join $ fmap fromOnly $ listToMaybe sids + query @_ @SymbolUsage (toQuery $ mconcat [ + qSymbol, + select_ ["n.qualifier"], + qModuleId, + select_ ["n.line", "n.column", "n.line_to", "n.column_to"], + from_ ["names as n"], + where_ [ + "n.symbol_id == ?", + "s.id == n.symbol_id", + "mu.id == n.module_id"]]) + (Only msid) + locals <- do + defs <- query @_ @(ModuleId :. Only Text :. Position :. Only (Maybe Text) :. Region) (toQuery $ mconcat [ + qModuleId, + select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type", "n.line", "n.column", "n.line_to", "n.column_to"], + from_ ["names as n", "names as defn"], + where_ [ + "n.module_id = mu.id", + "n.def_line = defn.def_line", + "n.def_column = defn.def_column", + "defn.module_id = mu.id", + "(?, ?) between (defn.line, defn.column) and (defn.line_to, defn.column_to)", + "mu.file = ?"]]) + (l, c, fpath ^. path) + return $ do + (mid :. Only nm :. defPos :. Only ftype :. useRgn) <- defs + let + sym = Symbol { + _symbolId = SymbolId nm mid, + _symbolDocs = Nothing, + _symbolPosition = Just defPos, + _symbolInfo = Function ftype } + return $ SymbolUsage sym Nothing mid useRgn + return $ us ++ locals +runCommand (Complete input True fpath) = toValue $ + query @_ @Symbol (toQuery $ mconcat [ + qSymbol, + from_ ["modules as srcm", "exports as e"], + where_ [ + "e.module_id in (select srcm.id union select module_id from projects_modules_scope where (((cabal is null) and (srcm.cabal is null)) or (cabal == srcm.cabal)))", + "s.id == e.symbol_id", + "msrc.file == ?", + "s.name like ? escape '\\'"]]) + (fpath ^. path, likePattern (SearchQuery input SearchPrefix)) +runCommand (Complete input False fpath) = toValue $ + query @_ @(Scoped Symbol) (toQuery $ mconcat [ + qSymbol, + select_ ["c.qualifier"], + from_ ["completions as c", "modules as srcm"], + where_ [ + "c.module_id == srcm.id", + "c.symbol_id == s.id", + "srcm.file == ?", + "c.completion like ? escape '\\'"]]) + (fpath ^. path, likePattern (SearchQuery input SearchPrefix)) +runCommand (Hayoo hq p ps) = do + m <- askSession sessionHTTPManager + toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM + (mapMaybe Hayoo.hayooAsSymbol . Hayoo.resultResult) $ + liftIO $ hsdevLift $ Hayoo.hayoo m hq (Just i) +runCommand (CabalList packages') = toValue $ liftIO $ hsdevLift $ Cabal.cabalList $ map unpack packages' +runCommand (UnresolvedSymbols fs) = toValue $ liftM concat $ forM fs $ \f -> do + rs <- query @_ @(Maybe String, String, Int, Int) "select n.qualifier, n.name, n.line, n.column from modules as m, names as n where (m.id == n.module_id) and (m.file == ?) and (n.resolve_error is not null);" + (Only $ f ^. path) + return $ map (\(m, nm, line, column) -> object [ + "qualifier" .= m, + "name" .= nm, + "line" .= line, + "column" .= column]) rs +runCommand (Lint fs lints) = toValue $ liftM concat $ forM fs $ \fsrc -> do + FileSource f c <- actualFileContents fsrc + liftIO $ hsdevLift $ HLint.hlint lints (view path f) c +runCommand (Check fs ghcs' clear) = toValue $ Log.scope "check" $ + liftM concat $ mapM (runCheck ghcs' clear) fs +runCommand (CheckLint fs ghcs' lints clear) = toValue $ do + fs' <- mapM actualFileContents fs + checkMsgs <- liftM concat $ mapM (runCheck ghcs' clear) fs' + lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint lints (view path f) c) fs' + return $ checkMsgs ++ lintMsgs +runCommand (Types fs ghcs' clear) = toValue $ do + liftM concat $ forM fs $ \fsrc@(FileSource file msrc) -> do + mcached' <- getCached file msrc + FileSource _ msrc' <- actualFileContents fsrc + maybe (updateTypes file msrc') return mcached' + where + getCached :: ServerMonadBase m => Path -> Maybe Text -> ClientM m (Maybe [Tools.Note Types.TypedExpr]) + getCached _ (Just _) = return Nothing + getCached file' Nothing = do + actual' <- sourceUpToDate file' + mid <- query @_ @((Bool, Int) :. ModuleId) + (toQuery $ mconcat [ + select_ ["json_extract(tags, '$.types') is 1", "mu.id"], + qModuleId, + where_ ["mu.file = ?"]]) + (Only file') + when (length mid > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ file' + when (null mid) $ hsdevError $ NotInspected $ FileModule file' Nothing + let + [(hasTypes', mid') :. modId] = mid + if actual' && hasTypes' + then do + types' <- query @_ @(Region :. Types.TypedExpr) "select line, column, line_to, column_to, expr, type from types where module_id = ?;" (Only mid') + liftM Just $ forM types' $ \(rgn :. texpr) -> return Tools.Note { + Tools._noteSource = modId ^. moduleLocation, + Tools._noteRegion = rgn, + Tools._noteLevel = Nothing, + Tools._note = set Types.typedExpr Nothing texpr } + else return Nothing + + updateTypes file msrc = do + sess <- getSession + m <- setFileSourceSession ghcs' file + types' <- inSessionGhc $ do + when clear clearTargets + Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $ + Types.fileTypes m msrc + updateProcess def [Update.setModTypes (m ^. moduleId) types'] + return $ set (each . Tools.note . Types.typedExpr) Nothing types' +runCommand (AutoFix ns) = toValue $ return $ AutoFix.corrections ns +runCommand (Refactor ns rest isPure) = toValue $ do + files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns + let + runFix file = do + unless isPure $ do + liftIO $ readFileUtf8 (view path file) >>= writeFileUtf8 (view path file) . AutoFix.refact fixRefacts' + return newCorrs' + where + findCorrs :: Path -> [Tools.Note AutoFix.Refact] -> [Tools.Note AutoFix.Refact] + findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile)) + fixCorrs' = findCorrs file ns + upCorrs' = findCorrs file rest + fixRefacts' = fixCorrs' ^.. each . Tools.note + newCorrs' = AutoFix.update fixRefacts' upCorrs' + liftM concat $ mapM runFix files +runCommand (Rename nm newName fpath) = toValue $ do + m <- refineSourceModule fpath + let + mname = m ^. moduleId . moduleName + makeNote mloc r = Tools.Note { + Tools._noteSource = mloc, + Tools._noteRegion = r, + Tools._noteLevel = Nothing, + Tools._note = AutoFix.Refact "rename" (AutoFix.replace (AutoFix.fromRegion r) newName) } + + defRenames <- do + -- FIXME: Doesn't take scope into account. If you have modules with same names in different project, it will rename symbols from both + defRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and def_line is not null;" ( + mname, + nm) + return $ map (makeNote (m ^. moduleId . moduleLocation)) defRegions + + usageRenames <- do + -- FIXME: Same as above: doesn't take scope into account + usageRegions <- query @_ @(Only Path :. Region) "select m.file, n.line, n.column, n.line_to, n.column_to from names as n, modules as m where n.module_id == m.id and m.file is not null and n.resolved_module == ? and n.resolved_name == ?;" ( + mname, + nm) + return $ map (\(Only p :. r) -> makeNote (FileModule p Nothing) r) usageRegions + + return $ defRenames ++ usageRenames +runCommand (GhcEval exprs mfile) = toValue $ do + mfile' <- traverse actualFileContents mfile + case mfile' of + Nothing -> inSessionGhc ghciSession + Just (FileSource f mcts) -> do + m <- setFileSourceSession [] f + inSessionGhc $ interpretModule m mcts + inSessionGhc $ mapM (tryRepl . evaluate) exprs +runCommand (GhcType exprs mfile) = toValue $ do + mfile' <- traverse actualFileContents mfile + case mfile' of + Nothing -> inSessionGhc ghciSession + Just (FileSource f mcts) -> do + m <- setFileSourceSession [] f + inSessionGhc $ interpretModule m mcts + inSessionGhc $ mapM (tryRepl . expressionType) exprs +runCommand Langs = toValue $ return Compat.languages +runCommand Flags = toValue $ return ["-f" ++ prefix ++ f | + f <- Compat.flags, + prefix <- ["", "no-"]] +runCommand (Link hold) = toValue $ commandLink >> when hold commandHold +runCommand StopGhc = toValue $ do + inSessionGhc $ do + ms <- findSessionBy (const True) + forM_ ms $ \s -> do + Log.sendLog Log.Trace $ "stopping session: {}" ~~ view sessionKey s + deleteSession $ view sessionKey s +runCommand Exit = toValue serverExit + + +targetFilter :: Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam]) +targetFilter mtable _ (TargetProject proj) = ( + "{t}.cabal in (select cabal from projects where name == :project or cabal == :project)" ~~ ("t" ~% mtable), + [":project" := proj]) +targetFilter mtable _ (TargetFile f) = ("{t}.file == :file" ~~ ("t" ~% mtable), [":file" := f]) +targetFilter mtable Nothing (TargetModule nm) = ("{t}.name == :module_name" ~~ ("t" ~% mtable), [":module_name" := nm]) +targetFilter mtable (Just stable) (TargetModule nm) = ( + "({t}.name == :module_name) or ({s}.id in (select e.symbol_id from exports as e, modules as em where e.module_id == em.id and em.name == :module_name))" + ~~ ("t" ~% mtable) + ~~ ("s" ~% stable), + [":module_name" := nm]) +targetFilter mtable _ (TargetPackage p) = (tpl ~~ ("t" ~% mtable), params) where + pkg = fromMaybe (mkPackage p) (readMaybe (unpack p)) + tpl + | T.null (pkg ^. packageVersion) = "{t}.package_name == :package_name" + | otherwise = "{t}.package_name == :package_name and {t}.package_version == :package_version" + params + | T.null (pkg ^. packageVersion) = [pname] + | otherwise = [pname, pver] + pname = ":package_name" := (pkg ^. packageName) + pver = ":package_version" := (pkg ^. packageVersion) +targetFilter mtable _ TargetInstalled = ("{t}.package_name is not null" ~~ ("t" ~% mtable), []) +targetFilter mtable _ TargetSourced = ("{t}.file is not null" ~~ ("t" ~% mtable), []) +targetFilter mtable _ TargetStandalone = ("{t}.file is not null and {t}.cabal is null" ~~ ("t" ~% mtable), []) + +targetFilters :: Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam]) +targetFilters mtable stable = second concat . unzip . map (targetFilter mtable stable) + +likePattern :: SearchQuery -> Text +likePattern (SearchQuery input stype) = case stype of + SearchExact -> escapedInput + SearchPrefix -> escapedInput `T.append` "%" + SearchInfix -> "%" `T.append` escapedInput `T.append` "%" + SearchSuffix -> "%" `T.append` escapedInput + where + escapedInput = escapeLike input + +instance ToJSON Log.Message where + toJSON m = object [ + "time" .= Log.messageTime m, + "level" .= show (Log.messageLevel m), + "component" .= show (Log.messageComponent m), + "scope" .= show (Log.messageScope m), + "text" .= Log.messageText m] + +instance FromJSON Log.Message where + parseJSON = withObject "log-message" $ \v -> Log.Message <$> + (v .:: "time") <*> + ((v .:: "level") >>= maybe (fail "invalid level") return . readMaybe) <*> + (read <$> (v .:: "component")) <*> + (read <$> (v .:: "scope")) <*> + (v .:: "text") + + +-- | Run check +runCheck :: CommandMonad m => [String] -> Bool -> FileSource -> m [Tools.Note Tools.OutputMessage] +runCheck ghcs' clear = actualFileContents >=> check' where + check' (FileSource file mcts) = Log.scope "run-check" $ do + Log.sendLog Log.Trace $ "setting file source session for {}" ~~ file + sess <- getSession + m <- setFileSourceSession ghcs' file + Log.sendLog Log.Trace "file source session set" + ns <- inSessionGhc $ do + when clear clearTargets + Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $ + Check.check m mcts + if null ns + then do + ns' <- Update.cachedWarnings [m ^. moduleId . moduleLocation] + unless (null ns') $ + Log.sendLog Log.Trace $ "returning {} cached warnings for {}" ~~ length ns' ~~ file + return ns' + else return ns + +-- Helper functions + +-- | Canonicalize paths +findPath :: (CommandMonad m, Paths a) => a -> m a +findPath = paths findPath' where + findPath' :: CommandMonad m => FilePath -> m FilePath + findPath' f = do + r <- commandRoot + liftIO $ canonicalizePath (normalise $ if isRelative f then r f else f) + +-- | Find sandbox by path +findSandbox :: CommandMonad m => Path -> m Sandbox +findSandbox fpath = do + fpath' <- findPath fpath + sbox <- liftIO $ S.findSandbox fpath' + maybe (hsdevError $ FileNotFound fpath') return sbox + +-- | Check if source file up to date +sourceUpToDate :: CommandMonad m => Path -> m Bool +sourceUpToDate fpath = do + fpath' <- findPath fpath + insps <- query @_ @Inspection "select inspection_time, inspection_opts from modules where file = ?;" (Only fpath') + when (length insps > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath' + maybe + (return False) + (upToDate (FileModule fpath' Nothing) []) + (listToMaybe insps) + +-- | Get source file +-- refineSourceFile :: CommandMonad m => Path -> m Path +-- refineSourceFile fpath = do +-- fpath' <- findPath fpath +-- fs <- liftM (map fromOnly) $ query "select file from modules where file == ?;" (Only fpath') +-- case fs of +-- [] -> hsdevError (NotInspected $ FileModule fpath' Nothing) +-- (f:_) -> do +-- when (length fs > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath' +-- return f + +-- | Get module by source +refineSourceModule :: CommandMonad m => Path -> m Module +refineSourceModule fpath = do + fpath' <- findPath fpath + ids <- query "select id, cabal from modules where file == ?;" (Only fpath') + case ids of + [] -> hsdevError (NotInspected $ FileModule fpath' Nothing) + ((i, mcabal):_) -> do + when (length ids > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath' + m <- SQLite.loadModule i + case mcabal of + Nothing -> do + [insp] <- query @_ @Inspection "select inspection_time, inspection_opts from modules where id = ?;" (Only i) + fresh' <- upToDate (m ^. moduleId . moduleLocation) [] insp + if fresh' + then return m + else do + defs <- askSession sessionDefines + mcts <- fmap (fmap snd) $ getFileContents fpath' + ip' <- runInspect (m ^. moduleId . moduleLocation) $ preload (m ^. moduleId . moduleName) defs [] mcts + case ip' ^? inspected of + Just p' -> return $ set moduleImports (p' ^. asModule . moduleImports) m + Nothing -> return m + Just cabal' -> do + proj' <- SQLite.loadProject cabal' + return $ set (moduleId . moduleLocation . moduleProject) (Just proj') m + +-- | Get file contents +actualFileContents :: CommandMonad m => FileSource -> m FileSource +actualFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath) +actualFileContents fcts = return fcts + +-- | Set session by source +setFileSourceSession :: CommandMonad m => [String] -> Path -> m Module +setFileSourceSession opts fpath = do + m <- refineSourceModule fpath + inSessionGhc $ targetSession opts m + return m + +-- | Ensure package exists +-- refinePackage :: CommandMonad m => Text -> m Text +-- refinePackage pkg = do +-- [(Only exists)] <- query "select count(*) > 0 from package_dbs where package_name == ?;" (Only pkg) +-- when (not exists) $ hsdevError (PackageNotFound pkg) +-- return pkg + +-- | Get list of enumerated sandboxes +getSandboxes :: CommandMonad m => [Path] -> m [Sandbox] +getSandboxes = traverse (findPath >=> findSandbox) + +-- | Find project by name or path +findProject :: CommandMonad m => Text -> m Project +findProject proj = do + proj' <- liftM addCabal $ findPath proj + ps <- liftM (map fromOnly) $ query "select cabal from projects where (cabal == ?) or (name == ?);" (view path proj', proj) + case ps of + [] -> hsdevError $ ProjectNotFound proj + _ -> SQLite.loadProject (head ps) + where + addCabal p + | takeExtension (view path p) == ".cabal" = p + | otherwise = over path (\p' -> p' (takeBaseName p' <.> "cabal")) p + +-- | Run DB update action +updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM IO ()] -> ClientM m () +updateProcess uopts acts = hoist liftIO $ do + copts <- getOptions + inSessionUpdater $ hoist (flip runReaderT copts) $ runClientM $ mapM_ (Update.runUpdate uopts . runAct) acts + where + runAct act = catch act onError + onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError) diff --git a/src/HsDev/Database/SQLite.hs b/src/HsDev/Database/SQLite.hs --- a/src/HsDev/Database/SQLite.hs +++ b/src/HsDev/Database/SQLite.hs @@ -1,501 +1,501 @@ -{-# LANGUAGE OverloadedStrings, TypeOperators, TypeApplications #-} - -module HsDev.Database.SQLite ( - initialize, purge, - privateMemory, sharedMemory, - query, query_, queryNamed, execute, execute_, executeMany, executeNamed, - withTemporaryTable, - updatePackageDb, removePackageDb, insertPackageDb, - updateProject, removeProject, insertProject, insertBuildInfo, - removeModuleContents, removeModule, - lookupModuleLocation, lookupModule, - lookupSymbol, - lastRow, - - loadModule, loadModules, - loadProject, - - updateModules, upsertModules, - - -- * Utils - lookupId, - escapeLike, - - -- * Reexports - module Database.SQLite.Simple, - module HsDev.Database.SQLite.Select, - module HsDev.Database.SQLite.Instances, - module HsDev.Database.SQLite.Transaction - ) where - -import Control.Lens hiding ((.=)) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.Aeson hiding (Error) -import Data.List (intercalate) -import Data.Maybe -import Data.String -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Database.SQLite.Simple hiding (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction) -import qualified Database.SQLite.Simple as SQL (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction) -import Distribution.Text (display) -import Language.Haskell.Extension () -import System.Directory -import System.Log.Simple -import Text.Format - -import System.Directory.Paths - -import HsDev.Database.SQLite.Instances -import HsDev.Database.SQLite.Schema -import HsDev.Database.SQLite.Select -import HsDev.Database.SQLite.Transaction -import qualified HsDev.Display as Display -import HsDev.Error -import HsDev.PackageDb.Types -import HsDev.Project.Types -import HsDev.Symbols (hasTag) -import HsDev.Symbols.Types hiding (loadProject) -import HsDev.Server.Types -import HsDev.Util - --- | Open new connection and set some pragmas -new :: String -> IO Connection -new p = do - conn <- open p - SQL.execute_ conn "pragma case_sensitive_like = true;" - SQL.execute_ conn "pragma synchronous = off;" - SQL.execute_ conn "pragma journal_mode = memory;" - return conn - --- | Initialize database -initialize :: String -> IO Connection -initialize p = do - conn <- new p - [Only hasTables] <- SQL.query_ conn "select count(*) > 0 from sqlite_master where type == 'table';" - goodVersion <- if hasTables - then do - [Only equalVersion] <- SQL.query conn "select sum(json(value) == json(?)) > 0 from hsdev where option == 'version';" (Only $ toJSON version) - return equalVersion - else return True - let - start - | not goodVersion = do - close conn - removeFile p - conn' <- new p - initDb conn' - | not hasTables = initDb conn - | otherwise = return conn - initDb conn' = SQL.withTransaction conn' $ do - mapM_ (SQL.execute_ conn') commands - SQL.execute @(Text, Value) conn' "insert into hsdev values (?, ?);" ("version", toJSON version) - return conn' - start - -purge :: SessionMonad m => m () -purge = do - tables <- query_ @(Only String) "select name from sqlite_master where type == 'table';" - forM_ tables $ \(Only table) -> - execute_ $ fromString $ "delete from {};" ~~ table - --- | Private memory for db -privateMemory :: String -privateMemory = ":memory:" - --- | Shared db in memory -sharedMemory :: String -sharedMemory = "file::memory:?cache=shared" - --- | Retries for simple queries -retried :: (MonadIO m, MonadCatch m) => m a -> m a -retried = retry def - -query :: (ToRow q, FromRow r, SessionMonad m) => Query -> q -> m [r] -query q' params = retried $ do - conn <- serverSqlDatabase - liftIO $ SQL.query conn q' params - -query_ :: (FromRow r, SessionMonad m) => Query -> m [r] -query_ q' = retried $ do - conn <- serverSqlDatabase - liftIO $ SQL.query_ conn q' - -queryNamed :: (FromRow r, SessionMonad m) => Query -> [NamedParam] -> m [r] -queryNamed q' ps' = retried $ do - conn <- serverSqlDatabase - liftIO $ SQL.queryNamed conn q' ps' - -execute :: (ToRow q, SessionMonad m) => Query -> q -> m () -execute q' params = retried $ do - conn <- serverSqlDatabase - liftIO $ SQL.execute conn q' params - -execute_ :: SessionMonad m => Query -> m () -execute_ q' = retried $ do - conn <- serverSqlDatabase - liftIO $ SQL.execute_ conn q' - -executeMany :: (ToRow q, SessionMonad m) => Query -> [q] -> m () -executeMany q' params = do - conn <- serverSqlDatabase - liftIO $ SQL.executeMany conn q' params - -executeNamed :: SessionMonad m => Query -> [NamedParam] -> m () -executeNamed q' ps' = do - conn <- serverSqlDatabase - liftIO $ SQL.executeNamed conn q' ps' - -withTemporaryTable :: SessionMonad m => String -> [String] -> m a -> m a -withTemporaryTable tableName columns = bracket_ createTable dropTable where - createTable = execute_ $ fromString $ "create temporary table {} ({});" ~~ tableName ~~ (intercalate ", " columns) - dropTable = execute_ $ fromString $ "drop table {};" ~~ tableName - -updatePackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m () -updatePackageDb pdb pkgs = scope "update-package-db" $ transaction_ Immediate $ do - sendLog Trace $ "update package-db: {}" ~~ Display.display pdb - removePackageDb pdb - insertPackageDb pdb pkgs - -removePackageDb :: SessionMonad m => PackageDb -> m () -removePackageDb pdb = scope "remove-package-db" $ - execute "delete from package_dbs where package_db == ?;" (Only pdb) - -insertPackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m () -insertPackageDb pdb pkgs = scope "insert-package-db" $ forM_ pkgs $ \pkg -> - execute - "insert into package_dbs (package_db, package_name, package_version) values (?, ?, ?);" - (pdb, pkg ^. packageName, pkg ^. packageVersion) - -updateProject :: SessionMonad m => Project -> m () -updateProject proj = scope "update-project" $ transaction_ Immediate $ do - sendLog Trace $ "update project: {}" ~~ Display.display proj - removeProject proj - insertProject proj - -removeProject :: SessionMonad m => Project -> m () -removeProject proj = scope "remove-project" $ do - projId <- query @_ @(Only Int) "select id from projects where cabal == ?;" (Only $ proj ^. projectCabal) - case projId of - [] -> return () - pids -> do - when (length pids > 1) $ - sendLog Warning $ "multiple projects for cabal {} found" ~~ (proj ^. projectCabal) - forM_ pids $ \pid -> do - bids <- query @_ @(Only Int) "select build_info_id from targets where project_id == ?;" pid - execute "delete from projects where id == ?;" pid - execute "delete from libraries where project_id == ?;" pid - execute "delete from executables where project_id == ?;" pid - execute "delete from tests where project_id == ?;" pid - forM_ bids $ \bid -> execute "delete from build_infos where id == ?;" bid - -insertProject :: SessionMonad m => Project -> m () -insertProject proj = scope "insert-project" $ do - execute "insert into projects (name, cabal, version, build_tool, package_db_stack) values (?, ?, ?, ?, ?);" proj - projId <- lastRow - - forM_ (proj ^? projectDescription . _Just . projectLibrary . _Just) $ \lib -> do - buildInfoId <- insertBuildInfo $ lib ^. libraryBuildInfo - execute "insert into libraries (project_id, modules, build_info_id) values (?, ?, ?);" - (projId, encode $ lib ^. libraryModules, buildInfoId) - - forM_ (proj ^.. projectDescription . _Just . projectExecutables . each) $ \exe -> do - buildInfoId <- insertBuildInfo $ exe ^. executableBuildInfo - execute "insert into executables (project_id, name, path, build_info_id) values (?, ?, ?, ?);" - (projId, exe ^. executableName, exe ^. executablePath . path, buildInfoId) - - forM_ (proj ^.. projectDescription . _Just . projectTests . each) $ \test -> do - buildInfoId <- insertBuildInfo $ test ^. testBuildInfo - execute "insert into tests (project_id, name, enabled, main, build_info_id) values (?, ?, ?, ?, ?);" - (projId, test ^. testName, test ^. testEnabled, test ^? testMain . _Just . path, buildInfoId) - -insertBuildInfo :: SessionMonad m => Info -> m Int -insertBuildInfo info = scope "insert-build-info" $ do - execute "insert into build_infos (depends, language, extensions, ghc_options, source_dirs, other_modules) values (?, ?, ?, ?, ?, ?);" ( - encode $ info ^. infoDepends, - fmap display $ info ^. infoLanguage, - encode $ map display $ info ^. infoExtensions, - encode $ info ^. infoGHCOptions, - encode $ info ^.. infoSourceDirs . each . path, - encode $ info ^. infoOtherModules) - lastRow - -removeModuleContents :: SessionMonad m => Int -> m () -removeModuleContents mid = scope "remove-module-contents" $ do - execute "delete from imports where module_id = ?;" (Only mid) - execute "delete from exports where module_id = ?;" (Only mid) - execute "delete from scopes where module_id = ?;" (Only mid) - execute "delete from names where module_id = ?;" (Only mid) - execute "delete from types where module_id = ?;" (Only mid) - execute "delete from symbols where module_id = ?;" (Only mid) - -removeModule :: SessionMonad m => Int -> m () -removeModule mid = scope "remove-module" $ do - removeModuleContents mid - execute "delete from modules where id == ?;" (Only mid) - -upsertModules :: SessionMonad m => [InspectedModule] -> m [Int] -upsertModules ims = scope "upsert-modules" $ bracket_ initTemp removeTemp $ do - executeMany "insert into upserted_modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ map moduleData ims - execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location));" - execute_ "insert or replace into modules (id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is not null;" - execute_ "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is null;" - execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location)) where id is null;" - - liftM (map fromOnly) $ query_ "select id from upserted_modules order by rowid;" - where - initTemp :: SessionMonad m => m () - initTemp = do - execute_ "create temporary table upserted_modules as select * from modules where 0;" - execute_ "create index upserted_modules_id_index on upserted_modules (id);" - - removeTemp :: SessionMonad m => m () - removeTemp = execute_ "drop table if exists upserted_modules;" - - moduleData im = ( - im ^? inspectedKey . moduleFile . path, - im ^? inspectedKey . moduleProject . _Just . projectCabal, - fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs), - im ^? inspectedKey . modulePackage . packageName, - im ^? inspectedKey . modulePackage . packageVersion, - im ^? inspectedKey . installedModuleName, - im ^? inspectedKey . installedModuleExposed, - im ^? inspectedKey . otherLocationName) - :. ( - msum [im ^? inspected . moduleId . moduleName, im ^? inspectedKey . installedModuleName], - im ^? inspected . moduleDocs, - fmap encode $ im ^? inspected . moduleFixities, - encode $ asDict $ im ^. inspectionTags, - fmap show $ im ^? inspectionResult . _Left) - :. - fromMaybe InspectionNone (im ^? inspection) - asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags] - -lookupModuleLocation :: SessionMonad m => ModuleLocation -> m (Maybe Int) -lookupModuleLocation m = do - mids <- queryNamed "select id from modules where (file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location);" [ - ":file" := m ^? moduleFile . path, - ":package_name" := m ^? modulePackage . packageName, - ":package_version" := m ^? modulePackage . packageVersion, - ":installed_name" := m ^? installedModuleName, - ":other_location" := m ^? otherLocationName] - when (length mids > 1) $ sendLog Warning $ "different modules with location: {}" ~~ Display.display m - return $ listToMaybe [mid | Only mid <- mids] - -lookupModule :: SessionMonad m => ModuleId -> m (Maybe Int) -lookupModule m = do - mids <- queryNamed "select id from modules where ((name is null and :name is null) or name = :name) and ((file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location));" [ - ":name" := m ^. moduleName, - ":file" := m ^? moduleLocation . moduleFile . path, - ":package_name" := m ^? moduleLocation . modulePackage . packageName, - ":package_version" := m ^? moduleLocation . modulePackage . packageVersion, - ":installed_name" := m ^? moduleLocation . installedModuleName, - ":other_location" := m ^? moduleLocation . otherLocationName] - when (length mids > 1) $ sendLog Warning $ "different modules with same name and location: {}" ~~ (m ^. moduleName) - return $ listToMaybe [mid | Only mid <- mids] - -lookupSymbol :: SessionMonad m => Int -> SymbolId -> m (Maybe Int) -lookupSymbol mid sym = do - sids <- query "select id from symbols where name == ? and module_id == ?;" ( - sym ^. symbolName, - mid) - when (length sids > 1) $ sendLog Warning $ "different symbols with same module id: {}.{}" ~~ show mid ~~ (sym ^. symbolName) - return $ listToMaybe [sid | Only sid <- sids] - -lastRow :: SessionMonad m => m Int -lastRow = do - [Only i] <- query_ "select last_insert_rowid();" - return i - -loadModule :: SessionMonad m => Int -> m Module -loadModule mid = scope "load-module" $ do - ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int)) - (toQuery $ mconcat [ - qModuleId, - select_ ["mu.docs", "mu.fixities", "mu.id"], - where_ [fromString "mu.id == ?"]]) - (Only mid) - case ms of - [] -> sqlFailure $ "module with id {} not found" ~~ mid - mods@((mid' :. (mdocs, mfixities, _)):_) -> do - when (length mods > 1) $ sendLog Warning $ "multiple modules with same id = {} found" ~~ mid - syms <- query @_ @Symbol - (toQuery $ mconcat [ - qSymbol, - from_ ["exports as e"], - where_ ["e.module_id == ?", "e.symbol_id == s.id"]]) - (Only mid) - imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid) - return Module { - _moduleId = mid', - _moduleDocs = mdocs, - _moduleImports = imps, - _moduleExports = syms, - _moduleFixities = fromMaybe [] (mfixities >>= fromJSON'), - _moduleScope = mempty, - _moduleSource = Nothing } - -loadModules :: (SessionMonad m, ToRow q) => String -> q -> m [Module] -loadModules selectExpr args = scope "load-modules" $ do - ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int)) - (toQuery $ mconcat [ - qModuleId, - select_ ["mu.docs", "mu.fixities", "mu.id"], - where_ [fromString $ "mu.id in (" ++ selectExpr ++ ")"]]) - args - forM ms $ \(mid' :. (mdocs, mfixities, mid)) -> do - syms <- query @_ @Symbol - (toQuery $ mconcat [ - qSymbol, - from_ ["exports as e"], - where_ ["e.module_id == ?", "e.symbol_id == s.id"]]) - (Only mid) - imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid) - return Module { - _moduleId = mid', - _moduleDocs = mdocs, - _moduleImports = imps, - _moduleExports = syms, - _moduleFixities = fromMaybe [] (mfixities >>= fromJSON'), - _moduleScope = mempty, - _moduleSource = Nothing } - -loadProject :: SessionMonad m => Path -> m Project -loadProject cabal = scope "load-project" $ do - projs <- query @_ @(Only Int :. Project) "select id, name, cabal, version, build_tool, package_db_stack from projects where cabal == ?;" (Only $ view path cabal) - (Only pid :. proj) <- case projs of - [] -> sqlFailure $ "project with cabal {} not found" ~~ view path cabal - _ -> do - when (length projs > 1) $ sendLog Warning $ "multiple projects with same cabal = {} found" ~~ view path cabal - return $ head projs - - libs <- query - (toQuery $ mconcat [ - select_ ["lib.modules"], - from_ ["libraries as lib"], - qBuildInfo, - where_ [ - "lib.build_info_id == bi.id", - "lib.project_id == ?"]]) - (Only pid) - - exes <- query - (toQuery $ mconcat [ - select_ ["exe.name", "exe.path"], - from_ ["executables as exe"], - qBuildInfo, - where_ [ - "exe.build_info_id == bi.id", - "exe.project_id == ?"]]) - (Only pid) - - tests <- query - (toQuery $ mconcat [ - select_ ["tst.name", "tst.enabled", "tst.main"], - from_ ["tests as tst"], - qBuildInfo, - where_ [ - "tst.build_info_id == bi.id", - "tst.project_id == ?"]]) - (Only pid) - - return $ - set (projectDescription . _Just . projectLibrary) (listToMaybe libs) . - set (projectDescription . _Just . projectExecutables) exes . - set (projectDescription . _Just . projectTests) tests $ - proj - --- | Update a bunch of modules -updateModules :: SessionMonad m => [InspectedModule] -> m () -updateModules ims = scope "update-modules" $ do - ids <- upsertModules ims - updateModulesSymbols $ zip ids ims - --- | Update symbols of bunch of modules -updateModulesSymbols :: SessionMonad m => [(Int, InspectedModule)] -> m () -updateModulesSymbols ims = scope "update-modules" $ timer "updated modules" $ bracket_ initTemps dropTemps $ do - initUpdatedIds ims - - removeModulesContents - transaction_ Immediate $ insertModulesDefs ims - transaction_ Immediate $ insertModulesExports ims - where - initTemps :: SessionMonad m => m () - initTemps = execute_ "create temporary table updated_ids (id integer not null, cabal text, module text not null, only_header int not null, dirty int not null);" - - dropTemps :: SessionMonad m => m () - dropTemps = execute_ "drop table if exists updated_ids;" - - initUpdatedIds :: SessionMonad m => [(Int, InspectedModule)] -> m () - initUpdatedIds imods = transaction_ Immediate $ do - execute_ "create unique index updated_ids_id_index on updated_ids (id);" - execute_ "create index updated_ids_module_index on updated_ids (module);" - executeMany "insert into updated_ids (id, cabal, module, only_header, dirty) values (?, ?, ?, ?, ?);" $ do - (mid, im) <- imods - return ( - mid, - im ^? inspectedKey . moduleProject . _Just . projectCabal, - im ^?! inspected . moduleId . moduleName, - hasTag OnlyHeaderTag im, - hasTag DirtyTag im) - - removeModulesContents :: SessionMonad m => m () - removeModulesContents = scope "remove-modules-contents" $ do - transaction_ Immediate $ do - execute_ "delete from symbols where module_id in (select id from updated_ids where not only_header or not dirty);" - execute_ "update symbols set line = null, column = null where module_id in (select id from updated_ids where only_header and dirty);" - execute_ "delete from imports where module_id in (select id from updated_ids);" - execute_ "delete from exports where module_id in (select id from updated_ids);" - - transaction_ Immediate $ execute_ "delete from scopes where module_id in (select id from updated_ids);" - transaction_ Immediate $ execute_ "delete from names where module_id in (select id from updated_ids);" - transaction_ Immediate $ execute_ "delete from types where module_id in (select id from updated_ids);" - - insertModulesDefs :: SessionMonad m => [(Int, InspectedModule)] -> m () - insertModulesDefs imods = executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do - (mid, im) <- imods - m <- im ^.. inspected - sym <- m ^. moduleExports - guard (sym ^. symbolId . symbolModule == m ^. moduleId) - return $ ( - sym ^. symbolId . symbolName, - mid, - sym ^. symbolDocs, - sym ^? symbolPosition . _Just . positionLine, - sym ^? symbolPosition . _Just . positionColumn) - :. (sym ^. symbolInfo) - - insertModulesExports :: SessionMonad m => [(Int, InspectedModule)] -> m () - insertModulesExports imods = executeMany "insert into exports (module_id, symbol_id) select ?, s.id from modules as m, symbols as s where ((? = m.file) or (? = m.package_name and ? = m.package_version and ? = m.installed_name) or (? = m.other_location)) and s.module_id = m.id and ? = s.name and ? = s.what;" $ do - (mid, im) <- imods - m <- im ^.. inspected - sym <- m ^. moduleExports - return $ - (Only mid) :. - mkLocationId (sym ^. symbolId . symbolModule) :. - (sym ^. symbolId . symbolName, symbolType sym) - - mkLocationId m' = ( - m' ^? moduleLocation . moduleFile, - m' ^? moduleLocation . modulePackage . packageName, - m' ^? moduleLocation . modulePackage . packageVersion, - m' ^? moduleLocation . installedModuleName, - m' ^? moduleLocation . otherLocationName) - - -escapeLike :: Text -> Text -escapeLike = T.replace "%" "\\%" . T.replace "_" "\\_" . T.replace "\\" "\\\\" - --- Util - -sqlFailure :: SessionMonad m => Text -> m a -sqlFailure msg = do - sendLog Error msg - hsdevError $ SQLiteError $ T.unpack msg - -lookupId :: SessionMonad m => ModuleLocation -> m Int -lookupId = lookupModuleLocation >=> maybe err return where - err = hsdevError $ SQLiteError "module not exist in db" +{-# LANGUAGE OverloadedStrings, TypeOperators, TypeApplications #-} + +module HsDev.Database.SQLite ( + initialize, purge, + privateMemory, sharedMemory, + query, query_, queryNamed, execute, execute_, executeMany, executeNamed, + withTemporaryTable, + updatePackageDb, removePackageDb, insertPackageDb, + updateProject, removeProject, insertProject, insertBuildInfo, + removeModuleContents, removeModule, + lookupModuleLocation, lookupModule, + lookupSymbol, + lastRow, + + loadModule, loadModules, + loadProject, + + updateModules, upsertModules, + + -- * Utils + lookupId, + escapeLike, + + -- * Reexports + module Database.SQLite.Simple, + module HsDev.Database.SQLite.Select, + module HsDev.Database.SQLite.Instances, + module HsDev.Database.SQLite.Transaction + ) where + +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Aeson hiding (Error) +import Data.List (intercalate) +import Data.Maybe +import Data.String +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Database.SQLite.Simple hiding (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction) +import qualified Database.SQLite.Simple as SQL (query, query_, queryNamed, execute, execute_, executeNamed, executeMany, withTransaction) +import Distribution.Text (display) +import Language.Haskell.Extension () +import System.Directory +import System.Log.Simple +import Text.Format + +import System.Directory.Paths + +import HsDev.Database.SQLite.Instances +import HsDev.Database.SQLite.Schema +import HsDev.Database.SQLite.Select +import HsDev.Database.SQLite.Transaction +import qualified HsDev.Display as Display +import HsDev.Error +import HsDev.PackageDb.Types +import HsDev.Project.Types +import HsDev.Symbols (hasTag) +import HsDev.Symbols.Types hiding (loadProject) +import HsDev.Server.Types +import HsDev.Util + +-- | Open new connection and set some pragmas +new :: String -> IO Connection +new p = do + conn <- open p + SQL.execute_ conn "pragma case_sensitive_like = true;" + SQL.execute_ conn "pragma synchronous = off;" + SQL.execute_ conn "pragma journal_mode = memory;" + return conn + +-- | Initialize database +initialize :: String -> IO Connection +initialize p = do + conn <- new p + [Only hasTables] <- SQL.query_ conn "select count(*) > 0 from sqlite_master where type == 'table';" + goodVersion <- if hasTables + then do + [Only equalVersion] <- SQL.query conn "select sum(json(value) == json(?)) > 0 from hsdev where option == 'version';" (Only $ toJSON version) + return equalVersion + else return True + let + start + | not goodVersion = do + close conn + removeFile p + conn' <- new p + initDb conn' + | not hasTables = initDb conn + | otherwise = return conn + initDb conn' = SQL.withTransaction conn' $ do + mapM_ (SQL.execute_ conn') commands + SQL.execute @(Text, Value) conn' "insert into hsdev values (?, ?);" ("version", toJSON version) + return conn' + start + +purge :: SessionMonad m => m () +purge = do + tables <- query_ @(Only String) "select name from sqlite_master where type == 'table';" + forM_ tables $ \(Only table) -> + execute_ $ fromString $ "delete from {};" ~~ table + +-- | Private memory for db +privateMemory :: String +privateMemory = ":memory:" + +-- | Shared db in memory +sharedMemory :: String +sharedMemory = "file::memory:?cache=shared" + +-- | Retries for simple queries +retried :: (MonadIO m, MonadCatch m) => m a -> m a +retried = retry def + +query :: (ToRow q, FromRow r, SessionMonad m) => Query -> q -> m [r] +query q' params = retried $ do + conn <- serverSqlDatabase + liftIO $ SQL.query conn q' params + +query_ :: (FromRow r, SessionMonad m) => Query -> m [r] +query_ q' = retried $ do + conn <- serverSqlDatabase + liftIO $ SQL.query_ conn q' + +queryNamed :: (FromRow r, SessionMonad m) => Query -> [NamedParam] -> m [r] +queryNamed q' ps' = retried $ do + conn <- serverSqlDatabase + liftIO $ SQL.queryNamed conn q' ps' + +execute :: (ToRow q, SessionMonad m) => Query -> q -> m () +execute q' params = retried $ do + conn <- serverSqlDatabase + liftIO $ SQL.execute conn q' params + +execute_ :: SessionMonad m => Query -> m () +execute_ q' = retried $ do + conn <- serverSqlDatabase + liftIO $ SQL.execute_ conn q' + +executeMany :: (ToRow q, SessionMonad m) => Query -> [q] -> m () +executeMany q' params = do + conn <- serverSqlDatabase + liftIO $ SQL.executeMany conn q' params + +executeNamed :: SessionMonad m => Query -> [NamedParam] -> m () +executeNamed q' ps' = do + conn <- serverSqlDatabase + liftIO $ SQL.executeNamed conn q' ps' + +withTemporaryTable :: SessionMonad m => String -> [String] -> m a -> m a +withTemporaryTable tableName columns = bracket_ createTable dropTable where + createTable = execute_ $ fromString $ "create temporary table {} ({});" ~~ tableName ~~ (intercalate ", " columns) + dropTable = execute_ $ fromString $ "drop table {};" ~~ tableName + +updatePackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m () +updatePackageDb pdb pkgs = scope "update-package-db" $ transaction_ Immediate $ do + sendLog Trace $ "update package-db: {}" ~~ Display.display pdb + removePackageDb pdb + insertPackageDb pdb pkgs + +removePackageDb :: SessionMonad m => PackageDb -> m () +removePackageDb pdb = scope "remove-package-db" $ + execute "delete from package_dbs where package_db == ?;" (Only pdb) + +insertPackageDb :: SessionMonad m => PackageDb -> [ModulePackage] -> m () +insertPackageDb pdb pkgs = scope "insert-package-db" $ forM_ pkgs $ \pkg -> + execute + "insert into package_dbs (package_db, package_name, package_version) values (?, ?, ?);" + (pdb, pkg ^. packageName, pkg ^. packageVersion) + +updateProject :: SessionMonad m => Project -> m () +updateProject proj = scope "update-project" $ transaction_ Immediate $ do + sendLog Trace $ "update project: {}" ~~ Display.display proj + removeProject proj + insertProject proj + +removeProject :: SessionMonad m => Project -> m () +removeProject proj = scope "remove-project" $ do + projId <- query @_ @(Only Int) "select id from projects where cabal == ?;" (Only $ proj ^. projectCabal) + case projId of + [] -> return () + pids -> do + when (length pids > 1) $ + sendLog Warning $ "multiple projects for cabal {} found" ~~ (proj ^. projectCabal) + forM_ pids $ \pid -> do + bids <- query @_ @(Only Int) "select build_info_id from targets where project_id == ?;" pid + execute "delete from projects where id == ?;" pid + execute "delete from libraries where project_id == ?;" pid + execute "delete from executables where project_id == ?;" pid + execute "delete from tests where project_id == ?;" pid + forM_ bids $ \bid -> execute "delete from build_infos where id == ?;" bid + +insertProject :: SessionMonad m => Project -> m () +insertProject proj = scope "insert-project" $ do + execute "insert into projects (name, cabal, version, build_tool, package_db_stack) values (?, ?, ?, ?, ?);" proj + projId <- lastRow + + forM_ (proj ^? projectDescription . _Just . projectLibrary . _Just) $ \lib -> do + buildInfoId <- insertBuildInfo $ lib ^. libraryBuildInfo + execute "insert into libraries (project_id, modules, build_info_id) values (?, ?, ?);" + (projId, encode $ lib ^. libraryModules, buildInfoId) + + forM_ (proj ^.. projectDescription . _Just . projectExecutables . each) $ \exe -> do + buildInfoId <- insertBuildInfo $ exe ^. executableBuildInfo + execute "insert into executables (project_id, name, path, build_info_id) values (?, ?, ?, ?);" + (projId, exe ^. executableName, exe ^. executablePath . path, buildInfoId) + + forM_ (proj ^.. projectDescription . _Just . projectTests . each) $ \test -> do + buildInfoId <- insertBuildInfo $ test ^. testBuildInfo + execute "insert into tests (project_id, name, enabled, main, build_info_id) values (?, ?, ?, ?, ?);" + (projId, test ^. testName, test ^. testEnabled, test ^? testMain . _Just . path, buildInfoId) + +insertBuildInfo :: SessionMonad m => Info -> m Int +insertBuildInfo info = scope "insert-build-info" $ do + execute "insert into build_infos (depends, language, extensions, ghc_options, source_dirs, other_modules) values (?, ?, ?, ?, ?, ?);" ( + encode $ info ^. infoDepends, + fmap display $ info ^. infoLanguage, + encode $ map display $ info ^. infoExtensions, + encode $ info ^. infoGHCOptions, + encode $ info ^.. infoSourceDirs . each . path, + encode $ info ^. infoOtherModules) + lastRow + +removeModuleContents :: SessionMonad m => Int -> m () +removeModuleContents mid = scope "remove-module-contents" $ do + execute "delete from imports where module_id = ?;" (Only mid) + execute "delete from exports where module_id = ?;" (Only mid) + execute "delete from scopes where module_id = ?;" (Only mid) + execute "delete from names where module_id = ?;" (Only mid) + execute "delete from types where module_id = ?;" (Only mid) + execute "delete from symbols where module_id = ?;" (Only mid) + +removeModule :: SessionMonad m => Int -> m () +removeModule mid = scope "remove-module" $ do + removeModuleContents mid + execute "delete from modules where id == ?;" (Only mid) + +upsertModules :: SessionMonad m => [InspectedModule] -> m [Int] +upsertModules ims = scope "upsert-modules" $ bracket_ initTemp removeTemp $ do + executeMany "insert into upserted_modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ map moduleData ims + execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location));" + execute_ "insert or replace into modules (id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is not null;" + execute_ "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is null;" + execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location)) where id is null;" + + liftM (map fromOnly) $ query_ "select id from upserted_modules order by rowid;" + where + initTemp :: SessionMonad m => m () + initTemp = do + execute_ "create temporary table upserted_modules as select * from modules where 0;" + execute_ "create index upserted_modules_id_index on upserted_modules (id);" + + removeTemp :: SessionMonad m => m () + removeTemp = execute_ "drop table if exists upserted_modules;" + + moduleData im = ( + im ^? inspectedKey . moduleFile . path, + im ^? inspectedKey . moduleProject . _Just . projectCabal, + fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs), + im ^? inspectedKey . modulePackage . packageName, + im ^? inspectedKey . modulePackage . packageVersion, + im ^? inspectedKey . installedModuleName, + im ^? inspectedKey . installedModuleExposed, + im ^? inspectedKey . otherLocationName) + :. ( + msum [im ^? inspected . moduleId . moduleName, im ^? inspectedKey . installedModuleName], + im ^? inspected . moduleDocs, + fmap encode $ im ^? inspected . moduleFixities, + encode $ asDict $ im ^. inspectionTags, + fmap show $ im ^? inspectionResult . _Left) + :. + fromMaybe InspectionNone (im ^? inspection) + asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags] + +lookupModuleLocation :: SessionMonad m => ModuleLocation -> m (Maybe Int) +lookupModuleLocation m = do + mids <- queryNamed "select id from modules where (file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location);" [ + ":file" := m ^? moduleFile . path, + ":package_name" := m ^? modulePackage . packageName, + ":package_version" := m ^? modulePackage . packageVersion, + ":installed_name" := m ^? installedModuleName, + ":other_location" := m ^? otherLocationName] + when (length mids > 1) $ sendLog Warning $ "different modules with location: {}" ~~ Display.display m + return $ listToMaybe [mid | Only mid <- mids] + +lookupModule :: SessionMonad m => ModuleId -> m (Maybe Int) +lookupModule m = do + mids <- queryNamed "select id from modules where ((name is null and :name is null) or name = :name) and ((file = :file) or (package_name = :package_name and package_version = :package_version and installed_name = :installed_name) or (other_location = :other_location));" [ + ":name" := m ^. moduleName, + ":file" := m ^? moduleLocation . moduleFile . path, + ":package_name" := m ^? moduleLocation . modulePackage . packageName, + ":package_version" := m ^? moduleLocation . modulePackage . packageVersion, + ":installed_name" := m ^? moduleLocation . installedModuleName, + ":other_location" := m ^? moduleLocation . otherLocationName] + when (length mids > 1) $ sendLog Warning $ "different modules with same name and location: {}" ~~ (m ^. moduleName) + return $ listToMaybe [mid | Only mid <- mids] + +lookupSymbol :: SessionMonad m => Int -> SymbolId -> m (Maybe Int) +lookupSymbol mid sym = do + sids <- query "select id from symbols where name == ? and module_id == ?;" ( + sym ^. symbolName, + mid) + when (length sids > 1) $ sendLog Warning $ "different symbols with same module id: {}.{}" ~~ show mid ~~ (sym ^. symbolName) + return $ listToMaybe [sid | Only sid <- sids] + +lastRow :: SessionMonad m => m Int +lastRow = do + [Only i] <- query_ "select last_insert_rowid();" + return i + +loadModule :: SessionMonad m => Int -> m Module +loadModule mid = scope "load-module" $ do + ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int)) + (toQuery $ mconcat [ + qModuleId, + select_ ["mu.docs", "mu.fixities", "mu.id"], + where_ [fromString "mu.id == ?"]]) + (Only mid) + case ms of + [] -> sqlFailure $ "module with id {} not found" ~~ mid + mods@((mid' :. (mdocs, mfixities, _)):_) -> do + when (length mods > 1) $ sendLog Warning $ "multiple modules with same id = {} found" ~~ mid + syms <- query @_ @Symbol + (toQuery $ mconcat [ + qSymbol, + from_ ["exports as e"], + where_ ["e.module_id == ?", "e.symbol_id == s.id"]]) + (Only mid) + imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid) + return Module { + _moduleId = mid', + _moduleDocs = mdocs, + _moduleImports = imps, + _moduleExports = syms, + _moduleFixities = fromMaybe [] (mfixities >>= fromJSON'), + _moduleScope = mempty, + _moduleSource = Nothing } + +loadModules :: (SessionMonad m, ToRow q) => String -> q -> m [Module] +loadModules selectExpr args = scope "load-modules" $ do + ms <- query @_ @(ModuleId :. (Maybe Text, Maybe Value, Int)) + (toQuery $ mconcat [ + qModuleId, + select_ ["mu.docs", "mu.fixities", "mu.id"], + where_ [fromString $ "mu.id in (" ++ selectExpr ++ ")"]]) + args + forM ms $ \(mid' :. (mdocs, mfixities, mid)) -> do + syms <- query @_ @Symbol + (toQuery $ mconcat [ + qSymbol, + from_ ["exports as e"], + where_ ["e.module_id == ?", "e.symbol_id == s.id"]]) + (Only mid) + imps <- query @_ @Import "select line, column, module_name, qualified, alias from imports where module_id == ?;" (Only mid) + return Module { + _moduleId = mid', + _moduleDocs = mdocs, + _moduleImports = imps, + _moduleExports = syms, + _moduleFixities = fromMaybe [] (mfixities >>= fromJSON'), + _moduleScope = mempty, + _moduleSource = Nothing } + +loadProject :: SessionMonad m => Path -> m Project +loadProject cabal = scope "load-project" $ do + projs <- query @_ @(Only Int :. Project) "select id, name, cabal, version, build_tool, package_db_stack from projects where cabal == ?;" (Only $ view path cabal) + (Only pid :. proj) <- case projs of + [] -> sqlFailure $ "project with cabal {} not found" ~~ view path cabal + _ -> do + when (length projs > 1) $ sendLog Warning $ "multiple projects with same cabal = {} found" ~~ view path cabal + return $ head projs + + libs <- query + (toQuery $ mconcat [ + select_ ["lib.modules"], + from_ ["libraries as lib"], + qBuildInfo, + where_ [ + "lib.build_info_id == bi.id", + "lib.project_id == ?"]]) + (Only pid) + + exes <- query + (toQuery $ mconcat [ + select_ ["exe.name", "exe.path"], + from_ ["executables as exe"], + qBuildInfo, + where_ [ + "exe.build_info_id == bi.id", + "exe.project_id == ?"]]) + (Only pid) + + tests <- query + (toQuery $ mconcat [ + select_ ["tst.name", "tst.enabled", "tst.main"], + from_ ["tests as tst"], + qBuildInfo, + where_ [ + "tst.build_info_id == bi.id", + "tst.project_id == ?"]]) + (Only pid) + + return $ + set (projectDescription . _Just . projectLibrary) (listToMaybe libs) . + set (projectDescription . _Just . projectExecutables) exes . + set (projectDescription . _Just . projectTests) tests $ + proj + +-- | Update a bunch of modules +updateModules :: SessionMonad m => [InspectedModule] -> m () +updateModules ims = scope "update-modules" $ do + ids <- upsertModules ims + updateModulesSymbols $ zip ids ims + +-- | Update symbols of bunch of modules +updateModulesSymbols :: SessionMonad m => [(Int, InspectedModule)] -> m () +updateModulesSymbols ims = scope "update-modules" $ timer "updated modules" $ bracket_ initTemps dropTemps $ do + initUpdatedIds ims + + removeModulesContents + transaction_ Immediate $ insertModulesDefs ims + transaction_ Immediate $ insertModulesExports ims + where + initTemps :: SessionMonad m => m () + initTemps = execute_ "create temporary table updated_ids (id integer not null, cabal text, module text not null, only_header int not null, dirty int not null);" + + dropTemps :: SessionMonad m => m () + dropTemps = execute_ "drop table if exists updated_ids;" + + initUpdatedIds :: SessionMonad m => [(Int, InspectedModule)] -> m () + initUpdatedIds imods = transaction_ Immediate $ do + execute_ "create unique index updated_ids_id_index on updated_ids (id);" + execute_ "create index updated_ids_module_index on updated_ids (module);" + executeMany "insert into updated_ids (id, cabal, module, only_header, dirty) values (?, ?, ?, ?, ?);" $ do + (mid, im) <- imods + return ( + mid, + im ^? inspectedKey . moduleProject . _Just . projectCabal, + im ^?! inspected . moduleId . moduleName, + hasTag OnlyHeaderTag im, + hasTag DirtyTag im) + + removeModulesContents :: SessionMonad m => m () + removeModulesContents = scope "remove-modules-contents" $ do + transaction_ Immediate $ do + execute_ "delete from symbols where module_id in (select id from updated_ids where not only_header or not dirty);" + execute_ "update symbols set line = null, column = null where module_id in (select id from updated_ids where only_header and dirty);" + execute_ "delete from imports where module_id in (select id from updated_ids);" + execute_ "delete from exports where module_id in (select id from updated_ids);" + + transaction_ Immediate $ execute_ "delete from scopes where module_id in (select id from updated_ids);" + transaction_ Immediate $ execute_ "delete from names where module_id in (select id from updated_ids);" + transaction_ Immediate $ execute_ "delete from types where module_id in (select id from updated_ids);" + + insertModulesDefs :: SessionMonad m => [(Int, InspectedModule)] -> m () + insertModulesDefs imods = executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do + (mid, im) <- imods + m <- im ^.. inspected + sym <- m ^. moduleExports + guard (sym ^. symbolId . symbolModule == m ^. moduleId) + return $ ( + sym ^. symbolId . symbolName, + mid, + sym ^. symbolDocs, + sym ^? symbolPosition . _Just . positionLine, + sym ^? symbolPosition . _Just . positionColumn) + :. (sym ^. symbolInfo) + + insertModulesExports :: SessionMonad m => [(Int, InspectedModule)] -> m () + insertModulesExports imods = executeMany "insert into exports (module_id, symbol_id) select ?, s.id from modules as m, symbols as s where ((? = m.file) or (? = m.package_name and ? = m.package_version and ? = m.installed_name) or (? = m.other_location)) and s.module_id = m.id and ? = s.name and ? = s.what;" $ do + (mid, im) <- imods + m <- im ^.. inspected + sym <- m ^. moduleExports + return $ + (Only mid) :. + mkLocationId (sym ^. symbolId . symbolModule) :. + (sym ^. symbolId . symbolName, symbolType sym) + + mkLocationId m' = ( + m' ^? moduleLocation . moduleFile, + m' ^? moduleLocation . modulePackage . packageName, + m' ^? moduleLocation . modulePackage . packageVersion, + m' ^? moduleLocation . installedModuleName, + m' ^? moduleLocation . otherLocationName) + + +escapeLike :: Text -> Text +escapeLike = T.replace "%" "\\%" . T.replace "_" "\\_" . T.replace "\\" "\\\\" + +-- Util + +sqlFailure :: SessionMonad m => Text -> m a +sqlFailure msg = do + sendLog Error msg + hsdevError $ SQLiteError $ T.unpack msg + +lookupId :: SessionMonad m => ModuleLocation -> m Int +lookupId = lookupModuleLocation >=> maybe err return where + err = hsdevError $ SQLiteError "module not exist in db" diff --git a/src/HsDev/Database/SQLite/Instances.hs b/src/HsDev/Database/SQLite/Instances.hs --- a/src/HsDev/Database/SQLite/Instances.hs +++ b/src/HsDev/Database/SQLite/Instances.hs @@ -1,371 +1,371 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Database.SQLite.Instances ( - JSON(..) - ) where - -import Control.Lens ((^.), (^?), _Just) -import Data.Aeson as A hiding (Error) -import Data.Maybe -import Data.Foldable -import Data.Time.Clock.POSIX -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Lazy as L -import Database.SQLite.Simple -import Database.SQLite.Simple.ToField -import Database.SQLite.Simple.FromField -import Language.Haskell.Extension -import qualified Language.Haskell.Names as N -import qualified Language.Haskell.Exts as H -import Text.Format - -import System.Directory.Paths -import HsDev.Display -import HsDev.Symbols.Name -import HsDev.Symbols.Location -import HsDev.Symbols.Types -import HsDev.Tools.Ghc.Types -import HsDev.Tools.Types -import HsDev.Util - -instance ToField Value where - toField = SQLBlob . L.toStrict . encode - -instance FromField Value where - fromField fld = case fieldData fld of - SQLText s -> either fail return . eitherDecode . L.fromStrict . T.encodeUtf8 $ s - SQLBlob s -> either fail return . eitherDecode . L.fromStrict $ s - _ -> fail "invalid json field type" - -newtype JSON a = JSON { getJSON :: a } - deriving (Eq, Ord, Read, Show) - -instance ToJSON a => ToField (JSON a) where - toField = SQLBlob . L.toStrict . encode . getJSON - -instance FromJSON a => FromField (JSON a) where - fromField fld = case fieldData fld of - SQLText s -> either fail (return . JSON) . eitherDecode . L.fromStrict . T.encodeUtf8 $ s - SQLBlob s -> either fail (return . JSON) . eitherDecode . L.fromStrict $ s - _ -> fail "invalid json field type" - -instance FromRow Position where - fromRow = Position <$> field <*> field - -instance ToRow Position where - toRow (Position l c) = [toField l, toField c] - -instance FromRow Region where - fromRow = Region <$> fromRow <*> fromRow - -instance ToRow Region where - toRow (Region f t) = toRow f ++ toRow t - -instance FromRow ModulePackage where - fromRow = ModulePackage <$> field <*> (fromMaybe T.empty <$> field) - -instance ToRow ModulePackage where - toRow (ModulePackage name ver) = [toField name, toField ver] - -instance FromRow ModuleLocation where - fromRow = do - file <- field - cabal <- field - dirs <- field - pname <- field - pver <- field - iname <- field - iexposed <- field - other <- field - - maybe (fail $ "Can't parse module location: {}" ~~ show (file, cabal, dirs, pname, pver, iname, iexposed, other)) return $ msum [ - FileModule <$> file <*> pure (project <$> cabal), - InstalledModule <$> maybe (pure []) fromJSON' dirs <*> (ModulePackage <$> pname <*> pver) <*> iname <*> iexposed, - OtherLocation <$> other, - pure NoLocation] - -instance ToRow ModuleLocation where - toRow mloc = [ - toField $ mloc ^? moduleFile, - toField $ mloc ^? moduleProject . _Just . projectCabal, - toField $ fmap toJSON $ mloc ^? moduleInstallDirs, - toField $ mloc ^? modulePackage . packageName, - toField $ mloc ^? modulePackage . packageVersion, - toField $ mloc ^? installedModuleName, - toField $ mloc ^? installedModuleExposed, - toField $ mloc ^? otherLocationName] - -instance FromRow ModuleId where - fromRow = ModuleId <$> field <*> fromRow - -instance ToRow ModuleId where - toRow mid = toField (mid ^. moduleName) : toRow (mid ^. moduleLocation) - -instance FromRow Import where - fromRow = Import <$> fromRow <*> field <*> field <*> field - -instance ToRow Import where - toRow (Import p n q a) = toRow p ++ [toField n, toField q, toField a] - -instance FromRow SymbolId where - fromRow = SymbolId <$> field <*> fromRow - -instance ToRow SymbolId where - toRow (SymbolId nm mid) = toField nm : toRow mid - -instance FromRow SymbolInfo where - fromRow = do - what <- field @String - ty <- field - parent <- field - ctors <- field - args <- field - ctx <- field - assoc <- field - patTy <- field - patCtor <- field - maybe (fail $ "Can't parse symbol info: {}" ~~ show (what, ty, parent, ctors, args, ctx, assoc, patTy, patCtor)) return $ case what of - "function" -> return $ Function ty - "method" -> Method <$> pure ty <*> parent - "selector" -> Selector <$> pure ty <*> parent <*> (fromJSON' =<< ctors) - "ctor" -> Constructor <$> (fromJSON' =<< args) <*> parent - "type" -> Type <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) - "newtype" -> NewType <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) - "data" -> Data <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) - "class" -> Class <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) - "type-family" -> TypeFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc - "data-family" -> DataFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc - "pat-ctor" -> PatConstructor <$> (fromJSON' =<< args) <*> pure patTy - "pat-selector" -> PatSelector <$> pure ty <*> pure patTy <*> patCtor - _ -> Nothing - -instance ToRow SymbolInfo where - toRow si = [ - toField $ symbolInfoType si, - toField $ si ^? functionType . _Just, - toField $ msum [si ^? parentClass, si ^? parentType], - toField $ toJSON $ si ^? selectorConstructors, - toField $ toJSON $ si ^? typeArgs, - toField $ toJSON $ si ^? typeContext, - toField $ si ^? familyAssociate . _Just, - toField $ si ^? patternType . _Just, - toField $ si ^? patternConstructor] - -instance FromRow Symbol where - fromRow = Symbol <$> fromRow <*> field <*> pos <*> fromRow where - pos = do - line <- field - column <- field - return $ Position <$> line <*> column - -instance ToRow Symbol where - toRow sym = concat [ - toRow (sym ^. symbolId), - [toField $ sym ^. symbolDocs], - maybe [SQLNull, SQLNull] toRow (sym ^. symbolPosition), - toRow (sym ^. symbolInfo)] - -instance FromRow a => FromRow (Scoped a) where - fromRow = flip Scoped <$> fromRow <*> field - -instance ToRow a => ToRow (Scoped a) where - toRow (Scoped q s) = toRow s ++ [toField q] - -instance ToField BuildTool where - toField CabalTool = toField @String "cabal" - toField StackTool = toField @String "stack" - -instance FromField BuildTool where - fromField = fromField @String >=> fromStr where - fromStr "cabal" = return CabalTool - fromStr "stack" = return StackTool - fromStr s = fail $ "Error parsing build tool: {}" ~~ s - -instance ToRow Sandbox where - toRow (Sandbox t p) = [toField t, toField p] - -instance FromRow Sandbox where - fromRow = Sandbox <$> field <*> field - -instance ToRow Project where - toRow (Project name _ cabal pdesc t dbs) = [toField name, toField cabal, toField $ pdesc ^? _Just . projectVersion, toField t, toField dbs] - -instance FromRow Project where - fromRow = do - name <- field - cabal <- field - ver <- field - tool <- field - dbs <- field - return $ Project name (takeDir cabal) cabal (fmap (\v -> ProjectDescription v Nothing [] []) ver) tool dbs - -instance FromRow Library where - fromRow = do - mods <- field >>= maybe (fail "Error parsing library modules") return . fromJSON' - binfo <- fromRow - return $ Library mods binfo - -instance FromRow Executable where - fromRow = Executable <$> field <*> field <*> fromRow - -instance FromRow Test where - fromRow = Test <$> field <*> field <*> field <*> fromRow - -instance FromRow Info where - fromRow = Info <$> - (field >>= maybe (fail "Error parsing depends") return . fromJSON') <*> - field <*> - (field >>= maybe (fail "Error parsing extensions") return . fromJSON') <*> - (field >>= maybe (fail "Error parsing ghc-options") return . fromJSON') <*> - (field >>= maybe (fail "Error parsing source-dirs") return . fromJSON') <*> - (field >>= maybe (fail "Error parsing other-modules") return . fromJSON') - -instance FromField Language where - fromField fld = case fieldData fld of - SQLText txt -> parseDT "Language" (T.unpack txt) - _ -> fail "Can't parse language, invalid type" - -instance ToField PackageDb where - toField GlobalDb = toField ("global-db" :: String) - toField UserDb = toField ("user-db" :: String) - toField (PackageDb p) = toField ("package-db:" ++ T.unpack p) - -instance FromField PackageDb where - fromField fld = do - s <- fromField fld - case s of - "global-db" -> return GlobalDb - "user-db" -> return UserDb - _ -> case T.stripPrefix "package-db:" s of - Just p' -> return $ PackageDb p' - Nothing -> fail $ "Can't parse package-db, invalid string: " ++ T.unpack s - -instance ToField PackageDbStack where - toField = toField . toJSON . packageDbs - -instance FromField PackageDbStack where - fromField = fromField >=> maybe (fail "Error parsing package-db-stack") (return . mkPackageDbStack) . fromJSON' - -instance FromRow SymbolUsage where - fromRow = SymbolUsage <$> fromRow <*> field <*> fromRow <*> fromRow - -instance FromField POSIXTime where - fromField = fmap (fromRational . toRational @Double) . fromField - -instance ToField POSIXTime where - toField = toField . fromRational @Double . toRational - -instance FromRow Inspection where - fromRow = do - tm <- field - opts <- field - case (tm, opts) of - (Nothing, Nothing) -> return InspectionNone - (_, Just opts') -> InspectionAt (fromMaybe 0 tm) <$> - maybe (fail "Error parsing inspection opts") return (fromJSON' opts') - (Just _, Nothing) -> fail "Error parsing inspection data, time is set, but flags are null" - -instance ToRow Inspection where - toRow InspectionNone = [SQLNull, SQLNull] - toRow (InspectionAt tm opts) = [ - if tm == 0 then SQLNull else toField tm, - toField $ toJSON opts] - -instance FromRow TypedExpr where - fromRow = TypedExpr <$> field <*> field - -instance ToRow TypedExpr where - toRow (TypedExpr e t) = [toField e, toField t] - -instance FromField (H.Name ()) where - fromField = fmap toName_ . fromField - -instance ToField (H.Name ()) where - toField = toField . fromName_ - -instance FromField (H.ModuleName ()) where - fromField = fmap toModuleName_ . fromField - -instance ToField (H.ModuleName ()) where - toField = toField . fromModuleName_ - -instance FromRow N.Symbol where - fromRow = do - what <- field @T.Text - mname <- field - name <- field - parent <- field - ctors <- do - ctorsJson <- field - return $ fmap (map toName_) (ctorsJson >>= fromJSON') - assoc <- field - patType <- field - patCtor <- field - let - m = toModuleName_ mname - n = toName_ name - maybe (fail $ "Can't parse symbol: {}" ~~ show (what, mname, name, parent, ctors, assoc, patType, patCtor)) return $ case what of - "function" -> return $ N.Value m n - "method" -> N.Method m n <$> parent - "selector" -> N.Selector m n <$> parent <*> ctors - "ctor" -> N.Constructor m n <$> parent - "type" -> return $ N.Type m n - "newtype" -> return $ N.NewType m n - "data" -> return $ N.Data m n - "class" -> return $ N.Class m n - "type-family" -> return $ N.TypeFam m n assoc - "data-family" -> return $ N.DataFam m n assoc - "pat-ctor" -> return $ N.PatternConstructor m n patType - "pat-selector" -> N.PatternSelector m n patType <$> patCtor - _ -> Nothing - -instance ToRow N.Symbol where - toRow = padNulls 8 . toRow' where - toRow' (N.Value m n) = mk "function" [toField m, toField n] - toRow' (N.Method m n p) = mk "method" [toField m, toField n, toField p] - toRow' (N.Selector m n p cs) = mk "selector" [toField m, toField n, toField p, toField $ toJSON (map fromName_ cs)] - toRow' (N.Constructor m n p) = mk "ctor" [toField m, toField n, toField p] - toRow' (N.Type m n) = mk "type" [toField m, toField n] - toRow' (N.NewType m n) = mk "newtype" [toField m, toField n] - toRow' (N.Data m n) = mk "data" [toField m, toField n] - toRow' (N.Class m n) = mk "class" [toField m, toField n] - toRow' (N.TypeFam m n assoc) = mk "type-family" [toField m, toField n, SQLNull, SQLNull, toField assoc] - toRow' (N.DataFam m n assoc) = mk "data-family" [toField m, toField n, SQLNull, SQLNull, toField assoc] - toRow' (N.PatternConstructor m n pty) = mk "pat-ctor" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty] - toRow' (N.PatternSelector m n pty pctor) = mk "pat-selector" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty, toField pctor] - - mk :: T.Text -> [SQLData] -> [SQLData] - mk what = (toField what :) - padNulls n fs = fs ++ replicate (n - length fs) SQLNull - -instance FromField Severity where - fromField fld = do - s <- fromField @String fld - msum [ - guard (s == "error") >> return Error, - guard (s == "warning") >> return Warning, - guard (s == "hint") >> return Hint, - fail ("Unknown severity: {}" ~~ s)] - -instance ToField Severity where - toField Error = toField @String "error" - toField Warning = toField @String "warning" - toField Hint = toField @String "hint" - -instance FromRow OutputMessage where - fromRow = OutputMessage <$> field <*> field - -instance ToRow OutputMessage where - toRow (OutputMessage msg suggest) = [toField msg, toField suggest] - -instance FromRow a => FromRow (Note a) where - fromRow = Note <$> (FileModule <$> field <*> pure Nothing) <*> fromRow <*> field <*> fromRow - -instance ToRow a => ToRow (Note a) where - toRow (Note mloc rgn sev n) = concat [ - [toField $ mloc ^? moduleFile], - toRow rgn, - [toField sev], - toRow n] +{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Database.SQLite.Instances ( + JSON(..) + ) where + +import Control.Lens ((^.), (^?), _Just) +import Data.Aeson as A hiding (Error) +import Data.Maybe +import Data.Foldable +import Data.Time.Clock.POSIX +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Lazy as L +import Database.SQLite.Simple +import Database.SQLite.Simple.ToField +import Database.SQLite.Simple.FromField +import Language.Haskell.Extension +import qualified Language.Haskell.Names as N +import qualified Language.Haskell.Exts as H +import Text.Format + +import System.Directory.Paths +import HsDev.Display +import HsDev.Symbols.Name +import HsDev.Symbols.Location +import HsDev.Symbols.Types +import HsDev.Tools.Ghc.Types +import HsDev.Tools.Types +import HsDev.Util + +instance ToField Value where + toField = SQLBlob . L.toStrict . encode + +instance FromField Value where + fromField fld = case fieldData fld of + SQLText s -> either fail return . eitherDecode . L.fromStrict . T.encodeUtf8 $ s + SQLBlob s -> either fail return . eitherDecode . L.fromStrict $ s + _ -> fail "invalid json field type" + +newtype JSON a = JSON { getJSON :: a } + deriving (Eq, Ord, Read, Show) + +instance ToJSON a => ToField (JSON a) where + toField = SQLBlob . L.toStrict . encode . getJSON + +instance FromJSON a => FromField (JSON a) where + fromField fld = case fieldData fld of + SQLText s -> either fail (return . JSON) . eitherDecode . L.fromStrict . T.encodeUtf8 $ s + SQLBlob s -> either fail (return . JSON) . eitherDecode . L.fromStrict $ s + _ -> fail "invalid json field type" + +instance FromRow Position where + fromRow = Position <$> field <*> field + +instance ToRow Position where + toRow (Position l c) = [toField l, toField c] + +instance FromRow Region where + fromRow = Region <$> fromRow <*> fromRow + +instance ToRow Region where + toRow (Region f t) = toRow f ++ toRow t + +instance FromRow ModulePackage where + fromRow = ModulePackage <$> field <*> (fromMaybe T.empty <$> field) + +instance ToRow ModulePackage where + toRow (ModulePackage name ver) = [toField name, toField ver] + +instance FromRow ModuleLocation where + fromRow = do + file <- field + cabal <- field + dirs <- field + pname <- field + pver <- field + iname <- field + iexposed <- field + other <- field + + maybe (fail $ "Can't parse module location: {}" ~~ show (file, cabal, dirs, pname, pver, iname, iexposed, other)) return $ msum [ + FileModule <$> file <*> pure (project <$> cabal), + InstalledModule <$> maybe (pure []) fromJSON' dirs <*> (ModulePackage <$> pname <*> pver) <*> iname <*> iexposed, + OtherLocation <$> other, + pure NoLocation] + +instance ToRow ModuleLocation where + toRow mloc = [ + toField $ mloc ^? moduleFile, + toField $ mloc ^? moduleProject . _Just . projectCabal, + toField $ fmap toJSON $ mloc ^? moduleInstallDirs, + toField $ mloc ^? modulePackage . packageName, + toField $ mloc ^? modulePackage . packageVersion, + toField $ mloc ^? installedModuleName, + toField $ mloc ^? installedModuleExposed, + toField $ mloc ^? otherLocationName] + +instance FromRow ModuleId where + fromRow = ModuleId <$> field <*> fromRow + +instance ToRow ModuleId where + toRow mid = toField (mid ^. moduleName) : toRow (mid ^. moduleLocation) + +instance FromRow Import where + fromRow = Import <$> fromRow <*> field <*> field <*> field + +instance ToRow Import where + toRow (Import p n q a) = toRow p ++ [toField n, toField q, toField a] + +instance FromRow SymbolId where + fromRow = SymbolId <$> field <*> fromRow + +instance ToRow SymbolId where + toRow (SymbolId nm mid) = toField nm : toRow mid + +instance FromRow SymbolInfo where + fromRow = do + what <- field @String + ty <- field + parent <- field + ctors <- field + args <- field + ctx <- field + assoc <- field + patTy <- field + patCtor <- field + maybe (fail $ "Can't parse symbol info: {}" ~~ show (what, ty, parent, ctors, args, ctx, assoc, patTy, patCtor)) return $ case what of + "function" -> return $ Function ty + "method" -> Method <$> pure ty <*> parent + "selector" -> Selector <$> pure ty <*> parent <*> (fromJSON' =<< ctors) + "ctor" -> Constructor <$> (fromJSON' =<< args) <*> parent + "type" -> Type <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) + "newtype" -> NewType <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) + "data" -> Data <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) + "class" -> Class <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) + "type-family" -> TypeFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc + "data-family" -> DataFam <$> (fromJSON' =<< args) <*> (fromJSON' =<< ctx) <*> pure assoc + "pat-ctor" -> PatConstructor <$> (fromJSON' =<< args) <*> pure patTy + "pat-selector" -> PatSelector <$> pure ty <*> pure patTy <*> patCtor + _ -> Nothing + +instance ToRow SymbolInfo where + toRow si = [ + toField $ symbolInfoType si, + toField $ si ^? functionType . _Just, + toField $ msum [si ^? parentClass, si ^? parentType], + toField $ toJSON $ si ^? selectorConstructors, + toField $ toJSON $ si ^? typeArgs, + toField $ toJSON $ si ^? typeContext, + toField $ si ^? familyAssociate . _Just, + toField $ si ^? patternType . _Just, + toField $ si ^? patternConstructor] + +instance FromRow Symbol where + fromRow = Symbol <$> fromRow <*> field <*> pos <*> fromRow where + pos = do + line <- field + column <- field + return $ Position <$> line <*> column + +instance ToRow Symbol where + toRow sym = concat [ + toRow (sym ^. symbolId), + [toField $ sym ^. symbolDocs], + maybe [SQLNull, SQLNull] toRow (sym ^. symbolPosition), + toRow (sym ^. symbolInfo)] + +instance FromRow a => FromRow (Scoped a) where + fromRow = flip Scoped <$> fromRow <*> field + +instance ToRow a => ToRow (Scoped a) where + toRow (Scoped q s) = toRow s ++ [toField q] + +instance ToField BuildTool where + toField CabalTool = toField @String "cabal" + toField StackTool = toField @String "stack" + +instance FromField BuildTool where + fromField = fromField @String >=> fromStr where + fromStr "cabal" = return CabalTool + fromStr "stack" = return StackTool + fromStr s = fail $ "Error parsing build tool: {}" ~~ s + +instance ToRow Sandbox where + toRow (Sandbox t p) = [toField t, toField p] + +instance FromRow Sandbox where + fromRow = Sandbox <$> field <*> field + +instance ToRow Project where + toRow (Project name _ cabal pdesc t dbs) = [toField name, toField cabal, toField $ pdesc ^? _Just . projectVersion, toField t, toField dbs] + +instance FromRow Project where + fromRow = do + name <- field + cabal <- field + ver <- field + tool <- field + dbs <- field + return $ Project name (takeDir cabal) cabal (fmap (\v -> ProjectDescription v Nothing [] []) ver) tool dbs + +instance FromRow Library where + fromRow = do + mods <- field >>= maybe (fail "Error parsing library modules") return . fromJSON' + binfo <- fromRow + return $ Library mods binfo + +instance FromRow Executable where + fromRow = Executable <$> field <*> field <*> fromRow + +instance FromRow Test where + fromRow = Test <$> field <*> field <*> field <*> fromRow + +instance FromRow Info where + fromRow = Info <$> + (field >>= maybe (fail "Error parsing depends") return . fromJSON') <*> + field <*> + (field >>= maybe (fail "Error parsing extensions") return . fromJSON') <*> + (field >>= maybe (fail "Error parsing ghc-options") return . fromJSON') <*> + (field >>= maybe (fail "Error parsing source-dirs") return . fromJSON') <*> + (field >>= maybe (fail "Error parsing other-modules") return . fromJSON') + +instance FromField Language where + fromField fld = case fieldData fld of + SQLText txt -> parseDT "Language" (T.unpack txt) + _ -> fail "Can't parse language, invalid type" + +instance ToField PackageDb where + toField GlobalDb = toField ("global-db" :: String) + toField UserDb = toField ("user-db" :: String) + toField (PackageDb p) = toField ("package-db:" ++ T.unpack p) + +instance FromField PackageDb where + fromField fld = do + s <- fromField fld + case s of + "global-db" -> return GlobalDb + "user-db" -> return UserDb + _ -> case T.stripPrefix "package-db:" s of + Just p' -> return $ PackageDb p' + Nothing -> fail $ "Can't parse package-db, invalid string: " ++ T.unpack s + +instance ToField PackageDbStack where + toField = toField . toJSON . packageDbs + +instance FromField PackageDbStack where + fromField = fromField >=> maybe (fail "Error parsing package-db-stack") (return . mkPackageDbStack) . fromJSON' + +instance FromRow SymbolUsage where + fromRow = SymbolUsage <$> fromRow <*> field <*> fromRow <*> fromRow + +instance FromField POSIXTime where + fromField = fmap (fromRational . toRational @Double) . fromField + +instance ToField POSIXTime where + toField = toField . fromRational @Double . toRational + +instance FromRow Inspection where + fromRow = do + tm <- field + opts <- field + case (tm, opts) of + (Nothing, Nothing) -> return InspectionNone + (_, Just opts') -> InspectionAt (fromMaybe 0 tm) <$> + maybe (fail "Error parsing inspection opts") return (fromJSON' opts') + (Just _, Nothing) -> fail "Error parsing inspection data, time is set, but flags are null" + +instance ToRow Inspection where + toRow InspectionNone = [SQLNull, SQLNull] + toRow (InspectionAt tm opts) = [ + if tm == 0 then SQLNull else toField tm, + toField $ toJSON opts] + +instance FromRow TypedExpr where + fromRow = TypedExpr <$> field <*> field + +instance ToRow TypedExpr where + toRow (TypedExpr e t) = [toField e, toField t] + +instance FromField (H.Name ()) where + fromField = fmap toName_ . fromField + +instance ToField (H.Name ()) where + toField = toField . fromName_ + +instance FromField (H.ModuleName ()) where + fromField = fmap toModuleName_ . fromField + +instance ToField (H.ModuleName ()) where + toField = toField . fromModuleName_ + +instance FromRow N.Symbol where + fromRow = do + what <- field @T.Text + mname <- field + name <- field + parent <- field + ctors <- do + ctorsJson <- field + return $ fmap (map toName_) (ctorsJson >>= fromJSON') + assoc <- field + patType <- field + patCtor <- field + let + m = toModuleName_ mname + n = toName_ name + maybe (fail $ "Can't parse symbol: {}" ~~ show (what, mname, name, parent, ctors, assoc, patType, patCtor)) return $ case what of + "function" -> return $ N.Value m n + "method" -> N.Method m n <$> parent + "selector" -> N.Selector m n <$> parent <*> ctors + "ctor" -> N.Constructor m n <$> parent + "type" -> return $ N.Type m n + "newtype" -> return $ N.NewType m n + "data" -> return $ N.Data m n + "class" -> return $ N.Class m n + "type-family" -> return $ N.TypeFam m n assoc + "data-family" -> return $ N.DataFam m n assoc + "pat-ctor" -> return $ N.PatternConstructor m n patType + "pat-selector" -> N.PatternSelector m n patType <$> patCtor + _ -> Nothing + +instance ToRow N.Symbol where + toRow = padNulls 8 . toRow' where + toRow' (N.Value m n) = mk "function" [toField m, toField n] + toRow' (N.Method m n p) = mk "method" [toField m, toField n, toField p] + toRow' (N.Selector m n p cs) = mk "selector" [toField m, toField n, toField p, toField $ toJSON (map fromName_ cs)] + toRow' (N.Constructor m n p) = mk "ctor" [toField m, toField n, toField p] + toRow' (N.Type m n) = mk "type" [toField m, toField n] + toRow' (N.NewType m n) = mk "newtype" [toField m, toField n] + toRow' (N.Data m n) = mk "data" [toField m, toField n] + toRow' (N.Class m n) = mk "class" [toField m, toField n] + toRow' (N.TypeFam m n assoc) = mk "type-family" [toField m, toField n, SQLNull, SQLNull, toField assoc] + toRow' (N.DataFam m n assoc) = mk "data-family" [toField m, toField n, SQLNull, SQLNull, toField assoc] + toRow' (N.PatternConstructor m n pty) = mk "pat-ctor" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty] + toRow' (N.PatternSelector m n pty pctor) = mk "pat-selector" [toField m, toField n, SQLNull, SQLNull, SQLNull, toField pty, toField pctor] + + mk :: T.Text -> [SQLData] -> [SQLData] + mk what = (toField what :) + padNulls n fs = fs ++ replicate (n - length fs) SQLNull + +instance FromField Severity where + fromField fld = do + s <- fromField @String fld + msum [ + guard (s == "error") >> return Error, + guard (s == "warning") >> return Warning, + guard (s == "hint") >> return Hint, + fail ("Unknown severity: {}" ~~ s)] + +instance ToField Severity where + toField Error = toField @String "error" + toField Warning = toField @String "warning" + toField Hint = toField @String "hint" + +instance FromRow OutputMessage where + fromRow = OutputMessage <$> field <*> field + +instance ToRow OutputMessage where + toRow (OutputMessage msg suggest) = [toField msg, toField suggest] + +instance FromRow a => FromRow (Note a) where + fromRow = Note <$> (FileModule <$> field <*> pure Nothing) <*> fromRow <*> field <*> fromRow + +instance ToRow a => ToRow (Note a) where + toRow (Note mloc rgn sev n) = concat [ + [toField $ mloc ^? moduleFile], + toRow rgn, + [toField sev], + toRow n] diff --git a/src/HsDev/Database/SQLite/Schema.hs b/src/HsDev/Database/SQLite/Schema.hs --- a/src/HsDev/Database/SQLite/Schema.hs +++ b/src/HsDev/Database/SQLite/Schema.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} - -module HsDev.Database.SQLite.Schema ( - schema, commands - ) where - -import qualified Data.Text as T -import Data.List (unfoldr) -import Database.SQLite.Simple (Query(..)) - -import HsDev.Database.SQLite.Schema.TH - -schema :: T.Text -schema = T.pack $schemaExp - -commands :: [Query] -commands = map (Query . T.unlines) . unfoldr takeStmt . T.lines $ schema where - takeStmt :: [T.Text] -> Maybe ([T.Text], [T.Text]) - takeStmt ls = case break endsStmt ls of - (_, []) -> Nothing - (hs, t:ts) -> Just (hs ++ [t], ts) - comment :: T.Text -> Bool - comment t = "-- " `T.isPrefixOf` T.strip t - endsStmt :: T.Text -> Bool - endsStmt t = not (comment t) && ";" `T.isSuffixOf` T.strip t +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} + +module HsDev.Database.SQLite.Schema ( + schema, commands + ) where + +import qualified Data.Text as T +import Data.List (unfoldr) +import Database.SQLite.Simple (Query(..)) + +import HsDev.Database.SQLite.Schema.TH + +schema :: T.Text +schema = T.pack $schemaExp + +commands :: [Query] +commands = map (Query . T.unlines) . unfoldr takeStmt . T.lines $ schema where + takeStmt :: [T.Text] -> Maybe ([T.Text], [T.Text]) + takeStmt ls = case break endsStmt ls of + (_, []) -> Nothing + (hs, t:ts) -> Just (hs ++ [t], ts) + comment :: T.Text -> Bool + comment t = "-- " `T.isPrefixOf` T.strip t + endsStmt :: T.Text -> Bool + endsStmt t = not (comment t) && ";" `T.isSuffixOf` T.strip t diff --git a/src/HsDev/Database/SQLite/Schema/TH.hs b/src/HsDev/Database/SQLite/Schema/TH.hs --- a/src/HsDev/Database/SQLite/Schema/TH.hs +++ b/src/HsDev/Database/SQLite/Schema/TH.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE TemplateHaskell #-} - -module HsDev.Database.SQLite.Schema.TH ( - schemaExp - ) where - -import System.Directory -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -schemaExp :: ExpQ -schemaExp = do - schemaFile <- runIO $ canonicalizePath "data/hsdev.sql" - addDependentFile schemaFile - s <- runIO (readFile "data/hsdev.sql") - [e| s |] +{-# LANGUAGE TemplateHaskell #-} + +module HsDev.Database.SQLite.Schema.TH ( + schemaExp + ) where + +import System.Directory +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +schemaExp :: ExpQ +schemaExp = do + schemaFile <- runIO $ canonicalizePath "data/hsdev.sql" + addDependentFile schemaFile + s <- runIO (readFile "data/hsdev.sql") + [e| s |] diff --git a/src/HsDev/Database/SQLite/Select.hs b/src/HsDev/Database/SQLite/Select.hs --- a/src/HsDev/Database/SQLite/Select.hs +++ b/src/HsDev/Database/SQLite/Select.hs @@ -1,159 +1,159 @@ -{-# LANGUAGE OverloadedStrings, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} - -module HsDev.Database.SQLite.Select ( - Select(..), select_, from_, where_, buildQuery, toQuery, - qSymbolId, qSymbol, qModuleLocation, qModuleId, qImport, qBuildInfo, - qNSymbol, qNote - ) where - -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Data.Semigroup -import Database.SQLite.Simple -import Text.Format - -data Select a = Select { - selectColumns :: [a], - selectTables :: [a], - selectConditions :: [a] } - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) - -instance Semigroup (Select a) where - Select lc lt lcond <> Select rc rt rcond = Select - (lc <> rc) - (lt <> rt) - (lcond <> rcond) - -instance Monoid (Select a) where - mempty = Select mempty mempty mempty - mappend l r = l <> r - -select_ :: [a] -> Select a -select_ cols = Select cols [] [] - -from_ :: [a] -> Select a -from_ tbls = Select [] tbls [] - -where_ :: [a] -> Select a -where_ = Select [] [] - -buildQuery :: Select Text -> String -buildQuery (Select cols tables conds) = "select {} from {} where {}" - ~~ T.intercalate ", " cols - ~~ T.intercalate ", " tables - ~~ T.intercalate " and " (map (\cond -> T.concat ["(", cond, ")"]) conds) - -toQuery :: Select Text -> Query -toQuery = fromString . buildQuery - -qSymbolId :: Select Text -qSymbolId = mconcat [ - select_ [ - "s.name", - "m.name", - "m.file", - "m.cabal", - "m.install_dirs", - "m.package_name", - "m.package_version", - "m.installed_name", - "m.exposed", - "m.other_location"], - from_ ["modules as m", "symbols as s"], - where_ ["m.id == s.module_id"]] - -qSymbol :: Select Text -qSymbol = mconcat [ - qSymbolId, - select_ [ - "s.docs", - "s.line", - "s.column", - "s.what", - "s.type", - "s.parent", - "s.constructors", - "s.args", - "s.context", - "s.associate", - "s.pat_type", - "s.pat_constructor"]] - -qModuleLocation :: Text -> Select Text -qModuleLocation ml = template ["ml" ~% ml] [ - select_ [ - "{ml}.file", - "{ml}.cabal", - "{ml}.install_dirs", - "{ml}.package_name", - "{ml}.package_version", - "{ml}.installed_name", - "{ml}.exposed", - "{ml}.other_location"], - from_ ["modules as {ml}"]] - -qModuleId :: Select Text -qModuleId = mconcat [ - select_ [ - "mu.name", - "mu.file", - "mu.cabal", - "mu.install_dirs", - "mu.package_name", - "mu.package_version", - "mu.installed_name", - "mu.exposed", - "mu.other_location"], - from_ ["modules as mu"], - where_ ["mu.name is not null"]] - -qImport :: Text -> Select Text -qImport i = template ["i" ~% i] [ - select_ [ - "{i}.line", "{i}.column", - "{i}.module_name", - "{i}.qualified", - "{i}.alias"], - from_ ["imports as {i}"]] - -qBuildInfo :: Select Text -qBuildInfo = mconcat [ - select_ [ - "bi.depends", - "bi.language", - "bi.extensions", - "bi.ghc_options", - "bi.source_dirs", - "bi.other_modules"], - from_ ["build_infos as bi"]] - --- | Symbol from haskell-names -qNSymbol :: Text -> Text -> Select Text -qNSymbol m s = template ["m" ~% m, "s" ~% s] [ - select_ [ - "{s}.what", - "{m}.name", - "{s}.name", - "{s}.parent", - "{s}.constructors", - "{s}.associate", - "{s}.pat_type", - "{s}.pat_constructor"], - from_ ["symbols as {s}", "modules as {m}"], - where_ ["{m}.id = {s}.module_id"]] - -qNote :: Text -> Text -> Select Text -qNote m n = template ["m" ~% m, "n" ~% n] [ - select_ [ - "{m}.file", - "{n}.line", "{n}.column", "{n}.line_to", "{n}.column_to", - "{n}.severity", - "{n}.message", "{n}.suggestion"], - from_ ["modules as {m}", "messages as {n}"], - where_ [ - "{m}.file is not null", - "{n}.module_id = {m}.id"]] - -template :: [FormatArg] -> [Select Text] -> Select Text -template args = fmap ((`formats` args) . T.unpack) . mconcat +{-# LANGUAGE OverloadedStrings, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} + +module HsDev.Database.SQLite.Select ( + Select(..), select_, from_, where_, buildQuery, toQuery, + qSymbolId, qSymbol, qModuleLocation, qModuleId, qImport, qBuildInfo, + qNSymbol, qNote + ) where + +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Data.Semigroup +import Database.SQLite.Simple +import Text.Format + +data Select a = Select { + selectColumns :: [a], + selectTables :: [a], + selectConditions :: [a] } + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Semigroup (Select a) where + Select lc lt lcond <> Select rc rt rcond = Select + (lc <> rc) + (lt <> rt) + (lcond <> rcond) + +instance Monoid (Select a) where + mempty = Select mempty mempty mempty + mappend l r = l <> r + +select_ :: [a] -> Select a +select_ cols = Select cols [] [] + +from_ :: [a] -> Select a +from_ tbls = Select [] tbls [] + +where_ :: [a] -> Select a +where_ = Select [] [] + +buildQuery :: Select Text -> String +buildQuery (Select cols tables conds) = "select {} from {} where {}" + ~~ T.intercalate ", " cols + ~~ T.intercalate ", " tables + ~~ T.intercalate " and " (map (\cond -> T.concat ["(", cond, ")"]) conds) + +toQuery :: Select Text -> Query +toQuery = fromString . buildQuery + +qSymbolId :: Select Text +qSymbolId = mconcat [ + select_ [ + "s.name", + "m.name", + "m.file", + "m.cabal", + "m.install_dirs", + "m.package_name", + "m.package_version", + "m.installed_name", + "m.exposed", + "m.other_location"], + from_ ["modules as m", "symbols as s"], + where_ ["m.id == s.module_id"]] + +qSymbol :: Select Text +qSymbol = mconcat [ + qSymbolId, + select_ [ + "s.docs", + "s.line", + "s.column", + "s.what", + "s.type", + "s.parent", + "s.constructors", + "s.args", + "s.context", + "s.associate", + "s.pat_type", + "s.pat_constructor"]] + +qModuleLocation :: Text -> Select Text +qModuleLocation ml = template ["ml" ~% ml] [ + select_ [ + "{ml}.file", + "{ml}.cabal", + "{ml}.install_dirs", + "{ml}.package_name", + "{ml}.package_version", + "{ml}.installed_name", + "{ml}.exposed", + "{ml}.other_location"], + from_ ["modules as {ml}"]] + +qModuleId :: Select Text +qModuleId = mconcat [ + select_ [ + "mu.name", + "mu.file", + "mu.cabal", + "mu.install_dirs", + "mu.package_name", + "mu.package_version", + "mu.installed_name", + "mu.exposed", + "mu.other_location"], + from_ ["modules as mu"], + where_ ["mu.name is not null"]] + +qImport :: Text -> Select Text +qImport i = template ["i" ~% i] [ + select_ [ + "{i}.line", "{i}.column", + "{i}.module_name", + "{i}.qualified", + "{i}.alias"], + from_ ["imports as {i}"]] + +qBuildInfo :: Select Text +qBuildInfo = mconcat [ + select_ [ + "bi.depends", + "bi.language", + "bi.extensions", + "bi.ghc_options", + "bi.source_dirs", + "bi.other_modules"], + from_ ["build_infos as bi"]] + +-- | Symbol from haskell-names +qNSymbol :: Text -> Text -> Select Text +qNSymbol m s = template ["m" ~% m, "s" ~% s] [ + select_ [ + "{s}.what", + "{m}.name", + "{s}.name", + "{s}.parent", + "{s}.constructors", + "{s}.associate", + "{s}.pat_type", + "{s}.pat_constructor"], + from_ ["symbols as {s}", "modules as {m}"], + where_ ["{m}.id = {s}.module_id"]] + +qNote :: Text -> Text -> Select Text +qNote m n = template ["m" ~% m, "n" ~% n] [ + select_ [ + "{m}.file", + "{n}.line", "{n}.column", "{n}.line_to", "{n}.column_to", + "{n}.severity", + "{n}.message", "{n}.suggestion"], + from_ ["modules as {m}", "messages as {n}"], + where_ [ + "{m}.file is not null", + "{n}.module_id = {m}.id"]] + +template :: [FormatArg] -> [Select Text] -> Select Text +template args = fmap ((`formats` args) . T.unpack) . mconcat diff --git a/src/HsDev/Database/SQLite/Transaction.hs b/src/HsDev/Database/SQLite/Transaction.hs --- a/src/HsDev/Database/SQLite/Transaction.hs +++ b/src/HsDev/Database/SQLite/Transaction.hs @@ -1,98 +1,98 @@ -{-# LANGUAGE TypeApplications, MultiWayIf, OverloadedStrings #-} - -module HsDev.Database.SQLite.Transaction ( - TransactionType(..), - Retries(..), def, noRetry, retryForever, retryN, - - -- * Transactions - withTransaction, beginTransaction, commitTransaction, rollbackTransaction, - transaction, transaction_, - - -- * Retry functions - retry, retry_ - ) where - -import Control.Concurrent -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.Default -import Database.SQLite.Simple as SQL hiding (withTransaction) - -import HsDev.Server.Types (SessionMonad, serverSqlDatabase) - --- | Three types of transactions -data TransactionType = Deferred | Immediate | Exclusive - deriving (Eq, Ord, Read, Show) - --- | Retry config -data Retries = Retries { - retriesIntervals :: [Int], - retriesError :: SQLError -> Bool } - -instance Default Retries where - def = Retries (replicate 10 100000) $ \e -> sqlError e `elem` [ErrorBusy, ErrorLocked] - --- | Don't retry -noRetry :: Retries -noRetry = Retries [] (const False) - --- | Retry forever -retryForever :: Int -> Retries -retryForever interval = def { retriesIntervals = repeat interval } - --- | Retry with interval N times -retryN :: Int -> Int -> Retries -retryN interval times = def { retriesIntervals = replicate times interval } - --- | Run actions inside transaction -withTransaction :: (MonadIO m, MonadMask m) => Connection -> TransactionType -> Retries -> m a -> m a -withTransaction conn t rs act = mask $ \restore -> do - mretry restore (beginTransaction conn t) - (restore act <* mretry restore (commitTransaction conn)) `onException` rollbackTransaction conn - where - mretry restore' fn = mretry' (retriesIntervals rs) where - mretry' [] = fn - mretry' (tm:tms) = catch @_ @SQLError fn $ \e -> if - | retriesError rs e -> do - _ <- restore' $ liftIO $ threadDelay tm - mretry' tms - | otherwise -> throwM e - --- | Begin transaction -beginTransaction :: MonadIO m => Connection -> TransactionType -> m () -beginTransaction conn t = liftIO $ SQL.execute_ conn $ case t of - Deferred -> "begin transaction;" - Immediate -> "begin immediate transaction;" - Exclusive -> "begin exclusive transaction;" - --- | Commit transaction -commitTransaction :: MonadIO m => Connection -> m () -commitTransaction conn = liftIO $ SQL.execute_ conn "commit transaction;" - --- | Rollback transaction -rollbackTransaction :: MonadIO m => Connection -> m () -rollbackTransaction conn = liftIO $ SQL.execute_ conn "rollback transaction;" - --- | Run transaction in @SessionMonad@ -transaction :: SessionMonad m => TransactionType -> Retries -> m a -> m a -transaction t rs act = do - conn <- serverSqlDatabase - withTransaction conn t rs act - --- | Transaction with default retries config -transaction_ :: SessionMonad m => TransactionType -> m a -> m a -transaction_ t = transaction t def - --- | Retry operation -retry :: (MonadIO m, MonadCatch m) => Retries -> m a -> m a -retry rs = retry' (retriesIntervals rs) where - retry' [] fn = fn - retry' (tm:tms) fn = catch @_ @SQLError fn $ \e -> if - | retriesError rs e -> do - liftIO $ threadDelay tm - retry' tms fn - | otherwise -> throwM e - --- | Retry with default params -retry_ :: (MonadIO m, MonadCatch m) => m a -> m a -retry_ = retry def +{-# LANGUAGE TypeApplications, MultiWayIf, OverloadedStrings #-} + +module HsDev.Database.SQLite.Transaction ( + TransactionType(..), + Retries(..), def, noRetry, retryForever, retryN, + + -- * Transactions + withTransaction, beginTransaction, commitTransaction, rollbackTransaction, + transaction, transaction_, + + -- * Retry functions + retry, retry_ + ) where + +import Control.Concurrent +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Default +import Database.SQLite.Simple as SQL hiding (withTransaction) + +import HsDev.Server.Types (SessionMonad, serverSqlDatabase) + +-- | Three types of transactions +data TransactionType = Deferred | Immediate | Exclusive + deriving (Eq, Ord, Read, Show) + +-- | Retry config +data Retries = Retries { + retriesIntervals :: [Int], + retriesError :: SQLError -> Bool } + +instance Default Retries where + def = Retries (replicate 10 100000) $ \e -> sqlError e `elem` [ErrorBusy, ErrorLocked] + +-- | Don't retry +noRetry :: Retries +noRetry = Retries [] (const False) + +-- | Retry forever +retryForever :: Int -> Retries +retryForever interval = def { retriesIntervals = repeat interval } + +-- | Retry with interval N times +retryN :: Int -> Int -> Retries +retryN interval times = def { retriesIntervals = replicate times interval } + +-- | Run actions inside transaction +withTransaction :: (MonadIO m, MonadMask m) => Connection -> TransactionType -> Retries -> m a -> m a +withTransaction conn t rs act = mask $ \restore -> do + mretry restore (beginTransaction conn t) + (restore act <* mretry restore (commitTransaction conn)) `onException` rollbackTransaction conn + where + mretry restore' fn = mretry' (retriesIntervals rs) where + mretry' [] = fn + mretry' (tm:tms) = catch @_ @SQLError fn $ \e -> if + | retriesError rs e -> do + _ <- restore' $ liftIO $ threadDelay tm + mretry' tms + | otherwise -> throwM e + +-- | Begin transaction +beginTransaction :: MonadIO m => Connection -> TransactionType -> m () +beginTransaction conn t = liftIO $ SQL.execute_ conn $ case t of + Deferred -> "begin transaction;" + Immediate -> "begin immediate transaction;" + Exclusive -> "begin exclusive transaction;" + +-- | Commit transaction +commitTransaction :: MonadIO m => Connection -> m () +commitTransaction conn = liftIO $ SQL.execute_ conn "commit transaction;" + +-- | Rollback transaction +rollbackTransaction :: MonadIO m => Connection -> m () +rollbackTransaction conn = liftIO $ SQL.execute_ conn "rollback transaction;" + +-- | Run transaction in @SessionMonad@ +transaction :: SessionMonad m => TransactionType -> Retries -> m a -> m a +transaction t rs act = do + conn <- serverSqlDatabase + withTransaction conn t rs act + +-- | Transaction with default retries config +transaction_ :: SessionMonad m => TransactionType -> m a -> m a +transaction_ t = transaction t def + +-- | Retry operation +retry :: (MonadIO m, MonadCatch m) => Retries -> m a -> m a +retry rs = retry' (retriesIntervals rs) where + retry' [] fn = fn + retry' (tm:tms) fn = catch @_ @SQLError fn $ \e -> if + | retriesError rs e -> do + liftIO $ threadDelay tm + retry' tms fn + | otherwise -> throwM e + +-- | Retry with default params +retry_ :: (MonadIO m, MonadCatch m) => m a -> m a +retry_ = retry def diff --git a/src/HsDev/Database/Update.hs b/src/HsDev/Database/Update.hs --- a/src/HsDev/Database/Update.hs +++ b/src/HsDev/Database/Update.hs @@ -1,692 +1,692 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses, RankNTypes, TypeOperators, TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Database.Update ( - Status(..), Progress(..), Task(..), - UpdateOptions(..), - - UpdateM(..), - runUpdate, - - postStatus, updater, runTask, runTasks, runTasks_, - - scanModules, scanFile, scanFiles, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanPackageDbStack, scanProjectFile, scanProjectStack, scanProject, scanDirectory, - scanPackageDbStackDocs, scanDocs, - setModTypes, inferModTypes, - scan, - processEvents, updateEvents, applyUpdates, - - cacheGhcWarnings, cachedWarnings, - - module HsDev.Database.Update.Types, - - module HsDev.Watcher, - - module Control.Monad.Except - ) where - -import qualified Control.Concurrent.Async as A -import Control.Concurrent.MVar -import Control.DeepSeq -import Control.Exception (ErrorCall, evaluate, displayException) -import Control.Lens -import Control.Monad.Catch (catch, handle, MonadThrow, bracket_) -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State (get, modify, runStateT) -import Data.Aeson -import Data.List (intercalate) -import Data.String (fromString) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Maybe -import Data.Text (Text) -import Data.Time.Clock.POSIX -import qualified Data.Text as T -import System.FilePath -import qualified System.Log.Simple as Log - -import Data.Maybe.JustIf -import HsDev.Error -import qualified HsDev.Database.SQLite as SQLite -import HsDev.Display -import HsDev.Inspect -import HsDev.Inspect.Order -import HsDev.PackageDb -import HsDev.Project -import HsDev.Sandbox -import qualified HsDev.Stack as S -import HsDev.Symbols -import HsDev.Tools.Ghc.Session hiding (Session, evaluate) -import HsDev.Tools.Ghc.Types (fileTypes, TypedExpr) -import HsDev.Tools.Types -import HsDev.Tools.HDocs -import qualified HsDev.Scan as S -import HsDev.Scan.Browse -import HsDev.Util (ordNub, fromJSON', uniqueBy, timer) -import qualified HsDev.Util as Util (withCurrentDirectory) -import HsDev.Server.Types (commandNotify, inSessionGhc, FileSource(..)) -import HsDev.Server.Message -import HsDev.Database.Update.Types -import HsDev.Watcher -import Text.Format -import System.Directory.Paths - -onStatus :: UpdateMonad m => m () -onStatus = asks (view (updateOptions . updateTasks)) >>= commandNotify . Notification . toJSON . reverse - -childTask :: UpdateMonad m => Task -> m a -> m a -childTask t = local (over (updateOptions . updateTasks) (t:)) - -transact :: SessionMonad m => m a -> m a -transact = SQLite.transaction_ SQLite.Immediate - -runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a -runUpdate uopts act = Log.scope "update" $ do - (r, updatedMods) <- withUpdateState uopts $ \ust -> - runWriterT (runUpdateM act' `runReaderT` ust) - Log.sendLog Log.Debug $ "updated {} modules" ~~ length updatedMods - return r - where - act' = do - (r, _) <- listen act - -- (r, mlocs') <- listen act - - -- dbs <- liftM S.unions $ forM mlocs' $ \mloc' -> do - -- mid <- SQLite.lookupModuleLocation mloc' - -- case mid of - -- Nothing -> return (S.empty :: S.Set PackageDb) - -- Just mid' -> liftM (S.fromList . map SQLite.fromOnly) $ SQLite.query (SQLite.toQuery $ SQLite.select_ - -- ["ps.package_db"] - -- ["package_dbs as ps", "modules as m"] - -- ["m.package_name == ps.package_name", "m.package_version == ps.package_version", "m.id == ?"]) (SQLite.Only mid') - - -- If some sourced files depends on currently scanned package-dbs - -- We must resolve them and even rescan if there was errors scanning without - -- dependencies provided (lack of fixities can cause errors inspecting files) - - -- sboxes = databaseSandboxes dbval - -- sboxOf :: Path -> Maybe Sandbox - -- sboxOf fpath = find (pathInSandbox fpath) sboxes - -- projsRows <- SQLite.query_ "select name, cabal, version, ifnull(package_db_stack, json('[]')) from projects;" - -- let - -- projs = [proj' | (proj' SQLite.:. (SQLite.Only (SQLite.JSON projPdbs))) <- projsRows, - -- not (S.null (S.fromList projPdbs `S.intersection` dbs))] - - -- stands = [] - -- -- HOWTO? - -- -- stands = do - -- -- sloc <- dbval ^.. standaloneSlice . modules . moduleId . moduleLocation - -- -- guard $ sboxUpdated $ sboxOf (sloc ^?! moduleFile) - -- -- guard (notElem sloc mlocs') - -- -- return (sloc, dbval ^.. databaseModules . ix sloc . inspection . inspectionOpts . each . unpacked, Nothing) - - -- Log.sendLog Log.Trace $ "updated package-dbs: {}, have to rescan {} projects and {} files" - -- ~~ intercalate ", " (map display $ S.toList dbs) - -- ~~ length projs ~~ length stands - -- (_, rlocs') <- listen $ runTasks_ (scanModules [] stands : [scanProject [] (proj ^. projectCabal) | proj <- projs]) - -- let - -- ulocs' = filter (isJust . preview moduleFile) (ordNub $ mlocs' ++ rlocs') - -- getMods :: (MonadIO m) => m [InspectedModule] - -- getMods = do - -- db' <- liftIO $ readAsync db - -- return $ filter ((`elem` ulocs') . view inspectedKey) $ toList $ view databaseModules db' - - -- FIXME: Now it's broken since `Database` is not used anymore - when (view updateDocs uopts) $ do - Log.sendLog Log.Trace "forking inspecting source docs" - Log.sendLog Log.Warning "not implemented" - -- void $ fork (getMods >>= waiter . mapM_ scanDocs_) - when (view updateInfer uopts) $ do - Log.sendLog Log.Trace "forking inferring types" - Log.sendLog Log.Warning "not implemented" - -- void $ fork (getMods >>= waiter . mapM_ inferModTypes_) - return r - -- scanDocs_ :: UpdateMonad m => InspectedModule -> m () - -- scanDocs_ im = do - -- im' <- (S.scanModify (\opts -> inSessionGhc . liftGhc . inspectDocsGhc opts) im) <|> return im - -- sendUpdateAction $ Log.scope "scan-docs" $ SQLite.updateModule im' - -- inferModTypes_ :: UpdateMonad m => InspectedModule -> m () - -- inferModTypes_ im = do - -- -- TODO: locate sandbox - -- im' <- (S.scanModify infer' im) <|> return im - -- sendUpdateAction $ Log.scope "infer-types" $ SQLite.updateModule im' - -- infer' :: UpdateMonad m => [String] -> Module -> m Module - -- infer' opts m = case preview (moduleId . moduleLocation . moduleFile) m of - -- Nothing -> return m - -- Just _ -> inSessionGhc $ do - -- targetSession opts m - -- inferTypes opts m Nothing - --- | Post status -postStatus :: UpdateMonad m => Task -> m () -postStatus t = childTask t onStatus - --- | Mark module as updated -updater :: UpdateMonad m => [ModuleLocation] -> m () -updater mlocs = tell $!! mlocs - --- | Run one task -runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a -runTask action subj act = Log.scope "task" $ do - postStatus $ set taskStatus StatusWorking task - x <- childTask task act - x `deepseq` postStatus (set taskStatus StatusOk task) - return x - `catch` - (\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e) - where - task = Task { - _taskName = action, - _taskStatus = StatusWorking, - _taskSubjectType = displayType subj, - _taskSubjectName = display subj, - _taskProgress = Nothing } - --- | Run many tasks with numeration -runTasks :: UpdateMonad m => [m a] -> m [a] -runTasks ts = liftM catMaybes $ zipWithM taskNum [1..] (map noErr ts) where - total = length ts - taskNum n = local setProgress where - setProgress = set (updateOptions . updateTasks . _head . taskProgress) (Just (Progress n total)) - noErr v = hsdevIgnore Nothing (Just <$> v) - --- | Run many tasks with numeration -runTasks_ :: UpdateMonad m => [m ()] -> m () -runTasks_ = void . runTasks - -data PreloadFailure = PreloadFailure ModuleLocation Inspection HsDevError - -instance NFData PreloadFailure where - rnf (PreloadFailure mloc insp err) = rnf mloc `seq` rnf insp `seq` rnf err - --- | Scan modules -scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m () -scanModules opts ms = Log.scope "scan-modules" $ mapM_ (uncurry scanModules') grouped where - scanModules' mproj ms' = do - maybe (return ()) (sendUpdateAction . SQLite.updateProject) mproj - updater $ ms' ^.. each . _1 - defines <- askSession sessionDefines - - let - pload (mloc, mopts, mcts) = runTask "preloading" mloc $ do - mfcts <- maybe (S.getFileContents (mloc ^?! moduleFile)) (const $ return Nothing) mcts - insp <- liftIO $ fileInspection (mloc ^?! moduleFile) (opts ++ mopts) - case (mfcts ^? _Just . _1) of - Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm - Nothing -> return () - let - inspection' = maybe insp (fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1 - dirtyTag' = maybe id (const $ inspectTag DirtyTag) $ mfcts ^? _Just . _1 - mcts' = mplus mcts (mfcts ^? _Just . _2) - runInspect mloc $ withInspection (return inspection') $ dirtyTag' $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mcts' - - ploaded <- runTasks (map pload ms') - sendUpdateAction $ void $ SQLite.upsertModules $ map (fmap (view asModule)) ploaded - let - mlocs' = ploaded ^.. each . inspected . preloadedId . moduleLocation - - updater mlocs' - - let - mcabal = mproj ^? _Just . projectCabal - - (env, fixities) <- loadEnv mcabal - - Log.sendLog Log.Trace $ "resolved environment: {} modules" ~~ M.size env - case orderBy (preview inspected) ploaded of - Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err) - Right ordered -> do - (ms'', (updEnv, updFixities)) <- flip runStateT (env, fixities) $ runTasks (map inspect' ordered) - saveEnv mcabal updEnv updFixities - mlocs'' <- timer "updated scanned modules" $ do - Log.sendLog Log.Trace $ case mproj of - Just proj -> "inserting data for resolved modules of project: {}" ~~ proj - Nothing -> "inserting data for resolved standalone modules" - sendUpdateAction $ Log.scope "resolved" $ updateResolveds mcabal ms'' - return (ms'' ^.. each . inspectedKey) - updater mlocs'' - where - inspect' pmod = runTask "scanning" ploc $ Log.scope "module" $ do - (env', fixities') <- get - r <- continueInspect pmod $ \p -> do - resolved' <- msum [ - resolveModule env' fixities' p, - do - lift (Log.sendLog Log.Trace ("error resolving module {}, falling to resolving just imports/scope" ~~ (p ^. preloadedId . moduleLocation))) - resolvePreloaded env' p] - eval resolved' - modify $ mappend ( - maybe mempty resolvedEnv (r ^? inspected), - maybe mempty resolvedFixitiesTable (r ^? inspected)) - return r - where - ploc = pmod ^?! inspected . preloadedId . moduleLocation - - grouped = M.toList $ M.unionsWith (++) [M.singleton (m ^? _1 . moduleProject . _Just) [m] | m <- ms] - eval v = handle onError (v `deepseq` liftIO (evaluate v)) where - onError :: MonadThrow m => ErrorCall -> m a - onError = hsdevError . OtherError . displayException - --- | Scan source file, possibly scanning also related project and installed modules -scanFile :: UpdateMonad m => [String] -> Path -> BuildTool -> Bool -> Bool -> m () -scanFile opts fpath tool scanProj scanDb = do - mproj <- fmap (set (_Just . projectBuildTool) tool) $ locateProjectInfo fpath - sbox <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj - when scanDb $ do - [SQLite.Only scanned] <- SQLite.query @_ @(SQLite.Only Bool) "select count(*) > 0 from package_dbs as pdbs where pdbs.package_db = ?;" (SQLite.Only (topPackageDb sbox)) - unless scanned $ scanPackageDbStack opts sbox - case join (mproj `justIf` scanProj) of - Nothing -> scanFiles [(FileSource fpath Nothing, opts)] - Just proj -> scanProject opts tool (view projectCabal proj) - --- | Scan source files, resolving dependent modules -scanFiles :: UpdateMonad m => [(FileSource, [String])] -> m () -scanFiles fsrcs = runTask "scanning" ("files" :: String) $ Log.scope "files" $ hsdevLiftIO $ do - Log.sendLog Log.Trace $ "scanning {} files" ~~ length fsrcs - fpaths' <- traverse (liftIO . canonicalize) $ map (fileSource . fst) fsrcs - forM_ fpaths' $ \fpath' -> do - ex <- liftIO $ fileExists fpath' - unless ex $ hsdevError $ FileNotFound fpath' - mlocs <- forM fpaths' $ \fpath' -> do - mids <- SQLite.query (SQLite.toQuery $ SQLite.qModuleId `mappend` SQLite.where_ ["mu.file == ?"]) (SQLite.Only fpath') - if length mids > 1 - then return (head mids ^. moduleLocation) - else do - mproj <- locateProjectInfo fpath' - return $ FileModule fpath' mproj - let - filesMods = liftM concat $ forM fpaths' $ \fpath' -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file == ?;" (SQLite.Only fpath') - scan filesMods [(mloc, opts, mcts) | (mloc, (FileSource _ mcts, opts)) <- zip mlocs fsrcs] [] $ \mlocs' -> do - mapM_ ((watch . flip watchModule) . view _1) mlocs' - S.ScanContents dmods _ _ <- fmap mconcat $ mapM (S.enumDependent . view (_1 . moduleFile . path)) mlocs' - Log.sendLog Log.Trace $ "dependent modules: {}" ~~ length dmods - scanModules [] (mlocs' ++ dmods) - --- | Scan source file with contents and resolve dependent modules -scanFileContents :: UpdateMonad m => [String] -> Path -> Maybe Text -> m () -scanFileContents opts fpath mcts = scanFiles [(FileSource fpath mcts, opts)] - --- | Scan cabal modules, doesn't rescan if already scanned -scanCabal :: UpdateMonad m => [String] -> m () -scanCabal opts = Log.scope "cabal" $ scanPackageDbStack opts userDb - --- | Prepare sandbox for scanning. This is used for stack project to build & configure. -prepareSandbox :: UpdateMonad m => Sandbox -> m () -prepareSandbox sbox@(Sandbox StackTool fpath) = Log.scope "prepare" $ runTasks_ [ - runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.buildDeps Nothing] - where - dir = takeDirectory $ view path fpath -prepareSandbox _ = return () - --- | Scan sandbox modules, doesn't rescan if already scanned -scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m () -scanSandbox opts sbox = Log.scope "sandbox" $ do - -- prepareSandbox sbox - pdbs <- inSessionGhc $ sandboxPackageDbStack sbox - scanPackageDbStack opts pdbs - --- | Scan top of package-db stack, usable for rescan -scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m () -scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do - pdbState <- liftIO $ readPackageDb (topPackageDb pdbs) - let - packageDbMods = S.fromList $ concat $ M.elems pdbState - packages' = M.keys pdbState - Log.sendLog Log.Trace $ "package-db state: {} modules" ~~ length packageDbMods - watch (\w -> watchPackageDb w pdbs opts) - - pkgs <- SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only $ topPackageDb pdbs) - if S.fromList packages' == S.fromList pkgs - then Log.sendLog Log.Trace "nothing changes, all packages the same" - else do - mlocs <- liftM - (filter (`S.member` packageDbMods)) $ - (inSessionGhc $ listModules opts pdbs packages') - let - umlocs = uniqueModuleLocations mlocs - Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs - let - packageDbMods' = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only (topPackageDb pdbs)) - scan packageDbMods' ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do - ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1) - Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms - sendUpdateAction $ timer "updated package-db modules" $ do - SQLite.updateModules ms - SQLite.updatePackageDb (topPackageDb pdbs) (M.keys pdbState) - - when hdocsSupported $ scanPackageDbStackDocs opts pdbs - - updater $ ms ^.. each . inspectedKey - --- | Scan top of package-db stack, usable for rescan -scanPackageDbStack :: UpdateMonad m => [String] -> PackageDbStack -> m () -scanPackageDbStack opts pdbs = runTask "scanning" pdbs $ Log.scope "package-db-stack" $ do - pdbStates <- liftIO $ mapM readPackageDb (packageDbs pdbs) - let - packageDbMods = S.fromList $ concat $ concatMap M.elems pdbStates - packages' = ordNub $ concatMap M.keys pdbStates - Log.sendLog Log.Trace $ "package-db-stack state: {} modules" ~~ length packageDbMods - watch (\w -> watchPackageDbStack w pdbs opts) - - pkgs <- liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only pdb) - if S.fromList packages' == S.fromList pkgs - then Log.sendLog Log.Trace "nothing changes, all packages the same" - else do - mlocs <- liftM - (filter (`S.member` packageDbMods)) $ - (inSessionGhc $ listModules opts pdbs packages') - let - umlocs = uniqueModuleLocations mlocs - Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs - let - packageDbStackMods = liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only pdb) - scan packageDbStackMods ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do - ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1) - Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms - sendUpdateAction $ timer "updated package-db-stack modules" $ do - SQLite.updateModules ms - sequence_ [SQLite.updatePackageDb pdb (M.keys pdbState) | (pdb, pdbState) <- zip (packageDbs pdbs) pdbStates] - - -- BUG: I don't know why, but these steps leads to segfault on my PC: - -- > hsdev scan --cabal --project . - -- > hsdev check -f .\src\HsDev\Client\Commands.hs - -- But it works if docs are scanned, it also works from ghci - - -- needDocs <- asks (view updateDocs) - -- ms' <- if needDocs - -- then do - -- docs <- inSessionGhc $ hdocsCabal pdbs opts - -- return $ map (fmap $ setDocs' docs) ms - -- else return ms - - when hdocsSupported $ scanPackageDbStackDocs opts pdbs - - updater $ ms ^.. each . inspectedKey - --- | Scan project file -scanProjectFile :: UpdateMonad m => [String] -> BuildTool -> Path -> m Project -scanProjectFile opts tool cabal = runTask "scanning" cabal $ do - proj <- fmap (set projectBuildTool tool) $ S.scanProjectFile opts cabal - pdbs <- inSessionGhc $ getProjectPackageDbStack proj - let - proj' = set projectPackageDbStack (Just pdbs) proj - sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj' - return proj' - --- | Refine project info and update if necessary -refineProjectInfo :: UpdateMonad m => Project -> m Project -refineProjectInfo proj = do - [SQLite.Only exist] <- SQLite.query "select count(*) > 0 from projects where cabal == ?;" (SQLite.Only (proj ^. projectCabal)) - if exist - then SQLite.loadProject (proj ^. projectCabal) - else runTask "scanning" (proj ^. projectCabal) $ do - proj' <- liftIO $ loadProject proj - pdbs <- inSessionGhc $ getProjectPackageDbStack proj' - let - proj'' = set projectPackageDbStack (Just pdbs) proj' - sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj'' - return proj'' - --- | Get project info for module -locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project) -locateProjectInfo cabal = liftIO (locateProject (view path cabal)) >>= traverse refineProjectInfo - --- | Scan project and related package-db stack -scanProjectStack :: UpdateMonad m => [String] -> BuildTool -> Path -> m () -scanProjectStack opts tool cabal = do - sbox <- liftIO $ projectSandbox tool cabal - maybe (scanCabal opts) (scanSandbox opts) sbox - scanProject opts tool cabal - --- | Scan project -scanProject :: UpdateMonad m => [String] -> BuildTool -> Path -> m () -scanProject opts tool cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do - proj <- scanProjectFile opts tool cabal - watch (\w -> watchProject w proj opts) - S.ScanContents _ [(_, sources)] _ <- S.enumProject proj - let - projMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file is not null and m.cabal == ?;" (SQLite.Only $ proj ^. projectCabal) - scan projMods sources opts $ scanModules opts - - -- Scan docs - -- inSessionGhc $ do - -- currentSession >>= maybe (return ()) (const clearTargets) - - -- forM_ (maybe [] targetInfos (proj ^. projectDescription)) $ \tinfo' -> do - -- opts' <- getProjectTargetOpts [] proj (tinfo' ^. targetBuildInfo) - -- files' <- projectTargetFiles proj tinfo' - -- haddockSession opts' - -- docsMap <- liftGhc $ readProjectTargetDocs opts' proj files' - -- Log.sendLog Log.Debug $ "scanned logs for modules: {}, summary docs: {}" ~~ (intercalate "," (M.keys docsMap)) ~~ (sum $ map M.size $ M.elems docsMap) - - --- | Scan directory for source files and projects -scanDirectory :: UpdateMonad m => [String] -> Path -> m () -scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do - S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory (view path dir) - runTasks_ [scanProject opts CabalTool (view projectCabal p) | (p, _) <- projSrcs] - runTasks_ $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan - mapMOf_ (each . _1) (watch . flip watchModule) standSrcs - let - standaloneMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.cabal is null and m.file is not null and m.file like ? escape '\\';" (SQLite.Only $ SQLite.escapeLike dir `T.append` "%") - scan standaloneMods standSrcs opts $ scanModules opts - --- | Scan installed docs -scanPackageDbStackDocs :: UpdateMonad m => [String] -> PackageDbStack -> m () -scanPackageDbStackDocs opts pdbs - | hdocsSupported = Log.scope "docs" $ do - docs <- inSessionGhc $ hdocsCabal pdbs opts - Log.sendLog Log.Trace $ "docs scanned: {} packages, {} modules total" - ~~ length docs ~~ sum (map (M.size . snd) docs) - sendUpdateAction $ transact $ SQLite.executeMany "update symbols set docs = ? where name == ? and module_id in (select id from modules where name == ? and package_name == ? and package_version == ?);" $ do - (ModulePackage pname pver, pdocs) <- docs - (mname, mdocs) <- M.toList pdocs - (nm, doc) <- M.toList mdocs - return (doc, nm, mname, pname, pver) - Log.sendLog Log.Trace "docs set" - | otherwise = Log.sendLog Log.Warning "hdocs not supported" - --- | Scan docs for inspected modules -scanDocs :: UpdateMonad m => [Module] -> m () -scanDocs - | hdocsSupported = runTasks_ . map scanDocs' - | otherwise = const $ Log.sendLog Log.Warning "hdocs not supported" - where - scanDocs' m = runTask "scanning docs" (view (moduleId . moduleLocation) m) $ Log.scope "docs" $ do - mid <- SQLite.lookupModule (m ^. moduleId) - mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid - m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m - Log.sendLog Log.Trace $ "Scanning docs for {}" ~~ view (moduleId . moduleLocation) m' - docsMap <- inSessionGhc $ do - (pdbs, opts') <- getModuleOpts [] m' - currentSession >>= maybe (return ()) (const clearTargets) - -- Calling haddock with targets set sometimes cause errors - haddockSession pdbs opts' - readModuleDocs opts' m' - sendUpdateAction $ transact $ do - SQLite.executeMany "update symbols set docs = ? where name == ? and module_id == ?;" - [(doc, nm, mid') | (nm, doc) <- maybe [] M.toList docsMap] - SQLite.execute "update modules set tags = json_set(tags, '$.docs', 1) where id == ?;" (SQLite.Only mid') - --- | Set inferred types for module -setModTypes :: UpdateMonad m => ModuleId -> [Note TypedExpr] -> m () -setModTypes m ts = Log.scope "set-types" $ do - mid <- SQLite.lookupModule m - mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid - sendUpdateAction $ transact $ do - SQLite.execute "delete from types where module_id = ?;" (SQLite.Only mid') - SQLite.executeMany "insert into types (module_id, line, column, line_to, column_to, expr, type) values (?, ?, ?, ?, ?, ?, ?);" [ - (SQLite.Only mid' SQLite.:. view noteRegion n' SQLite.:. view note n') | n' <- uniqueBy (view noteRegion) ts] - SQLite.execute "update names set inferred_type = (select type from types as t where t.module_id = ? and names.line = t.line and names.column = t.column and names.line_to = t.line_to and names.column_to = t.column_to) where module_id == ?;" - (mid', mid') - SQLite.execute "update symbols set type = (select type from types as t where t.module_id = ? and symbols.line = t.line and symbols.column = t.column order by t.line_to, t.column_to) where module_id == ? and type is null;" (mid', mid') - SQLite.execute "update modules set tags = json_set(tags, '$.types', 1) where id == ?;" (SQLite.Only mid') - --- | Infer types for modules -inferModTypes :: UpdateMonad m => [Module] -> m () -inferModTypes = runTasks_ . map inferModTypes' where - inferModTypes' m = runTask "inferring types" (view (moduleId . moduleLocation) m) $ Log.scope "types" $ do - mid <- SQLite.lookupModule (m ^. moduleId) - _ <- maybe (hsdevError $ SQLiteError "module id not found") return mid - m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m - Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view (moduleId . moduleLocation) m' - - sess <- getSession - mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile) - types' <- inSessionGhc $ do - targetSession [] m' - cacheGhcWarnings sess (m' ^.. moduleId . moduleLocation) $ - fileTypes m' mcts - - setModTypes (m' ^. moduleId) types' - --- | Generic scan function. Removed obsolete modules and calls callback on changed modules. -scan :: UpdateMonad m - => m [SQLite.Only Int SQLite.:. ModuleLocation SQLite.:. Inspection] - -- ^ Get affected modules, obsolete will be removed, changed will be updated - -> [S.ModuleToScan] - -- ^ Actual modules, other will be removed - -> [String] - -- ^ Extra scan options - -> ([S.ModuleToScan] -> m ()) - -- ^ Update function - -> m () -scan part' mlocs opts act = Log.scope "scan" $ do - mlocs' <- liftM (M.fromList . map (\(SQLite.Only mid SQLite.:. (m SQLite.:. i)) -> (m, (mid, i)))) part' - let - obsolete = M.filterWithKey (\k _ -> k `S.notMember` S.fromList (map (^. _1) mlocs)) mlocs' - changed <- S.changedModules (M.map snd mlocs') opts mlocs - sendUpdateAction $ Log.scope "remove-obsolete" $ transact $ - forM_ (M.elems obsolete) $ SQLite.removeModule . fst - act changed - -processEvents :: ([(Watched, Event)] -> IO ()) -> MVar (A.Async ()) -> MVar [(Watched, Event)] -> [(Watched, Event)] -> ClientM IO () -processEvents handleEvents updaterTask eventsVar evs = Log.scope "event" $ do - Log.sendLog Log.Trace $ "events received: {}" ~~ intercalate ", " (evs ^.. each . _2 . eventPath) - l <- Log.askLog - liftIO $ do - modifyMVar_ eventsVar (return . (++evs)) - modifyMVar_ updaterTask $ \task -> do - done <- fmap isJust $ poll task - if done - then do - Log.withLog l $ Log.sendLog Log.Trace "starting update thread" - A.async $ fix $ \loop -> do - updates <- modifyMVar eventsVar (\es -> return ([], es)) - unless (null updates) $ handleEvents updates >> loop - else return task - -updateEvents :: ServerMonadBase m => [(Watched, Event)] -> UpdateM m () -updateEvents updates = Log.scope "updater" $ do - Log.sendLog Log.Trace $ "prepared to process {} events" ~~ length updates - files <- fmap concat $ forM updates $ \(w, e) -> case w of - WatchedProject proj projOpts - | isSource e -> do - Log.sendLog Log.Info $ "File '{file}' in project {proj} changed" - ~~ ("file" ~% view eventPath e) - ~~ ("proj" ~% view projectName proj) - [SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e) - opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts - return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)] - | isCabal e -> do - Log.sendLog Log.Info $ "Project {proj} changed" - ~~ ("proj" ~% view projectName proj) - scanProject projOpts (view projectBuildTool proj) (view projectCabal proj) - return [] - | otherwise -> return [] - WatchedPackageDb pdbs opts - | isConf e -> do - Log.sendLog Log.Info $ "Package db {package} changed" - ~~ ("package" ~% topPackageDb pdbs) - scanPackageDb opts pdbs - return [] - | otherwise -> return [] - WatchedModule - | isSource e -> do - Log.sendLog Log.Info $ "Module {file} changed" - ~~ ("file" ~% view eventPath e) - [SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e) - opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts - return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)] - | otherwise -> return [] - scanFiles files - where - parseErr' mopts' = do - Log.sendLog Log.Error $ "Error parsing inspection_opts: {}" ~~ show mopts' - hsdevError $ SQLiteError $ "Error parsing inspection_opts: {}" ~~ show mopts' - -applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO () -applyUpdates uopts = runUpdate uopts . updateEvents - --- Save ghc warnings on loading target, because second loading won't produce any -cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a -cacheGhcWarnings sess mlocs act = Log.scope "cache-warnings" $ do - tm <- liftIO getPOSIXTime - (r, msgs) <- collectMessages act - Log.sendLog Log.Trace $ "collected {} warnings" ~~ length msgs - _ <- liftIO $ withSession sess $ postSessionUpdater $ refreshCache mlocs tm msgs - return r - where - refreshCache :: [ModuleLocation] -> POSIXTime -> [Note OutputMessage] -> ServerM IO () - refreshCache mlocs' tm' msgs' = Log.scope "refresh" $ bracket_ initTemp dropTemp $ do - fillTemp - removeOutdated - insertMessages - where - initTemp :: SessionMonad m => m () - initTemp = do - SQLite.execute_ "create temporary table updating_ids (id integer not null unique);" - SQLite.execute_ "create temporary table updating_messages as select * from messages where 0;" - SQLite.execute_ "create index update_messages_module_id_index on updating_messages (module_id);" - - dropTemp :: SessionMonad m => m () - dropTemp = do - SQLite.execute_ "drop table if exists updating_ids;" - SQLite.execute_ "drop table if exists updating_messages;" - - fillTemp :: SessionMonad m => m () - fillTemp = do - SQLite.executeMany "insert into updating_ids select distinct m.id from modules as m where (m.file = ?);" $ (map SQLite.Only $ mlocs' ^.. each . moduleFile) - SQLite.executeMany "insert into updating_messages select (select m.id from modules as m where (m.file = ?)), ?, ?, ?, ?, ?, ?, ?;" msgs' - SQLite.execute_ "insert into updating_ids select distinct umsgs.module_id from updating_messages as umsgs where umsgs.module_id not in (select id from updating_ids);" - - removeOutdated :: SessionMonad m => m () - removeOutdated = SQLite.execute_ $ fromString $ unlines [ - "delete from messages", - "where", - " module_id in (", - " select um.id", - " from", - " updating_ids as um, modules as m", - " left outer join", - " load_times as lt", - " on", - " lt.module_id = um.id", - " where", - " um.id = m.id and (", - " lt.load_time is null or", - " lt.load_time <= m.inspection_time or", - " um.id in (select distinct umsgs.module_id from updating_messages as umsgs)", - " )", - " );"] - - insertMessages :: SessionMonad m => m () - insertMessages = SQLite.transaction_ SQLite.Deferred $ do - SQLite.execute "insert or replace into load_times (module_id, load_time) select um.id, ? from updating_ids as um;" (SQLite.Only tm') - SQLite.execute_ "insert into messages select distinct * from updating_messages;" - --- | Get cached warnings -cachedWarnings :: SessionMonad m => [ModuleLocation] -> m [Note OutputMessage] -cachedWarnings mlocs = liftM concat $ forM (mlocs ^.. each . moduleFile) $ \f -> SQLite.query @_ @(Note OutputMessage) (SQLite.toQuery $ mconcat [ - SQLite.qNote "m" "n", - SQLite.from_ ["load_times as lt"], - SQLite.where_ [ - "lt.module_id = m.id", - "m.file = ?", - "lt.load_time >= m.inspection_time"]]) - (SQLite.Only f) - -watch :: SessionMonad m => (Watcher -> IO ()) -> m () -watch f = whenJustM (askSession sessionWatcher) $ liftIO . f +{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses, RankNTypes, TypeOperators, TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Database.Update ( + Status(..), Progress(..), Task(..), + UpdateOptions(..), + + UpdateM(..), + runUpdate, + + postStatus, updater, runTask, runTasks, runTasks_, + + scanModules, scanFile, scanFiles, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanPackageDbStack, scanProjectFile, scanProjectStack, scanProject, scanDirectory, + scanPackageDbStackDocs, scanDocs, + setModTypes, inferModTypes, + scan, + processEvents, updateEvents, applyUpdates, + + cacheGhcWarnings, cachedWarnings, + + module HsDev.Database.Update.Types, + + module HsDev.Watcher, + + module Control.Monad.Except + ) where + +import qualified Control.Concurrent.Async as A +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Exception (ErrorCall, evaluate, displayException) +import Control.Lens +import Control.Monad.Catch (catch, handle, MonadThrow, bracket_) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State (get, modify, runStateT) +import Data.Aeson +import Data.List (intercalate) +import Data.String (fromString) +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Maybe +import Data.Text (Text) +import Data.Time.Clock.POSIX +import qualified Data.Text as T +import System.FilePath +import qualified System.Log.Simple as Log + +import Data.Maybe.JustIf +import HsDev.Error +import qualified HsDev.Database.SQLite as SQLite +import HsDev.Display +import HsDev.Inspect +import HsDev.Inspect.Order +import HsDev.PackageDb +import HsDev.Project +import HsDev.Sandbox +import qualified HsDev.Stack as S +import HsDev.Symbols +import HsDev.Tools.Ghc.Session hiding (Session, evaluate) +import HsDev.Tools.Ghc.Types (fileTypes, TypedExpr) +import HsDev.Tools.Types +import HsDev.Tools.HDocs +import qualified HsDev.Scan as S +import HsDev.Scan.Browse +import HsDev.Util (ordNub, fromJSON', uniqueBy, timer) +import qualified HsDev.Util as Util (withCurrentDirectory) +import HsDev.Server.Types (commandNotify, inSessionGhc, FileSource(..)) +import HsDev.Server.Message +import HsDev.Database.Update.Types +import HsDev.Watcher +import Text.Format +import System.Directory.Paths + +onStatus :: UpdateMonad m => m () +onStatus = asks (view (updateOptions . updateTasks)) >>= commandNotify . Notification . toJSON . reverse + +childTask :: UpdateMonad m => Task -> m a -> m a +childTask t = local (over (updateOptions . updateTasks) (t:)) + +transact :: SessionMonad m => m a -> m a +transact = SQLite.transaction_ SQLite.Immediate + +runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a +runUpdate uopts act = Log.scope "update" $ do + (r, updatedMods) <- withUpdateState uopts $ \ust -> + runWriterT (runUpdateM act' `runReaderT` ust) + Log.sendLog Log.Debug $ "updated {} modules" ~~ length updatedMods + return r + where + act' = do + (r, _) <- listen act + -- (r, mlocs') <- listen act + + -- dbs <- liftM S.unions $ forM mlocs' $ \mloc' -> do + -- mid <- SQLite.lookupModuleLocation mloc' + -- case mid of + -- Nothing -> return (S.empty :: S.Set PackageDb) + -- Just mid' -> liftM (S.fromList . map SQLite.fromOnly) $ SQLite.query (SQLite.toQuery $ SQLite.select_ + -- ["ps.package_db"] + -- ["package_dbs as ps", "modules as m"] + -- ["m.package_name == ps.package_name", "m.package_version == ps.package_version", "m.id == ?"]) (SQLite.Only mid') + + -- If some sourced files depends on currently scanned package-dbs + -- We must resolve them and even rescan if there was errors scanning without + -- dependencies provided (lack of fixities can cause errors inspecting files) + + -- sboxes = databaseSandboxes dbval + -- sboxOf :: Path -> Maybe Sandbox + -- sboxOf fpath = find (pathInSandbox fpath) sboxes + -- projsRows <- SQLite.query_ "select name, cabal, version, ifnull(package_db_stack, json('[]')) from projects;" + -- let + -- projs = [proj' | (proj' SQLite.:. (SQLite.Only (SQLite.JSON projPdbs))) <- projsRows, + -- not (S.null (S.fromList projPdbs `S.intersection` dbs))] + + -- stands = [] + -- -- HOWTO? + -- -- stands = do + -- -- sloc <- dbval ^.. standaloneSlice . modules . moduleId . moduleLocation + -- -- guard $ sboxUpdated $ sboxOf (sloc ^?! moduleFile) + -- -- guard (notElem sloc mlocs') + -- -- return (sloc, dbval ^.. databaseModules . ix sloc . inspection . inspectionOpts . each . unpacked, Nothing) + + -- Log.sendLog Log.Trace $ "updated package-dbs: {}, have to rescan {} projects and {} files" + -- ~~ intercalate ", " (map display $ S.toList dbs) + -- ~~ length projs ~~ length stands + -- (_, rlocs') <- listen $ runTasks_ (scanModules [] stands : [scanProject [] (proj ^. projectCabal) | proj <- projs]) + -- let + -- ulocs' = filter (isJust . preview moduleFile) (ordNub $ mlocs' ++ rlocs') + -- getMods :: (MonadIO m) => m [InspectedModule] + -- getMods = do + -- db' <- liftIO $ readAsync db + -- return $ filter ((`elem` ulocs') . view inspectedKey) $ toList $ view databaseModules db' + + -- FIXME: Now it's broken since `Database` is not used anymore + when (view updateDocs uopts) $ do + Log.sendLog Log.Trace "forking inspecting source docs" + Log.sendLog Log.Warning "not implemented" + -- void $ fork (getMods >>= waiter . mapM_ scanDocs_) + when (view updateInfer uopts) $ do + Log.sendLog Log.Trace "forking inferring types" + Log.sendLog Log.Warning "not implemented" + -- void $ fork (getMods >>= waiter . mapM_ inferModTypes_) + return r + -- scanDocs_ :: UpdateMonad m => InspectedModule -> m () + -- scanDocs_ im = do + -- im' <- (S.scanModify (\opts -> inSessionGhc . liftGhc . inspectDocsGhc opts) im) <|> return im + -- sendUpdateAction $ Log.scope "scan-docs" $ SQLite.updateModule im' + -- inferModTypes_ :: UpdateMonad m => InspectedModule -> m () + -- inferModTypes_ im = do + -- -- TODO: locate sandbox + -- im' <- (S.scanModify infer' im) <|> return im + -- sendUpdateAction $ Log.scope "infer-types" $ SQLite.updateModule im' + -- infer' :: UpdateMonad m => [String] -> Module -> m Module + -- infer' opts m = case preview (moduleId . moduleLocation . moduleFile) m of + -- Nothing -> return m + -- Just _ -> inSessionGhc $ do + -- targetSession opts m + -- inferTypes opts m Nothing + +-- | Post status +postStatus :: UpdateMonad m => Task -> m () +postStatus t = childTask t onStatus + +-- | Mark module as updated +updater :: UpdateMonad m => [ModuleLocation] -> m () +updater mlocs = tell $!! mlocs + +-- | Run one task +runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a +runTask action subj act = Log.scope "task" $ do + postStatus $ set taskStatus StatusWorking task + x <- childTask task act + x `deepseq` postStatus (set taskStatus StatusOk task) + return x + `catch` + (\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e) + where + task = Task { + _taskName = action, + _taskStatus = StatusWorking, + _taskSubjectType = displayType subj, + _taskSubjectName = display subj, + _taskProgress = Nothing } + +-- | Run many tasks with numeration +runTasks :: UpdateMonad m => [m a] -> m [a] +runTasks ts = liftM catMaybes $ zipWithM taskNum [1..] (map noErr ts) where + total = length ts + taskNum n = local setProgress where + setProgress = set (updateOptions . updateTasks . _head . taskProgress) (Just (Progress n total)) + noErr v = hsdevIgnore Nothing (Just <$> v) + +-- | Run many tasks with numeration +runTasks_ :: UpdateMonad m => [m ()] -> m () +runTasks_ = void . runTasks + +data PreloadFailure = PreloadFailure ModuleLocation Inspection HsDevError + +instance NFData PreloadFailure where + rnf (PreloadFailure mloc insp err) = rnf mloc `seq` rnf insp `seq` rnf err + +-- | Scan modules +scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m () +scanModules opts ms = Log.scope "scan-modules" $ mapM_ (uncurry scanModules') grouped where + scanModules' mproj ms' = do + maybe (return ()) (sendUpdateAction . SQLite.updateProject) mproj + updater $ ms' ^.. each . _1 + defines <- askSession sessionDefines + + let + pload (mloc, mopts, mcts) = runTask "preloading" mloc $ do + mfcts <- maybe (S.getFileContents (mloc ^?! moduleFile)) (const $ return Nothing) mcts + insp <- liftIO $ fileInspection (mloc ^?! moduleFile) (opts ++ mopts) + case (mfcts ^? _Just . _1) of + Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm + Nothing -> return () + let + inspection' = maybe insp (fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1 + dirtyTag' = maybe id (const $ inspectTag DirtyTag) $ mfcts ^? _Just . _1 + mcts' = mplus mcts (mfcts ^? _Just . _2) + runInspect mloc $ withInspection (return inspection') $ dirtyTag' $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mcts' + + ploaded <- runTasks (map pload ms') + sendUpdateAction $ void $ SQLite.upsertModules $ map (fmap (view asModule)) ploaded + let + mlocs' = ploaded ^.. each . inspected . preloadedId . moduleLocation + + updater mlocs' + + let + mcabal = mproj ^? _Just . projectCabal + + (env, fixities) <- loadEnv mcabal + + Log.sendLog Log.Trace $ "resolved environment: {} modules" ~~ M.size env + case orderBy (preview inspected) ploaded of + Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err) + Right ordered -> do + (ms'', (updEnv, updFixities)) <- flip runStateT (env, fixities) $ runTasks (map inspect' ordered) + saveEnv mcabal updEnv updFixities + mlocs'' <- timer "updated scanned modules" $ do + Log.sendLog Log.Trace $ case mproj of + Just proj -> "inserting data for resolved modules of project: {}" ~~ proj + Nothing -> "inserting data for resolved standalone modules" + sendUpdateAction $ Log.scope "resolved" $ updateResolveds mcabal ms'' + return (ms'' ^.. each . inspectedKey) + updater mlocs'' + where + inspect' pmod = runTask "scanning" ploc $ Log.scope "module" $ do + (env', fixities') <- get + r <- continueInspect pmod $ \p -> do + resolved' <- msum [ + resolveModule env' fixities' p, + do + lift (Log.sendLog Log.Trace ("error resolving module {}, falling to resolving just imports/scope" ~~ (p ^. preloadedId . moduleLocation))) + resolvePreloaded env' p] + eval resolved' + modify $ mappend ( + maybe mempty resolvedEnv (r ^? inspected), + maybe mempty resolvedFixitiesTable (r ^? inspected)) + return r + where + ploc = pmod ^?! inspected . preloadedId . moduleLocation + + grouped = M.toList $ M.unionsWith (++) [M.singleton (m ^? _1 . moduleProject . _Just) [m] | m <- ms] + eval v = handle onError (v `deepseq` liftIO (evaluate v)) where + onError :: MonadThrow m => ErrorCall -> m a + onError = hsdevError . OtherError . displayException + +-- | Scan source file, possibly scanning also related project and installed modules +scanFile :: UpdateMonad m => [String] -> Path -> BuildTool -> Bool -> Bool -> m () +scanFile opts fpath tool scanProj scanDb = do + mproj <- fmap (set (_Just . projectBuildTool) tool) $ locateProjectInfo fpath + sbox <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj + when scanDb $ do + [SQLite.Only scanned] <- SQLite.query @_ @(SQLite.Only Bool) "select count(*) > 0 from package_dbs as pdbs where pdbs.package_db = ?;" (SQLite.Only (topPackageDb sbox)) + unless scanned $ scanPackageDbStack opts sbox + case join (mproj `justIf` scanProj) of + Nothing -> scanFiles [(FileSource fpath Nothing, opts)] + Just proj -> scanProject opts tool (view projectCabal proj) + +-- | Scan source files, resolving dependent modules +scanFiles :: UpdateMonad m => [(FileSource, [String])] -> m () +scanFiles fsrcs = runTask "scanning" ("files" :: String) $ Log.scope "files" $ hsdevLiftIO $ do + Log.sendLog Log.Trace $ "scanning {} files" ~~ length fsrcs + fpaths' <- traverse (liftIO . canonicalize) $ map (fileSource . fst) fsrcs + forM_ fpaths' $ \fpath' -> do + ex <- liftIO $ fileExists fpath' + unless ex $ hsdevError $ FileNotFound fpath' + mlocs <- forM fpaths' $ \fpath' -> do + mids <- SQLite.query (SQLite.toQuery $ SQLite.qModuleId `mappend` SQLite.where_ ["mu.file == ?"]) (SQLite.Only fpath') + if length mids > 1 + then return (head mids ^. moduleLocation) + else do + mproj <- locateProjectInfo fpath' + return $ FileModule fpath' mproj + let + filesMods = liftM concat $ forM fpaths' $ \fpath' -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file == ?;" (SQLite.Only fpath') + scan filesMods [(mloc, opts, mcts) | (mloc, (FileSource _ mcts, opts)) <- zip mlocs fsrcs] [] $ \mlocs' -> do + mapM_ ((watch . flip watchModule) . view _1) mlocs' + S.ScanContents dmods _ _ <- fmap mconcat $ mapM (S.enumDependent . view (_1 . moduleFile . path)) mlocs' + Log.sendLog Log.Trace $ "dependent modules: {}" ~~ length dmods + scanModules [] (mlocs' ++ dmods) + +-- | Scan source file with contents and resolve dependent modules +scanFileContents :: UpdateMonad m => [String] -> Path -> Maybe Text -> m () +scanFileContents opts fpath mcts = scanFiles [(FileSource fpath mcts, opts)] + +-- | Scan cabal modules, doesn't rescan if already scanned +scanCabal :: UpdateMonad m => [String] -> m () +scanCabal opts = Log.scope "cabal" $ scanPackageDbStack opts userDb + +-- | Prepare sandbox for scanning. This is used for stack project to build & configure. +prepareSandbox :: UpdateMonad m => Sandbox -> m () +prepareSandbox sbox@(Sandbox StackTool fpath) = Log.scope "prepare" $ runTasks_ [ + runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.buildDeps Nothing] + where + dir = takeDirectory $ view path fpath +prepareSandbox _ = return () + +-- | Scan sandbox modules, doesn't rescan if already scanned +scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m () +scanSandbox opts sbox = Log.scope "sandbox" $ do + -- prepareSandbox sbox + pdbs <- inSessionGhc $ sandboxPackageDbStack sbox + scanPackageDbStack opts pdbs + +-- | Scan top of package-db stack, usable for rescan +scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m () +scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do + pdbState <- liftIO $ readPackageDb (topPackageDb pdbs) + let + packageDbMods = S.fromList $ concat $ M.elems pdbState + packages' = M.keys pdbState + Log.sendLog Log.Trace $ "package-db state: {} modules" ~~ length packageDbMods + watch (\w -> watchPackageDb w pdbs opts) + + pkgs <- SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only $ topPackageDb pdbs) + if S.fromList packages' == S.fromList pkgs + then Log.sendLog Log.Trace "nothing changes, all packages the same" + else do + mlocs <- liftM + (filter (`S.member` packageDbMods)) $ + (inSessionGhc $ listModules opts pdbs packages') + let + umlocs = uniqueModuleLocations mlocs + Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs + let + packageDbMods' = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only (topPackageDb pdbs)) + scan packageDbMods' ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do + ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1) + Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms + sendUpdateAction $ timer "updated package-db modules" $ do + SQLite.updateModules ms + SQLite.updatePackageDb (topPackageDb pdbs) (M.keys pdbState) + + when hdocsSupported $ scanPackageDbStackDocs opts pdbs + + updater $ ms ^.. each . inspectedKey + +-- | Scan top of package-db stack, usable for rescan +scanPackageDbStack :: UpdateMonad m => [String] -> PackageDbStack -> m () +scanPackageDbStack opts pdbs = runTask "scanning" pdbs $ Log.scope "package-db-stack" $ do + pdbStates <- liftIO $ mapM readPackageDb (packageDbs pdbs) + let + packageDbMods = S.fromList $ concat $ concatMap M.elems pdbStates + packages' = ordNub $ concatMap M.keys pdbStates + Log.sendLog Log.Trace $ "package-db-stack state: {} modules" ~~ length packageDbMods + watch (\w -> watchPackageDbStack w pdbs opts) + + pkgs <- liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only pdb) + if S.fromList packages' == S.fromList pkgs + then Log.sendLog Log.Trace "nothing changes, all packages the same" + else do + mlocs <- liftM + (filter (`S.member` packageDbMods)) $ + (inSessionGhc $ listModules opts pdbs packages') + let + umlocs = uniqueModuleLocations mlocs + Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs + let + packageDbStackMods = liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only pdb) + scan packageDbStackMods ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do + ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1) + Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms + sendUpdateAction $ timer "updated package-db-stack modules" $ do + SQLite.updateModules ms + sequence_ [SQLite.updatePackageDb pdb (M.keys pdbState) | (pdb, pdbState) <- zip (packageDbs pdbs) pdbStates] + + -- BUG: I don't know why, but these steps leads to segfault on my PC: + -- > hsdev scan --cabal --project . + -- > hsdev check -f .\src\HsDev\Client\Commands.hs + -- But it works if docs are scanned, it also works from ghci + + -- needDocs <- asks (view updateDocs) + -- ms' <- if needDocs + -- then do + -- docs <- inSessionGhc $ hdocsCabal pdbs opts + -- return $ map (fmap $ setDocs' docs) ms + -- else return ms + + when hdocsSupported $ scanPackageDbStackDocs opts pdbs + + updater $ ms ^.. each . inspectedKey + +-- | Scan project file +scanProjectFile :: UpdateMonad m => [String] -> BuildTool -> Path -> m Project +scanProjectFile opts tool cabal = runTask "scanning" cabal $ do + proj <- fmap (set projectBuildTool tool) $ S.scanProjectFile opts cabal + pdbs <- inSessionGhc $ getProjectPackageDbStack proj + let + proj' = set projectPackageDbStack (Just pdbs) proj + sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj' + return proj' + +-- | Refine project info and update if necessary +refineProjectInfo :: UpdateMonad m => Project -> m Project +refineProjectInfo proj = do + [SQLite.Only exist] <- SQLite.query "select count(*) > 0 from projects where cabal == ?;" (SQLite.Only (proj ^. projectCabal)) + if exist + then SQLite.loadProject (proj ^. projectCabal) + else runTask "scanning" (proj ^. projectCabal) $ do + proj' <- liftIO $ loadProject proj + pdbs <- inSessionGhc $ getProjectPackageDbStack proj' + let + proj'' = set projectPackageDbStack (Just pdbs) proj' + sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj'' + return proj'' + +-- | Get project info for module +locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project) +locateProjectInfo cabal = liftIO (locateProject (view path cabal)) >>= traverse refineProjectInfo + +-- | Scan project and related package-db stack +scanProjectStack :: UpdateMonad m => [String] -> BuildTool -> Path -> m () +scanProjectStack opts tool cabal = do + sbox <- liftIO $ projectSandbox tool cabal + maybe (scanCabal opts) (scanSandbox opts) sbox + scanProject opts tool cabal + +-- | Scan project +scanProject :: UpdateMonad m => [String] -> BuildTool -> Path -> m () +scanProject opts tool cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do + proj <- scanProjectFile opts tool cabal + watch (\w -> watchProject w proj opts) + S.ScanContents _ [(_, sources)] _ <- S.enumProject proj + let + projMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file is not null and m.cabal == ?;" (SQLite.Only $ proj ^. projectCabal) + scan projMods sources opts $ scanModules opts + + -- Scan docs + -- inSessionGhc $ do + -- currentSession >>= maybe (return ()) (const clearTargets) + + -- forM_ (maybe [] targetInfos (proj ^. projectDescription)) $ \tinfo' -> do + -- opts' <- getProjectTargetOpts [] proj (tinfo' ^. targetBuildInfo) + -- files' <- projectTargetFiles proj tinfo' + -- haddockSession opts' + -- docsMap <- liftGhc $ readProjectTargetDocs opts' proj files' + -- Log.sendLog Log.Debug $ "scanned logs for modules: {}, summary docs: {}" ~~ (intercalate "," (M.keys docsMap)) ~~ (sum $ map M.size $ M.elems docsMap) + + +-- | Scan directory for source files and projects +scanDirectory :: UpdateMonad m => [String] -> Path -> m () +scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do + S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory (view path dir) + runTasks_ [scanProject opts CabalTool (view projectCabal p) | (p, _) <- projSrcs] + runTasks_ $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan + mapMOf_ (each . _1) (watch . flip watchModule) standSrcs + let + standaloneMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.cabal is null and m.file is not null and m.file like ? escape '\\';" (SQLite.Only $ SQLite.escapeLike dir `T.append` "%") + scan standaloneMods standSrcs opts $ scanModules opts + +-- | Scan installed docs +scanPackageDbStackDocs :: UpdateMonad m => [String] -> PackageDbStack -> m () +scanPackageDbStackDocs opts pdbs + | hdocsSupported = Log.scope "docs" $ do + docs <- inSessionGhc $ hdocsCabal pdbs opts + Log.sendLog Log.Trace $ "docs scanned: {} packages, {} modules total" + ~~ length docs ~~ sum (map (M.size . snd) docs) + sendUpdateAction $ transact $ SQLite.executeMany "update symbols set docs = ? where name == ? and module_id in (select id from modules where name == ? and package_name == ? and package_version == ?);" $ do + (ModulePackage pname pver, pdocs) <- docs + (mname, mdocs) <- M.toList pdocs + (nm, doc) <- M.toList mdocs + return (doc, nm, mname, pname, pver) + Log.sendLog Log.Trace "docs set" + | otherwise = Log.sendLog Log.Warning "hdocs not supported" + +-- | Scan docs for inspected modules +scanDocs :: UpdateMonad m => [Module] -> m () +scanDocs + | hdocsSupported = runTasks_ . map scanDocs' + | otherwise = const $ Log.sendLog Log.Warning "hdocs not supported" + where + scanDocs' m = runTask "scanning docs" (view (moduleId . moduleLocation) m) $ Log.scope "docs" $ do + mid <- SQLite.lookupModule (m ^. moduleId) + mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid + m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m + Log.sendLog Log.Trace $ "Scanning docs for {}" ~~ view (moduleId . moduleLocation) m' + docsMap <- inSessionGhc $ do + (pdbs, opts') <- getModuleOpts [] m' + currentSession >>= maybe (return ()) (const clearTargets) + -- Calling haddock with targets set sometimes cause errors + haddockSession pdbs opts' + readModuleDocs opts' m' + sendUpdateAction $ transact $ do + SQLite.executeMany "update symbols set docs = ? where name == ? and module_id == ?;" + [(doc, nm, mid') | (nm, doc) <- maybe [] M.toList docsMap] + SQLite.execute "update modules set tags = json_set(tags, '$.docs', 1) where id == ?;" (SQLite.Only mid') + +-- | Set inferred types for module +setModTypes :: UpdateMonad m => ModuleId -> [Note TypedExpr] -> m () +setModTypes m ts = Log.scope "set-types" $ do + mid <- SQLite.lookupModule m + mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid + sendUpdateAction $ transact $ do + SQLite.execute "delete from types where module_id = ?;" (SQLite.Only mid') + SQLite.executeMany "insert into types (module_id, line, column, line_to, column_to, expr, type) values (?, ?, ?, ?, ?, ?, ?);" [ + (SQLite.Only mid' SQLite.:. view noteRegion n' SQLite.:. view note n') | n' <- uniqueBy (view noteRegion) ts] + SQLite.execute "update names set inferred_type = (select type from types as t where t.module_id = ? and names.line = t.line and names.column = t.column and names.line_to = t.line_to and names.column_to = t.column_to) where module_id == ?;" + (mid', mid') + SQLite.execute "update symbols set type = (select type from types as t where t.module_id = ? and symbols.line = t.line and symbols.column = t.column order by t.line_to, t.column_to) where module_id == ? and type is null;" (mid', mid') + SQLite.execute "update modules set tags = json_set(tags, '$.types', 1) where id == ?;" (SQLite.Only mid') + +-- | Infer types for modules +inferModTypes :: UpdateMonad m => [Module] -> m () +inferModTypes = runTasks_ . map inferModTypes' where + inferModTypes' m = runTask "inferring types" (view (moduleId . moduleLocation) m) $ Log.scope "types" $ do + mid <- SQLite.lookupModule (m ^. moduleId) + _ <- maybe (hsdevError $ SQLiteError "module id not found") return mid + m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m + Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view (moduleId . moduleLocation) m' + + sess <- getSession + mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile) + types' <- inSessionGhc $ do + targetSession [] m' + cacheGhcWarnings sess (m' ^.. moduleId . moduleLocation) $ + fileTypes m' mcts + + setModTypes (m' ^. moduleId) types' + +-- | Generic scan function. Removed obsolete modules and calls callback on changed modules. +scan :: UpdateMonad m + => m [SQLite.Only Int SQLite.:. ModuleLocation SQLite.:. Inspection] + -- ^ Get affected modules, obsolete will be removed, changed will be updated + -> [S.ModuleToScan] + -- ^ Actual modules, other will be removed + -> [String] + -- ^ Extra scan options + -> ([S.ModuleToScan] -> m ()) + -- ^ Update function + -> m () +scan part' mlocs opts act = Log.scope "scan" $ do + mlocs' <- liftM (M.fromList . map (\(SQLite.Only mid SQLite.:. (m SQLite.:. i)) -> (m, (mid, i)))) part' + let + obsolete = M.filterWithKey (\k _ -> k `S.notMember` S.fromList (map (^. _1) mlocs)) mlocs' + changed <- S.changedModules (M.map snd mlocs') opts mlocs + sendUpdateAction $ Log.scope "remove-obsolete" $ transact $ + forM_ (M.elems obsolete) $ SQLite.removeModule . fst + act changed + +processEvents :: ([(Watched, Event)] -> IO ()) -> MVar (A.Async ()) -> MVar [(Watched, Event)] -> [(Watched, Event)] -> ClientM IO () +processEvents handleEvents updaterTask eventsVar evs = Log.scope "event" $ do + Log.sendLog Log.Trace $ "events received: {}" ~~ intercalate ", " (evs ^.. each . _2 . eventPath) + l <- Log.askLog + liftIO $ do + modifyMVar_ eventsVar (return . (++evs)) + modifyMVar_ updaterTask $ \task -> do + done <- fmap isJust $ poll task + if done + then do + Log.withLog l $ Log.sendLog Log.Trace "starting update thread" + A.async $ fix $ \loop -> do + updates <- modifyMVar eventsVar (\es -> return ([], es)) + unless (null updates) $ handleEvents updates >> loop + else return task + +updateEvents :: ServerMonadBase m => [(Watched, Event)] -> UpdateM m () +updateEvents updates = Log.scope "updater" $ do + Log.sendLog Log.Trace $ "prepared to process {} events" ~~ length updates + files <- fmap concat $ forM updates $ \(w, e) -> case w of + WatchedProject proj projOpts + | isSource e -> do + Log.sendLog Log.Info $ "File '{file}' in project {proj} changed" + ~~ ("file" ~% view eventPath e) + ~~ ("proj" ~% view projectName proj) + [SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e) + opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts + return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)] + | isCabal e -> do + Log.sendLog Log.Info $ "Project {proj} changed" + ~~ ("proj" ~% view projectName proj) + scanProject projOpts (view projectBuildTool proj) (view projectCabal proj) + return [] + | otherwise -> return [] + WatchedPackageDb pdbs opts + | isConf e -> do + Log.sendLog Log.Info $ "Package db {package} changed" + ~~ ("package" ~% topPackageDb pdbs) + scanPackageDb opts pdbs + return [] + | otherwise -> return [] + WatchedModule + | isSource e -> do + Log.sendLog Log.Info $ "Module {file} changed" + ~~ ("file" ~% view eventPath e) + [SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e) + opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts + return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)] + | otherwise -> return [] + scanFiles files + where + parseErr' mopts' = do + Log.sendLog Log.Error $ "Error parsing inspection_opts: {}" ~~ show mopts' + hsdevError $ SQLiteError $ "Error parsing inspection_opts: {}" ~~ show mopts' + +applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO () +applyUpdates uopts = runUpdate uopts . updateEvents + +-- Save ghc warnings on loading target, because second loading won't produce any +cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a +cacheGhcWarnings sess mlocs act = Log.scope "cache-warnings" $ do + tm <- liftIO getPOSIXTime + (r, msgs) <- collectMessages act + Log.sendLog Log.Trace $ "collected {} warnings" ~~ length msgs + _ <- liftIO $ withSession sess $ postSessionUpdater $ refreshCache mlocs tm msgs + return r + where + refreshCache :: [ModuleLocation] -> POSIXTime -> [Note OutputMessage] -> ServerM IO () + refreshCache mlocs' tm' msgs' = Log.scope "refresh" $ bracket_ initTemp dropTemp $ do + fillTemp + removeOutdated + insertMessages + where + initTemp :: SessionMonad m => m () + initTemp = do + SQLite.execute_ "create temporary table updating_ids (id integer not null unique);" + SQLite.execute_ "create temporary table updating_messages as select * from messages where 0;" + SQLite.execute_ "create index update_messages_module_id_index on updating_messages (module_id);" + + dropTemp :: SessionMonad m => m () + dropTemp = do + SQLite.execute_ "drop table if exists updating_ids;" + SQLite.execute_ "drop table if exists updating_messages;" + + fillTemp :: SessionMonad m => m () + fillTemp = do + SQLite.executeMany "insert into updating_ids select distinct m.id from modules as m where (m.file = ?);" $ (map SQLite.Only $ mlocs' ^.. each . moduleFile) + SQLite.executeMany "insert into updating_messages select (select m.id from modules as m where (m.file = ?)), ?, ?, ?, ?, ?, ?, ?;" msgs' + SQLite.execute_ "insert into updating_ids select distinct umsgs.module_id from updating_messages as umsgs where umsgs.module_id not in (select id from updating_ids);" + + removeOutdated :: SessionMonad m => m () + removeOutdated = SQLite.execute_ $ fromString $ unlines [ + "delete from messages", + "where", + " module_id in (", + " select um.id", + " from", + " updating_ids as um, modules as m", + " left outer join", + " load_times as lt", + " on", + " lt.module_id = um.id", + " where", + " um.id = m.id and (", + " lt.load_time is null or", + " lt.load_time <= m.inspection_time or", + " um.id in (select distinct umsgs.module_id from updating_messages as umsgs)", + " )", + " );"] + + insertMessages :: SessionMonad m => m () + insertMessages = SQLite.transaction_ SQLite.Deferred $ do + SQLite.execute "insert or replace into load_times (module_id, load_time) select um.id, ? from updating_ids as um;" (SQLite.Only tm') + SQLite.execute_ "insert into messages select distinct * from updating_messages;" + +-- | Get cached warnings +cachedWarnings :: SessionMonad m => [ModuleLocation] -> m [Note OutputMessage] +cachedWarnings mlocs = liftM concat $ forM (mlocs ^.. each . moduleFile) $ \f -> SQLite.query @_ @(Note OutputMessage) (SQLite.toQuery $ mconcat [ + SQLite.qNote "m" "n", + SQLite.from_ ["load_times as lt"], + SQLite.where_ [ + "lt.module_id = m.id", + "m.file = ?", + "lt.load_time >= m.inspection_time"]]) + (SQLite.Only f) + +watch :: SessionMonad m => (Watcher -> IO ()) -> m () +watch f = whenJustM (askSession sessionWatcher) $ liftIO . f diff --git a/src/HsDev/Database/Update/Types.hs b/src/HsDev/Database/Update/Types.hs --- a/src/HsDev/Database/Update/Types.hs +++ b/src/HsDev/Database/Update/Types.hs @@ -1,145 +1,145 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ConstraintKinds, FlexibleContexts, TemplateHaskell #-} - -module HsDev.Database.Update.Types ( - Status(..), Progress(..), Task(..), - UpdateOptions(..), updateTasks, updateGhcOpts, updateDocs, updateInfer, - UpdateState(..), updateOptions, updateWorker, withUpdateState, sendUpdateAction, - UpdateM(..), UpdateMonad, - taskName, taskStatus, taskSubjectType, taskSubjectName, taskProgress, - - module HsDev.Server.Types - ) where - -import Control.Applicative -import Control.Lens (makeLenses) -import Control.Monad.Base -import Control.Monad.Catch -import Control.Monad.Except -import Control.Monad.Fail (MonadFail) -import Control.Monad.Morph -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.Trans.Control -import Data.Aeson -import Data.Functor -import Data.Default -import qualified System.Log.Simple as Log - -import Control.Concurrent.Worker -import HsDev.Server.Types hiding (Command(..)) -import HsDev.Symbols -import HsDev.Types -import HsDev.Util ((.::), logAll) - -data Status = StatusWorking | StatusOk | StatusError HsDevError - -instance ToJSON Status where - toJSON StatusWorking = toJSON ("working" :: String) - toJSON StatusOk = toJSON ("ok" :: String) - toJSON (StatusError e) = toJSON e - -instance FromJSON Status where - parseJSON v = msum $ map ($ v) [ - withText "status" $ \t -> guard (t == "working") $> StatusWorking, - withText "status" $ \t -> guard (t == "ok") $> StatusOk, - liftM StatusError . parseJSON, - fail "invalid status"] - -data Progress = Progress { - progressCurrent :: Int, - progressTotal :: Int } - -instance ToJSON Progress where - toJSON (Progress c t) = object [ - "current" .= c, - "total" .= t] - -instance FromJSON Progress where - parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total") - -data Task = Task { - _taskName :: String, - _taskStatus :: Status, - _taskSubjectType :: String, - _taskSubjectName :: String, - _taskProgress :: Maybe Progress } - -makeLenses ''Task - -instance ToJSON Task where - toJSON t = object [ - "task" .= _taskName t, - "status" .= _taskStatus t, - "type" .= _taskSubjectType t, - "name" .= _taskSubjectName t, - "progress" .= _taskProgress t] - -instance FromJSON Task where - parseJSON = withObject "task" $ \v -> Task <$> - (v .:: "task") <*> - (v .:: "status") <*> - (v .:: "type") <*> - (v .:: "name") <*> - (v .:: "progress") - -data UpdateOptions = UpdateOptions { - _updateTasks :: [Task], - _updateGhcOpts :: [String], - _updateDocs :: Bool, - _updateInfer :: Bool } - -instance Default UpdateOptions where - def = UpdateOptions [] [] False False - -makeLenses ''UpdateOptions - -data UpdateState = UpdateState { - _updateOptions :: UpdateOptions, - _updateWorker :: Worker (ServerM IO) } - -makeLenses ''UpdateState - -withUpdateState :: SessionMonad m => UpdateOptions -> (UpdateState -> m a) -> m a -withUpdateState uopts fn = do - session <- getSession - bracket (liftIO $ startWorker (withSession session . Log.component "sqlite" . Log.scope "update") id logAll) (liftIO . joinWorker) $ \w -> - fn (UpdateState uopts w) - -- where - -- enterTransaction act = do - -- Log.sendLog Log.Trace "entering sqlite transaction" - -- timer "closed transaction" $ transaction_ Immediate $ do - -- Log.sendLog Log.Debug "updating sql database" - -- _ <- act - -- Log.sendLog Log.Debug "sql database updated" - -type UpdateMonad m = (CommandMonad m, MonadReader UpdateState m, MonadWriter [ModuleLocation] m) - -sendUpdateAction :: UpdateMonad m => ServerM IO () -> m () -sendUpdateAction act = do - w <- asks _updateWorker - liftIO $ inWorker w act - -newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m)) a } - deriving (Applicative, Alternative, Monad, MonadFail, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask, Functor, MonadReader UpdateState, MonadWriter [ModuleLocation]) - -instance MonadTrans UpdateM where - lift = UpdateM . lift . lift . lift - -instance (MonadIO m, MonadMask m) => Log.MonadLog (UpdateM m) where - askLog = UpdateM $ lift $ lift Log.askLog - localLog fn = UpdateM . hoist (hoist (Log.localLog fn)) . runUpdateM - -instance ServerMonadBase m => SessionMonad (UpdateM m) where - getSession = UpdateM $ lift $ lift getSession - localSession fn = UpdateM . hoist (hoist (localSession fn)) . runUpdateM - -instance ServerMonadBase m => CommandMonad (UpdateM m) where - getOptions = UpdateM $ lift $ lift getOptions - -instance MonadBase b m => MonadBase b (UpdateM m) where - liftBase = UpdateM . liftBase - -instance MonadBaseControl b m => MonadBaseControl b (UpdateM m) where - type StM (UpdateM m) a = StM (ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m))) a - liftBaseWith f = UpdateM $ liftBaseWith (\f' -> f (f' . runUpdateM)) - restoreM = UpdateM . restoreM +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ConstraintKinds, FlexibleContexts, TemplateHaskell #-} + +module HsDev.Database.Update.Types ( + Status(..), Progress(..), Task(..), + UpdateOptions(..), updateTasks, updateGhcOpts, updateDocs, updateInfer, + UpdateState(..), updateOptions, updateWorker, withUpdateState, sendUpdateAction, + UpdateM(..), UpdateMonad, + taskName, taskStatus, taskSubjectType, taskSubjectName, taskProgress, + + module HsDev.Server.Types + ) where + +import Control.Applicative +import Control.Lens (makeLenses) +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Fail (MonadFail) +import Control.Monad.Morph +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Trans.Control +import Data.Aeson +import Data.Functor +import Data.Default +import qualified System.Log.Simple as Log + +import Control.Concurrent.Worker +import HsDev.Server.Types hiding (Command(..)) +import HsDev.Symbols +import HsDev.Types +import HsDev.Util ((.::), logAll) + +data Status = StatusWorking | StatusOk | StatusError HsDevError + +instance ToJSON Status where + toJSON StatusWorking = toJSON ("working" :: String) + toJSON StatusOk = toJSON ("ok" :: String) + toJSON (StatusError e) = toJSON e + +instance FromJSON Status where + parseJSON v = msum $ map ($ v) [ + withText "status" $ \t -> guard (t == "working") $> StatusWorking, + withText "status" $ \t -> guard (t == "ok") $> StatusOk, + liftM StatusError . parseJSON, + fail "invalid status"] + +data Progress = Progress { + progressCurrent :: Int, + progressTotal :: Int } + +instance ToJSON Progress where + toJSON (Progress c t) = object [ + "current" .= c, + "total" .= t] + +instance FromJSON Progress where + parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total") + +data Task = Task { + _taskName :: String, + _taskStatus :: Status, + _taskSubjectType :: String, + _taskSubjectName :: String, + _taskProgress :: Maybe Progress } + +makeLenses ''Task + +instance ToJSON Task where + toJSON t = object [ + "task" .= _taskName t, + "status" .= _taskStatus t, + "type" .= _taskSubjectType t, + "name" .= _taskSubjectName t, + "progress" .= _taskProgress t] + +instance FromJSON Task where + parseJSON = withObject "task" $ \v -> Task <$> + (v .:: "task") <*> + (v .:: "status") <*> + (v .:: "type") <*> + (v .:: "name") <*> + (v .:: "progress") + +data UpdateOptions = UpdateOptions { + _updateTasks :: [Task], + _updateGhcOpts :: [String], + _updateDocs :: Bool, + _updateInfer :: Bool } + +instance Default UpdateOptions where + def = UpdateOptions [] [] False False + +makeLenses ''UpdateOptions + +data UpdateState = UpdateState { + _updateOptions :: UpdateOptions, + _updateWorker :: Worker (ServerM IO) } + +makeLenses ''UpdateState + +withUpdateState :: SessionMonad m => UpdateOptions -> (UpdateState -> m a) -> m a +withUpdateState uopts fn = do + session <- getSession + bracket (liftIO $ startWorker (withSession session . Log.component "sqlite" . Log.scope "update") id logAll) (liftIO . joinWorker) $ \w -> + fn (UpdateState uopts w) + -- where + -- enterTransaction act = do + -- Log.sendLog Log.Trace "entering sqlite transaction" + -- timer "closed transaction" $ transaction_ Immediate $ do + -- Log.sendLog Log.Debug "updating sql database" + -- _ <- act + -- Log.sendLog Log.Debug "sql database updated" + +type UpdateMonad m = (CommandMonad m, MonadReader UpdateState m, MonadWriter [ModuleLocation] m) + +sendUpdateAction :: UpdateMonad m => ServerM IO () -> m () +sendUpdateAction act = do + w <- asks _updateWorker + liftIO $ inWorker w act + +newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m)) a } + deriving (Applicative, Alternative, Monad, MonadFail, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask, Functor, MonadReader UpdateState, MonadWriter [ModuleLocation]) + +instance MonadTrans UpdateM where + lift = UpdateM . lift . lift . lift + +instance (MonadIO m, MonadMask m) => Log.MonadLog (UpdateM m) where + askLog = UpdateM $ lift $ lift Log.askLog + localLog fn = UpdateM . hoist (hoist (Log.localLog fn)) . runUpdateM + +instance ServerMonadBase m => SessionMonad (UpdateM m) where + getSession = UpdateM $ lift $ lift getSession + localSession fn = UpdateM . hoist (hoist (localSession fn)) . runUpdateM + +instance ServerMonadBase m => CommandMonad (UpdateM m) where + getOptions = UpdateM $ lift $ lift getOptions + +instance MonadBase b m => MonadBase b (UpdateM m) where + liftBase = UpdateM . liftBase + +instance MonadBaseControl b m => MonadBaseControl b (UpdateM m) where + type StM (UpdateM m) a = StM (ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m))) a + liftBaseWith f = UpdateM $ liftBaseWith (\f' -> f (f' . runUpdateM)) + restoreM = UpdateM . restoreM diff --git a/src/HsDev/Display.hs b/src/HsDev/Display.hs --- a/src/HsDev/Display.hs +++ b/src/HsDev/Display.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Display ( - Display(..) - ) where - -import Control.Lens (view) - -import System.Directory.Paths - -class Display a where - display :: a -> String - displayType :: a -> String - -instance Display FilePath where - display = id - displayType _ = "path" - -instance Display Path where - display = view path - displayType _ = "path" +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Display ( + Display(..) + ) where + +import Control.Lens (view) + +import System.Directory.Paths + +class Display a where + display :: a -> String + displayType :: a -> String + +instance Display FilePath where + display = id + displayType _ = "path" + +instance Display Path where + display = view path + displayType _ = "path" diff --git a/src/HsDev/Error.hs b/src/HsDev/Error.hs --- a/src/HsDev/Error.hs +++ b/src/HsDev/Error.hs @@ -1,53 +1,53 @@ -{-# LANGUAGE FlexibleContexts #-} - -module HsDev.Error ( - hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore, - hsdevHandle, - - module HsDev.Types - ) where - -import Prelude - -import Control.Exception (IOException) -import Control.Monad.Catch -import Control.Monad.Except - -import HsDev.Types - --- | Throw `HsDevError` -hsdevError :: MonadThrow m => HsDevError -> m a -hsdevError = throwM - --- | Throw as `OtherError` -hsdevOtherError :: (Exception e, MonadThrow m) => e -> m a -hsdevOtherError = hsdevError . OtherError . displayException - --- | Throw as `OtherError` -hsdevLift :: MonadThrow m => ExceptT String m a -> m a -hsdevLift = hsdevLiftWith OtherError - --- | Throw as some `HsDevError` -hsdevLiftWith :: MonadThrow m => (String -> HsDevError) -> ExceptT String m a -> m a -hsdevLiftWith ctor act = runExceptT act >>= either (hsdevError . ctor) return - -hsdevCatch :: MonadCatch m => m a -> m (Either HsDevError a) -hsdevCatch = try - --- | Rethrow IO exceptions as `HsDevError` -hsdevLiftIO :: MonadCatch m => m a -> m a -hsdevLiftIO = hsdevLiftIOWith IOFailed - --- | Rethrow IO exceptions -hsdevLiftIOWith :: MonadCatch m => (String -> HsDevError) -> m a -> m a -hsdevLiftIOWith ctor act = catch act onErr where - onErr :: MonadThrow m => IOException -> m a - onErr = hsdevError . ctor . displayException - --- | Ignore hsdev exception -hsdevIgnore :: MonadCatch m => a -> m a -> m a -hsdevIgnore v act = hsdevCatch act >>= either (const $ return v) return - --- | Handle hsdev exception -hsdevHandle :: MonadCatch m => (HsDevError -> m a) -> m a -> m a -hsdevHandle h act = hsdevCatch act >>= either h return +{-# LANGUAGE FlexibleContexts #-} + +module HsDev.Error ( + hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore, + hsdevHandle, + + module HsDev.Types + ) where + +import Prelude + +import Control.Exception (IOException) +import Control.Monad.Catch +import Control.Monad.Except + +import HsDev.Types + +-- | Throw `HsDevError` +hsdevError :: MonadThrow m => HsDevError -> m a +hsdevError = throwM + +-- | Throw as `OtherError` +hsdevOtherError :: (Exception e, MonadThrow m) => e -> m a +hsdevOtherError = hsdevError . OtherError . displayException + +-- | Throw as `OtherError` +hsdevLift :: MonadThrow m => ExceptT String m a -> m a +hsdevLift = hsdevLiftWith OtherError + +-- | Throw as some `HsDevError` +hsdevLiftWith :: MonadThrow m => (String -> HsDevError) -> ExceptT String m a -> m a +hsdevLiftWith ctor act = runExceptT act >>= either (hsdevError . ctor) return + +hsdevCatch :: MonadCatch m => m a -> m (Either HsDevError a) +hsdevCatch = try + +-- | Rethrow IO exceptions as `HsDevError` +hsdevLiftIO :: MonadCatch m => m a -> m a +hsdevLiftIO = hsdevLiftIOWith IOFailed + +-- | Rethrow IO exceptions +hsdevLiftIOWith :: MonadCatch m => (String -> HsDevError) -> m a -> m a +hsdevLiftIOWith ctor act = catch act onErr where + onErr :: MonadThrow m => IOException -> m a + onErr = hsdevError . ctor . displayException + +-- | Ignore hsdev exception +hsdevIgnore :: MonadCatch m => a -> m a -> m a +hsdevIgnore v act = hsdevCatch act >>= either (const $ return v) return + +-- | Handle hsdev exception +hsdevHandle :: MonadCatch m => (HsDevError -> m a) -> m a -> m a +hsdevHandle h act = hsdevCatch act >>= either h return diff --git a/src/HsDev/Inspect.hs b/src/HsDev/Inspect.hs --- a/src/HsDev/Inspect.hs +++ b/src/HsDev/Inspect.hs @@ -1,320 +1,320 @@ -{-# LANGUAGE CPP, TypeSynonymInstances, ImplicitParams, TemplateHaskell #-} - -module HsDev.Inspect ( - preload, - AnalyzeEnv(..), analyzeEnv, analyzeFixities, analyzeRefine, moduleAnalyzeEnv, - analyzeResolve, analyzePreloaded, - inspectDocs, inspectDocsGhc, - inspectContents, contentsInspection, - inspectFile, sourceInspection, fileInspection, fileContentsInspection, fileContentsInspection_, installedInspection, moduleInspection, - projectDirs, projectSources, - getDefines, - preprocess, preprocess_, - - module HsDev.Inspect.Types, - module HsDev.Inspect.Resolve, - module Control.Monad.Except - ) where - -import Control.DeepSeq -import qualified Control.Exception as E -import Control.Lens -import Control.Monad -import Control.Monad.Catch -import Control.Monad.Reader -import Control.Monad.Except -import Data.List -import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Semigroup -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime, POSIXTime) -import qualified Data.Map.Strict as M -import qualified Language.Haskell.Exts as H -import Language.Haskell.Exts.Fixity -import qualified Language.Haskell.Names as N -import qualified Language.Haskell.Names.Annotated as N -import qualified Language.Haskell.Names.SyntaxUtils as N -import qualified Language.Haskell.Names.Exports as N -import qualified Language.Haskell.Names.Imports as N -import qualified Language.Haskell.Names.ModuleSymbols as N -import qualified Language.Haskell.Names.Open as N -import qualified Language.Preprocessor.Cpphs as Cpphs -import qualified System.Directory as Dir -import System.FilePath -import Text.Format - -import HsDev.Display () -import HsDev.Error -import HsDev.Inspect.Definitions -import HsDev.Inspect.Types -import HsDev.Inspect.Resolve -import HsDev.Sandbox (searchPackageDbStack) -import HsDev.Symbols -import HsDev.Symbols.Resolve (refineSymbol, refineTable, RefineTable) -import qualified HsDev.Symbols.HaskellNames as HN -import HsDev.Tools.Base -import HsDev.Tools.Ghc.Worker (GhcM) -import HsDev.Tools.HDocs (hdocs, hdocsProcess, readModuleDocs) -import HsDev.Util -import System.Directory.Paths - --- | Preload module - load head and imports to get actual extensions and dependencies -preload :: (MonadIO m, MonadCatch m) => Text -> [(String, String)] -> [String] -> Maybe Text -> InspectM ModuleLocation ModuleTag m Preloaded -preload name defines opts mcts = inspectTag OnlyHeaderTag $ case mcts of - Nothing -> do - mloc <- ask - case mloc of - FileModule fpath mproj -> do - inspect_ (liftIO $ fileInspection fpath opts) $ do - cts <- liftIO $ readFileUtf8 (view path fpath) - let - srcExts = fromMaybe (takeDir fpath `withExtensions` mempty) $ do - proj <- mproj - findSourceDir proj fpath - liftIO $ preload' name defines (opts ++ extensionsOpts srcExts) mloc cts - _ -> throwError $ InspectError $ format "preload called on non-sourced module: {}" ~~ mloc - Just cts -> inspect (liftIO $ fileContentsInspection opts) $ \mloc -> - liftIO $ preload' name defines opts mloc cts - where - preload' name' defines' opts' mloc' cts' = do - cts'' <- preprocess_ defines' exts fpath $ T.map untab cts' - pragmas <- parseOk $ H.getTopPragmas (T.unpack cts'') - let - fileExts = [H.parseExtension (T.unpack $ fromName_ $ void lang) | H.LanguagePragma _ langs <- pragmas, lang <- langs] - pmode = H.ParseMode { - H.parseFilename = view path fpath, - H.baseLanguage = H.Haskell2010, - H.extensions = ordNub (map H.parseExtension exts ++ fileExts), - H.ignoreLanguagePragmas = False, - H.ignoreLinePragmas = True, - H.fixities = Nothing, - H.ignoreFunctionArity = False } - H.ModuleHeadAndImports l mpragmas mhead mimps <- parseOk $ fmap H.unNonGreedy $ H.parseWithMode pmode (T.unpack cts'') - let - mname = case mhead of - Just (H.ModuleHead _ (H.ModuleName _ nm) _ _) -> nm - _ -> "Main" - return $ Preloaded { - _preloadedId = ModuleId (fromString mname) mloc', - _preloadedMode = pmode, - _preloadedModule = H.Module l mhead mpragmas mimps [], - _preloaded = cts'' } - where - fpath = fromMaybe name' (mloc' ^? moduleFile) - parseOk :: H.ParseResult a -> IO a - parseOk (H.ParseOk v) = return v - parseOk (H.ParseFailed loc err) = hsdevError $ InspectError $ - format "Parse {} failed at {} with: {}" ~~ fpath ~~ show loc ~~ err - untab '\t' = ' ' - untab ch = ch - exts = mapMaybe flagExtension opts' - -data AnalyzeEnv = AnalyzeEnv { - _analyzeEnv :: N.Environment, - _analyzeFixities :: M.Map Name H.Fixity, - _analyzeRefine :: RefineTable } - -instance Semigroup AnalyzeEnv where - AnalyzeEnv lenv lf lt <> AnalyzeEnv renv rf rt = AnalyzeEnv - (lenv <> renv) - (lf <> rf) - (lt <> rt) - -instance Monoid AnalyzeEnv where - mempty = AnalyzeEnv mempty mempty mempty - mappend l r = l <> r - -moduleAnalyzeEnv :: Module -> AnalyzeEnv -moduleAnalyzeEnv m = AnalyzeEnv - (environment m) - (m ^. fixitiesMap) - (refineTable (m ^.. exportedSymbols)) - --- | Resolve module imports/exports/scope -analyzeResolve :: AnalyzeEnv -> Module -> Module -analyzeResolve (AnalyzeEnv env _ rtable) m = case m ^. moduleSource of - Nothing -> m - Just msrc -> over moduleSymbols (refineSymbol stbl) $ m { - _moduleImports = map (toImport . dropScope) idecls', - _moduleExports = map HN.fromSymbol $ N.exportedSymbols tbl msrc, - _moduleFixities = [Fixity (void assoc) (fromMaybe 0 pr) (fixName opName) - | H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops], - _moduleScope = M.map (map HN.fromSymbol) tbl, - _moduleSource = Just annotated } - where - getOpName (H.VarOp _ nm) = nm - getOpName (H.ConOp _ nm) = nm - fixName o = H.Qual () (H.ModuleName () (T.unpack $ m ^. moduleId . moduleName)) (void o) - itbl = N.importTable env msrc - tbl = N.moduleTable itbl msrc - syms = set (each . symbolId . symbolModule) (m ^. moduleId) $ - getSymbols decls' - stbl = refineTable syms `mappend` rtable - -- Not using 'annotate' because we already computed needed tables - annotated = H.Module l mhead' mpragmas idecls' decls' - H.Module l mhead mpragmas idecls decls = fmap (\(N.Scoped _ v) -> N.Scoped N.None v) msrc - mhead' = fmap scopeHead mhead - scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead lh mname mwarns $ - fmap (N.annotateExportSpecList tbl . dropScope) mexports - idecls' = N.annotateImportDecls mn env (fmap dropScope idecls) - decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl) . dropScope) decls - mn = dropScope $ N.getModuleName msrc - --- | Inspect preloaded module -analyzePreloaded :: AnalyzeEnv -> Preloaded -> Either String Module -analyzePreloaded aenv@(AnalyzeEnv env gfixities _) p = case H.parseFileContentsWithMode (_preloadedMode p') (T.unpack $ _preloaded p') of - H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason - H.ParseOk m -> Right $ analyzeResolve aenv $ Module { - _moduleId = _preloadedId p', - _moduleDocs = Nothing, - _moduleImports = mempty, - _moduleExports = mempty, - _moduleFixities = mempty, - _moduleScope = mempty, - _moduleSource = Just $ fmap (N.Scoped N.None) m } - where - qimps = M.keys $ N.importTable env (_preloadedModule p) - p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` gfixities) qimps) } } - --- | Adds documentation to declaration -addDoc :: Map String String -> Symbol -> Symbol -addDoc docsMap sym' = set symbolDocs (preview (ix (view (symbolId . symbolName) sym')) docsMap') sym' where - docsMap' = M.mapKeys fromString . M.map fromString $ docsMap - --- | Adds documentation to all declarations in module -addDocs :: Map String String -> Module -> Module -addDocs docsMap = over moduleSymbols (addDoc docsMap) - --- | Extract file docs and set them to module declarations -inspectDocs :: [String] -> Module -> GhcM Module -inspectDocs opts m = do - let - hdocsWorkaround = False - pdbs <- case view (moduleId . moduleLocation) m of - FileModule fpath mproj -> searchPackageDbStack (maybe CabalTool (view projectBuildTool) mproj) fpath - InstalledModule{} -> return userDb - _ -> return userDb - docsMap <- if hdocsWorkaround - then liftIO $ hdocsProcess (fromMaybe (T.unpack $ view (moduleId . moduleName) m) (preview (moduleId . moduleLocation . moduleFile . path) m)) opts - else liftM Just $ hdocs pdbs (view (moduleId . moduleLocation) m) opts - return $ maybe id addDocs docsMap m - --- | Like @inspectDocs@, but in @Ghc@ monad -inspectDocsGhc :: [String] -> Module -> GhcM Module -inspectDocsGhc opts m = do - docsMap <- readModuleDocs opts m - return $ maybe id addDocs docsMap m - --- | Inspect contents -inspectContents :: Text -> [(String, String)] -> [String] -> Text -> IO InspectedModule -inspectContents name defines opts cts = runInspect (OtherLocation name) $ withInspection (contentsInspection cts opts) $ do - p <- preload name defines opts (Just cts) - analyzed <- lift $ either (hsdevError . InspectError) return $ analyzePreloaded mempty p - inspectUntag OnlyHeaderTag $ - return $ set (moduleId . moduleLocation) (OtherLocation name) analyzed - -contentsInspection :: Text -> [String] -> IO Inspection -contentsInspection _ _ = return InspectionNone -- crc or smth - --- | Inspect file -inspectFile :: [(String, String)] -> [String] -> Path -> Maybe Project -> Maybe Text -> IO InspectedModule -inspectFile defines opts file mproj mcts = hsdevLiftIO $ do - absFilename <- canonicalize file - ex <- fileExists absFilename - unless ex $ hsdevError $ FileNotFound absFilename - runInspect (FileModule absFilename mproj) $ withInspection (sourceInspection absFilename mcts opts) $ do - p <- preload absFilename defines opts mcts - forced <- liftIO (E.handle onErr (return $!! analyzePreloaded mempty p)) >>= either (hsdevError . InspectError) return - return $ set (moduleId . moduleLocation) (FileModule absFilename mproj) forced - where - onErr :: E.ErrorCall -> IO (Either String Module) - onErr = return . Left . show - --- | Source inspection data, differs whether there are contents provided -sourceInspection :: Path -> Maybe Text -> [String] -> IO Inspection -sourceInspection f Nothing = fileInspection f -sourceInspection _ (Just _) = fileContentsInspection - --- | File inspection data -fileInspection :: Path -> [String] -> IO Inspection -fileInspection f opts = do - tm <- Dir.getModificationTime (view path f) - return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ map fromString $ sort $ ordNub opts - --- | File contents inspection data -fileContentsInspection :: [String] -> IO Inspection -fileContentsInspection opts = fileContentsInspection_ opts <$> getPOSIXTime - --- | File contents inspection data -fileContentsInspection_ :: [String] -> POSIXTime -> Inspection -fileContentsInspection_ opts tm = InspectionAt tm $ map fromString $ sort $ ordNub opts - --- | Installed module inspection data, just opts -installedInspection :: [String] -> IO Inspection -installedInspection opts = return $ InspectionAt 0 $ map fromString $ sort $ ordNub opts - --- | Inspection by module location -moduleInspection :: ModuleLocation -> [String] -> IO Inspection -moduleInspection (FileModule fpath _) = fileInspection fpath -moduleInspection _ = installedInspection - --- | Enumerate project dirs -projectDirs :: Project -> IO [Extensions Path] -projectDirs p = do - p' <- loadProject p - return $ ordNub $ map (fmap (normPath . (view projectPath p' `subPath`))) $ maybe [] sourceDirs $ view projectDescription p' - --- | Enumerate project source files -projectSources :: Project -> IO [Extensions Path] -projectSources p = do - dirs <- projectDirs p - let - enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory - dirs' = map (view (entity . path)) dirs - -- enum inner projects and dont consider them as part of this project - subProjs <- liftM (map fromFilePath . delete (view (projectPath . path) p) . ordNub . concat) $ triesMap (enumCabals) dirs' - let - enumHs = liftM (filter thisProjectSource) . traverseDirectory - thisProjectSource h = haskellSource h && not (any (`isParent` fromFilePath h) subProjs) - liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (liftM (map fromFilePath) . enumHs . view path)) dirs - --- | Get actual defines -getDefines :: IO [(String, String)] -getDefines = E.handle onIO $ do - tmp <- Dir.getTemporaryDirectory - writeFile (tmp "defines.hs") "" - _ <- runWait "ghc" ["-E", "-optP-dM", "-cpp", tmp "defines.hs"] "" - cts <- readFileUtf8 (tmp "defines.hspp") - Dir.removeFile (tmp "defines.hs") - Dir.removeFile (tmp "defines.hspp") - return $ mapMaybe (\g -> (,) <$> g 1 <*> g 2) $ mapMaybe (matchRx rx . T.unpack) $ T.lines cts - where - rx = "#define ([^\\s]+) (.*)" - onIO :: E.IOException -> IO [(String, String)] - onIO _ = return [] - -preprocess :: [(String, String)] -> Path -> Text -> IO Text -preprocess defines fpath cts = do - cts' <- E.catch (Cpphs.cppIfdef (view path fpath) defines [] cppOpts (T.unpack cts)) onIOError - return $ T.unlines $ map (fromString . snd) cts' - where - onIOError :: E.IOException -> IO [(Cpphs.Posn, String)] - onIOError _ = return [] - - cppOpts = Cpphs.defaultBoolOptions { - Cpphs.locations = False, - Cpphs.hashline = False - } - -preprocess_ :: [(String, String)] -> [String] -> Path -> Text -> IO Text -preprocess_ defines exts fpath cts - | hasCPP = preprocess defines fpath cts - | otherwise = return cts - where - exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions $ T.unpack cts) - hasCPP = H.EnableExtension H.CPP `elem` exts' - -makeLenses ''AnalyzeEnv +{-# LANGUAGE CPP, TypeSynonymInstances, ImplicitParams, TemplateHaskell #-} + +module HsDev.Inspect ( + preload, + AnalyzeEnv(..), analyzeEnv, analyzeFixities, analyzeRefine, moduleAnalyzeEnv, + analyzeResolve, analyzePreloaded, + inspectDocs, inspectDocsGhc, + inspectContents, contentsInspection, + inspectFile, sourceInspection, fileInspection, fileContentsInspection, fileContentsInspection_, installedInspection, moduleInspection, + projectDirs, projectSources, + getDefines, + preprocess, preprocess_, + + module HsDev.Inspect.Types, + module HsDev.Inspect.Resolve, + module Control.Monad.Except + ) where + +import Control.DeepSeq +import qualified Control.Exception as E +import Control.Lens +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Reader +import Control.Monad.Except +import Data.List +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Semigroup +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime, POSIXTime) +import qualified Data.Map.Strict as M +import qualified Language.Haskell.Exts as H +import Language.Haskell.Exts.Fixity +import qualified Language.Haskell.Names as N +import qualified Language.Haskell.Names.Annotated as N +import qualified Language.Haskell.Names.SyntaxUtils as N +import qualified Language.Haskell.Names.Exports as N +import qualified Language.Haskell.Names.Imports as N +import qualified Language.Haskell.Names.ModuleSymbols as N +import qualified Language.Haskell.Names.Open as N +import qualified Language.Preprocessor.Cpphs as Cpphs +import qualified System.Directory as Dir +import System.FilePath +import Text.Format + +import HsDev.Display () +import HsDev.Error +import HsDev.Inspect.Definitions +import HsDev.Inspect.Types +import HsDev.Inspect.Resolve +import HsDev.Sandbox (searchPackageDbStack) +import HsDev.Symbols +import HsDev.Symbols.Resolve (refineSymbol, refineTable, RefineTable) +import qualified HsDev.Symbols.HaskellNames as HN +import HsDev.Tools.Base +import HsDev.Tools.Ghc.Worker (GhcM) +import HsDev.Tools.HDocs (hdocs, hdocsProcess, readModuleDocs) +import HsDev.Util +import System.Directory.Paths + +-- | Preload module - load head and imports to get actual extensions and dependencies +preload :: (MonadIO m, MonadCatch m) => Text -> [(String, String)] -> [String] -> Maybe Text -> InspectM ModuleLocation ModuleTag m Preloaded +preload name defines opts mcts = inspectTag OnlyHeaderTag $ case mcts of + Nothing -> do + mloc <- ask + case mloc of + FileModule fpath mproj -> do + inspect_ (liftIO $ fileInspection fpath opts) $ do + cts <- liftIO $ readFileUtf8 (view path fpath) + let + srcExts = fromMaybe (takeDir fpath `withExtensions` mempty) $ do + proj <- mproj + findSourceDir proj fpath + liftIO $ preload' name defines (opts ++ extensionsOpts srcExts) mloc cts + _ -> throwError $ InspectError $ format "preload called on non-sourced module: {}" ~~ mloc + Just cts -> inspect (liftIO $ fileContentsInspection opts) $ \mloc -> + liftIO $ preload' name defines opts mloc cts + where + preload' name' defines' opts' mloc' cts' = do + cts'' <- preprocess_ defines' exts fpath $ T.map untab cts' + pragmas <- parseOk $ H.getTopPragmas (T.unpack cts'') + let + fileExts = [H.parseExtension (T.unpack $ fromName_ $ void lang) | H.LanguagePragma _ langs <- pragmas, lang <- langs] + pmode = H.ParseMode { + H.parseFilename = view path fpath, + H.baseLanguage = H.Haskell2010, + H.extensions = ordNub (map H.parseExtension exts ++ fileExts), + H.ignoreLanguagePragmas = False, + H.ignoreLinePragmas = True, + H.fixities = Nothing, + H.ignoreFunctionArity = False } + H.ModuleHeadAndImports l mpragmas mhead mimps <- parseOk $ fmap H.unNonGreedy $ H.parseWithMode pmode (T.unpack cts'') + let + mname = case mhead of + Just (H.ModuleHead _ (H.ModuleName _ nm) _ _) -> nm + _ -> "Main" + return $ Preloaded { + _preloadedId = ModuleId (fromString mname) mloc', + _preloadedMode = pmode, + _preloadedModule = H.Module l mhead mpragmas mimps [], + _preloaded = cts'' } + where + fpath = fromMaybe name' (mloc' ^? moduleFile) + parseOk :: H.ParseResult a -> IO a + parseOk (H.ParseOk v) = return v + parseOk (H.ParseFailed loc err) = hsdevError $ InspectError $ + format "Parse {} failed at {} with: {}" ~~ fpath ~~ show loc ~~ err + untab '\t' = ' ' + untab ch = ch + exts = mapMaybe flagExtension opts' + +data AnalyzeEnv = AnalyzeEnv { + _analyzeEnv :: N.Environment, + _analyzeFixities :: M.Map Name H.Fixity, + _analyzeRefine :: RefineTable } + +instance Semigroup AnalyzeEnv where + AnalyzeEnv lenv lf lt <> AnalyzeEnv renv rf rt = AnalyzeEnv + (lenv <> renv) + (lf <> rf) + (lt <> rt) + +instance Monoid AnalyzeEnv where + mempty = AnalyzeEnv mempty mempty mempty + mappend l r = l <> r + +moduleAnalyzeEnv :: Module -> AnalyzeEnv +moduleAnalyzeEnv m = AnalyzeEnv + (environment m) + (m ^. fixitiesMap) + (refineTable (m ^.. exportedSymbols)) + +-- | Resolve module imports/exports/scope +analyzeResolve :: AnalyzeEnv -> Module -> Module +analyzeResolve (AnalyzeEnv env _ rtable) m = case m ^. moduleSource of + Nothing -> m + Just msrc -> over moduleSymbols (refineSymbol stbl) $ m { + _moduleImports = map (toImport . dropScope) idecls', + _moduleExports = map HN.fromSymbol $ N.exportedSymbols tbl msrc, + _moduleFixities = [Fixity (void assoc) (fromMaybe 0 pr) (fixName opName) + | H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops], + _moduleScope = M.map (map HN.fromSymbol) tbl, + _moduleSource = Just annotated } + where + getOpName (H.VarOp _ nm) = nm + getOpName (H.ConOp _ nm) = nm + fixName o = H.Qual () (H.ModuleName () (T.unpack $ m ^. moduleId . moduleName)) (void o) + itbl = N.importTable env msrc + tbl = N.moduleTable itbl msrc + syms = set (each . symbolId . symbolModule) (m ^. moduleId) $ + getSymbols decls' + stbl = refineTable syms `mappend` rtable + -- Not using 'annotate' because we already computed needed tables + annotated = H.Module l mhead' mpragmas idecls' decls' + H.Module l mhead mpragmas idecls decls = fmap (\(N.Scoped _ v) -> N.Scoped N.None v) msrc + mhead' = fmap scopeHead mhead + scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead lh mname mwarns $ + fmap (N.annotateExportSpecList tbl . dropScope) mexports + idecls' = N.annotateImportDecls mn env (fmap dropScope idecls) + decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl) . dropScope) decls + mn = dropScope $ N.getModuleName msrc + +-- | Inspect preloaded module +analyzePreloaded :: AnalyzeEnv -> Preloaded -> Either String Module +analyzePreloaded aenv@(AnalyzeEnv env gfixities _) p = case H.parseFileContentsWithMode (_preloadedMode p') (T.unpack $ _preloaded p') of + H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason + H.ParseOk m -> Right $ analyzeResolve aenv $ Module { + _moduleId = _preloadedId p', + _moduleDocs = Nothing, + _moduleImports = mempty, + _moduleExports = mempty, + _moduleFixities = mempty, + _moduleScope = mempty, + _moduleSource = Just $ fmap (N.Scoped N.None) m } + where + qimps = M.keys $ N.importTable env (_preloadedModule p) + p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` gfixities) qimps) } } + +-- | Adds documentation to declaration +addDoc :: Map String String -> Symbol -> Symbol +addDoc docsMap sym' = set symbolDocs (preview (ix (view (symbolId . symbolName) sym')) docsMap') sym' where + docsMap' = M.mapKeys fromString . M.map fromString $ docsMap + +-- | Adds documentation to all declarations in module +addDocs :: Map String String -> Module -> Module +addDocs docsMap = over moduleSymbols (addDoc docsMap) + +-- | Extract file docs and set them to module declarations +inspectDocs :: [String] -> Module -> GhcM Module +inspectDocs opts m = do + let + hdocsWorkaround = False + pdbs <- case view (moduleId . moduleLocation) m of + FileModule fpath mproj -> searchPackageDbStack (maybe CabalTool (view projectBuildTool) mproj) fpath + InstalledModule{} -> return userDb + _ -> return userDb + docsMap <- if hdocsWorkaround + then liftIO $ hdocsProcess (fromMaybe (T.unpack $ view (moduleId . moduleName) m) (preview (moduleId . moduleLocation . moduleFile . path) m)) opts + else liftM Just $ hdocs pdbs (view (moduleId . moduleLocation) m) opts + return $ maybe id addDocs docsMap m + +-- | Like @inspectDocs@, but in @Ghc@ monad +inspectDocsGhc :: [String] -> Module -> GhcM Module +inspectDocsGhc opts m = do + docsMap <- readModuleDocs opts m + return $ maybe id addDocs docsMap m + +-- | Inspect contents +inspectContents :: Text -> [(String, String)] -> [String] -> Text -> IO InspectedModule +inspectContents name defines opts cts = runInspect (OtherLocation name) $ withInspection (contentsInspection cts opts) $ do + p <- preload name defines opts (Just cts) + analyzed <- lift $ either (hsdevError . InspectError) return $ analyzePreloaded mempty p + inspectUntag OnlyHeaderTag $ + return $ set (moduleId . moduleLocation) (OtherLocation name) analyzed + +contentsInspection :: Text -> [String] -> IO Inspection +contentsInspection _ _ = return InspectionNone -- crc or smth + +-- | Inspect file +inspectFile :: [(String, String)] -> [String] -> Path -> Maybe Project -> Maybe Text -> IO InspectedModule +inspectFile defines opts file mproj mcts = hsdevLiftIO $ do + absFilename <- canonicalize file + ex <- fileExists absFilename + unless ex $ hsdevError $ FileNotFound absFilename + runInspect (FileModule absFilename mproj) $ withInspection (sourceInspection absFilename mcts opts) $ do + p <- preload absFilename defines opts mcts + forced <- liftIO (E.handle onErr (return $!! analyzePreloaded mempty p)) >>= either (hsdevError . InspectError) return + return $ set (moduleId . moduleLocation) (FileModule absFilename mproj) forced + where + onErr :: E.ErrorCall -> IO (Either String Module) + onErr = return . Left . show + +-- | Source inspection data, differs whether there are contents provided +sourceInspection :: Path -> Maybe Text -> [String] -> IO Inspection +sourceInspection f Nothing = fileInspection f +sourceInspection _ (Just _) = fileContentsInspection + +-- | File inspection data +fileInspection :: Path -> [String] -> IO Inspection +fileInspection f opts = do + tm <- Dir.getModificationTime (view path f) + return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ map fromString $ sort $ ordNub opts + +-- | File contents inspection data +fileContentsInspection :: [String] -> IO Inspection +fileContentsInspection opts = fileContentsInspection_ opts <$> getPOSIXTime + +-- | File contents inspection data +fileContentsInspection_ :: [String] -> POSIXTime -> Inspection +fileContentsInspection_ opts tm = InspectionAt tm $ map fromString $ sort $ ordNub opts + +-- | Installed module inspection data, just opts +installedInspection :: [String] -> IO Inspection +installedInspection opts = return $ InspectionAt 0 $ map fromString $ sort $ ordNub opts + +-- | Inspection by module location +moduleInspection :: ModuleLocation -> [String] -> IO Inspection +moduleInspection (FileModule fpath _) = fileInspection fpath +moduleInspection _ = installedInspection + +-- | Enumerate project dirs +projectDirs :: Project -> IO [Extensions Path] +projectDirs p = do + p' <- loadProject p + return $ ordNub $ map (fmap (normPath . (view projectPath p' `subPath`))) $ maybe [] sourceDirs $ view projectDescription p' + +-- | Enumerate project source files +projectSources :: Project -> IO [Extensions Path] +projectSources p = do + dirs <- projectDirs p + let + enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory + dirs' = map (view (entity . path)) dirs + -- enum inner projects and dont consider them as part of this project + subProjs <- liftM (map fromFilePath . delete (view (projectPath . path) p) . ordNub . concat) $ triesMap (enumCabals) dirs' + let + enumHs = liftM (filter thisProjectSource) . traverseDirectory + thisProjectSource h = haskellSource h && not (any (`isParent` fromFilePath h) subProjs) + liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (liftM (map fromFilePath) . enumHs . view path)) dirs + +-- | Get actual defines +getDefines :: IO [(String, String)] +getDefines = E.handle onIO $ do + tmp <- Dir.getTemporaryDirectory + writeFile (tmp "defines.hs") "" + _ <- runWait "ghc" ["-E", "-optP-dM", "-cpp", tmp "defines.hs"] "" + cts <- readFileUtf8 (tmp "defines.hspp") + Dir.removeFile (tmp "defines.hs") + Dir.removeFile (tmp "defines.hspp") + return $ mapMaybe (\g -> (,) <$> g 1 <*> g 2) $ mapMaybe (matchRx rx . T.unpack) $ T.lines cts + where + rx = "#define ([^\\s]+) (.*)" + onIO :: E.IOException -> IO [(String, String)] + onIO _ = return [] + +preprocess :: [(String, String)] -> Path -> Text -> IO Text +preprocess defines fpath cts = do + cts' <- E.catch (Cpphs.cppIfdef (view path fpath) defines [] cppOpts (T.unpack cts)) onIOError + return $ T.unlines $ map (fromString . snd) cts' + where + onIOError :: E.IOException -> IO [(Cpphs.Posn, String)] + onIOError _ = return [] + + cppOpts = Cpphs.defaultBoolOptions { + Cpphs.locations = False, + Cpphs.hashline = False + } + +preprocess_ :: [(String, String)] -> [String] -> Path -> Text -> IO Text +preprocess_ defines exts fpath cts + | hasCPP = preprocess defines fpath cts + | otherwise = return cts + where + exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions $ T.unpack cts) + hasCPP = H.EnableExtension H.CPP `elem` exts' + +makeLenses ''AnalyzeEnv diff --git a/src/HsDev/Inspect/Definitions.hs b/src/HsDev/Inspect/Definitions.hs --- a/src/HsDev/Inspect/Definitions.hs +++ b/src/HsDev/Inspect/Definitions.hs @@ -1,141 +1,141 @@ -{-# LANGUAGE CPP #-} - -module HsDev.Inspect.Definitions ( - getSymbols, - getDecl - ) where - -import Control.Lens -import Control.Monad -import Data.Data (Data) -import Data.Generics.Uniplate.Data -import Data.List -import Data.Maybe -import Data.Function -import Data.Ord -import Data.String -import Data.Text (Text) -import qualified Language.Haskell.Exts as H - -import HsDev.Symbols.Types -import HsDev.Symbols.Parsed -import HsDev.Symbols.Resolve (symbolUniqId) - --- | Get top symbols -getSymbols :: [H.Decl Ann] -> [Symbol] -getSymbols decls = - map mergeSymbols . - groupBy ((==) `on` symbolUniqId) . - sortBy (comparing symbolUniqId) $ - concatMap getDecl decls - where - mergeSymbols :: [Symbol] -> Symbol - mergeSymbols [] = error "impossible" - mergeSymbols [s] = s - mergeSymbols ss@(s:_) = Symbol - (view symbolId s) - (msum $ map (view symbolDocs) ss) - (msum $ map (view symbolPosition) ss) - (foldr1 mergeInfo $ map (view symbolInfo) ss) - - mergeInfo :: SymbolInfo -> SymbolInfo -> SymbolInfo - mergeInfo (Function lt) (Function rt) = Function $ lt `mplus` rt - mergeInfo (PatConstructor las lt) (PatConstructor ras rt) = PatConstructor (if null las then ras else las) (lt `mplus` rt) - mergeInfo (Selector lt lp lc) (Selector rt rp rc) - | lt == rt && lp == rp = Selector lt lp (nub $ lc ++ rc) - | otherwise = Selector lt lp lc - mergeInfo l _ = l - --- | Get symbols from declarations -getDecl :: H.Decl Ann -> [Symbol] -getDecl decl' = case decl' of - H.TypeDecl _ h _ -> [mkSymbol (tyName h) (Type (tyArgs h) [])] - H.TypeFamDecl _ h _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)] - H.ClosedTypeFamDecl _ h _ _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)] - H.DataDecl _ dt mctx h dcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getConDecl nm) dcons where - nm = tyName h - H.GDataDecl _ dt mctx h _ gcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getGConDecl nm) gcons where - nm = tyName h - H.DataFamDecl _ mctx h _ -> [mkSymbol (tyName h) (DataFam (tyArgs h) (getCtx mctx) Nothing)] - H.ClassDecl _ mctx h _ clsDecls -> mkSymbol nm (Class (tyArgs h) (getCtx mctx)) : concatMap (getClassDecl nm) (fromMaybe [] clsDecls) where - nm = tyName h - H.TypeSig _ ns tsig -> [mkSymbol n (Function (Just $ oneLinePrint tsig)) | n <- ns] -#if MIN_VERSION_haskell_src_exts(1,21,0) - H.PatSynSig _ ns mas _ _ _ t -> -#else - H.PatSynSig _ ns mas _ _ t -> -#endif - [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] -#if MIN_VERSION_haskell_src_exts(1,21,0) -getGConDecl _ (H.GadtDecl _ n _ _ Nothing t) = -#else -getGConDecl _ (H.GadtDecl _ n Nothing t) = -#endif - [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') -#if MIN_VERSION_haskell_src_exts(1,21,0) -getGConDecl ptype (H.GadtDecl _ n _ _ (Just fs) t) = -#else -getGConDecl ptype (H.GadtDecl _ n (Just fs) t) = -#endif - mkSymbol n (Constructor [prp ft | H.FieldDecl _ _ ft <- fs] (prp t)) : - [mkSymbol fn (Selector (Just $ prp ft) (prp ptype) [prp n]) | H.FieldDecl _ fns ft <- fs, fn <- fns] - -getClassDecl :: H.Name Ann -> H.ClassDecl Ann -> [Symbol] -getClassDecl pclass (H.ClsDecl _ (H.TypeSig _ ns tsig)) = [mkSymbol n (Method (Just $ oneLinePrint tsig) (prp pclass)) | n <- ns] -getClassDecl _ _ = [] - -prp :: H.Pretty a => a -> Text -prp = fromString . H.prettyPrint - - -mkSymbol :: H.Name Ann -> SymbolInfo -> Symbol -mkSymbol nm = Symbol (SymbolId (fromName_ $ void nm) (ModuleId (fromString "") noLocation)) Nothing (nm ^? binders . defPos) - - --- | Print something in one line -oneLinePrint :: (H.Pretty a, IsString s) => a -> s -oneLinePrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode +{-# LANGUAGE CPP #-} + +module HsDev.Inspect.Definitions ( + getSymbols, + getDecl + ) where + +import Control.Lens +import Control.Monad +import Data.Data (Data) +import Data.Generics.Uniplate.Data +import Data.List +import Data.Maybe +import Data.Function +import Data.Ord +import Data.String +import Data.Text (Text) +import qualified Language.Haskell.Exts as H + +import HsDev.Symbols.Types +import HsDev.Symbols.Parsed +import HsDev.Symbols.Resolve (symbolUniqId) + +-- | Get top symbols +getSymbols :: [H.Decl Ann] -> [Symbol] +getSymbols decls = + map mergeSymbols . + groupBy ((==) `on` symbolUniqId) . + sortBy (comparing symbolUniqId) $ + concatMap getDecl decls + where + mergeSymbols :: [Symbol] -> Symbol + mergeSymbols [] = error "impossible" + mergeSymbols [s] = s + mergeSymbols ss@(s:_) = Symbol + (view symbolId s) + (msum $ map (view symbolDocs) ss) + (msum $ map (view symbolPosition) ss) + (foldr1 mergeInfo $ map (view symbolInfo) ss) + + mergeInfo :: SymbolInfo -> SymbolInfo -> SymbolInfo + mergeInfo (Function lt) (Function rt) = Function $ lt `mplus` rt + mergeInfo (PatConstructor las lt) (PatConstructor ras rt) = PatConstructor (if null las then ras else las) (lt `mplus` rt) + mergeInfo (Selector lt lp lc) (Selector rt rp rc) + | lt == rt && lp == rp = Selector lt lp (nub $ lc ++ rc) + | otherwise = Selector lt lp lc + mergeInfo l _ = l + +-- | Get symbols from declarations +getDecl :: H.Decl Ann -> [Symbol] +getDecl decl' = case decl' of + H.TypeDecl _ h _ -> [mkSymbol (tyName h) (Type (tyArgs h) [])] + H.TypeFamDecl _ h _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)] + H.ClosedTypeFamDecl _ h _ _ _ -> [mkSymbol (tyName h) (TypeFam (tyArgs h) [] Nothing)] + H.DataDecl _ dt mctx h dcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getConDecl nm) dcons where + nm = tyName h + H.GDataDecl _ dt mctx h _ gcons _ -> mkSymbol nm ((getCtor dt) (tyArgs h) (getCtx mctx)) : concatMap (getGConDecl nm) gcons where + nm = tyName h + H.DataFamDecl _ mctx h _ -> [mkSymbol (tyName h) (DataFam (tyArgs h) (getCtx mctx) Nothing)] + H.ClassDecl _ mctx h _ clsDecls -> mkSymbol nm (Class (tyArgs h) (getCtx mctx)) : concatMap (getClassDecl nm) (fromMaybe [] clsDecls) where + nm = tyName h + H.TypeSig _ ns tsig -> [mkSymbol n (Function (Just $ oneLinePrint tsig)) | n <- ns] +#if MIN_VERSION_haskell_src_exts(1,21,0) + H.PatSynSig _ ns mas _ _ _ t -> +#else + H.PatSynSig _ ns mas _ _ t -> +#endif + [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] +#if MIN_VERSION_haskell_src_exts(1,21,0) +getGConDecl _ (H.GadtDecl _ n _ _ Nothing t) = +#else +getGConDecl _ (H.GadtDecl _ n Nothing t) = +#endif + [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') +#if MIN_VERSION_haskell_src_exts(1,21,0) +getGConDecl ptype (H.GadtDecl _ n _ _ (Just fs) t) = +#else +getGConDecl ptype (H.GadtDecl _ n (Just fs) t) = +#endif + 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 diff --git a/src/HsDev/Inspect/Order.hs b/src/HsDev/Inspect/Order.hs --- a/src/HsDev/Inspect/Order.hs +++ b/src/HsDev/Inspect/Order.hs @@ -1,42 +1,42 @@ -module HsDev.Inspect.Order ( - orderBy, order - ) where - -import Control.Lens -import Data.Maybe -import Data.String -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Language.Haskell.Exts as H - -import Data.Deps -import HsDev.Inspect -import HsDev.Symbols.Types -import System.Directory.Paths - --- | Order source files so that dependencies goes first and we are able to resolve symbols and set fixities -orderBy :: (a -> Maybe Preloaded) -> [a] -> Either (DepsError Path) [a] -orderBy fn ps = do - order' <- linearize pdeps - return $ mapMaybe (`M.lookup` pm) order' - where - pdeps = mconcat $ mapMaybe (fmap getDeps . fn) ps - pm = M.fromList [(pfile, p) | p <- ps, pfile <- fn p ^.. _Just . preloadedId . moduleLocation . moduleFile] - files = S.fromList $ map fn ps ^.. each . _Just . preloadedId . moduleLocation . moduleFile - getDeps :: Preloaded -> Deps Path - getDeps p = deps mfile [ifile | ifile <- ifiles, S.member ifile files] where - H.Module _ _ _ idecls _ = _preloadedModule p - imods = [fromString iname | H.ModuleName _ iname <- map H.importModule idecls] - mfile = _preloadedId p ^?! moduleLocation . moduleFile - projRoot = _preloadedId p ^? moduleLocation . moduleProject . _Just . projectPath - mroot = fromMaybe - (sourceModuleRoot (view moduleName $ _preloadedId p) mfile) - projRoot - dirs = do - proj <- _preloadedId p ^.. moduleLocation . moduleProject . _Just - i <- fileTargets proj mfile - view infoSourceDirs i - ifiles = [normPath (joinPaths [mroot, dir, importPath imod]) | imod <- imods, dir <- if null dirs then [fromFilePath "."] else dirs] - -order :: [Preloaded] -> Either (DepsError Path) [Preloaded] -order = orderBy Just +module HsDev.Inspect.Order ( + orderBy, order + ) where + +import Control.Lens +import Data.Maybe +import Data.String +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Language.Haskell.Exts as H + +import Data.Deps +import HsDev.Inspect +import HsDev.Symbols.Types +import System.Directory.Paths + +-- | Order source files so that dependencies goes first and we are able to resolve symbols and set fixities +orderBy :: (a -> Maybe Preloaded) -> [a] -> Either (DepsError Path) [a] +orderBy fn ps = do + order' <- linearize pdeps + return $ mapMaybe (`M.lookup` pm) order' + where + pdeps = mconcat $ mapMaybe (fmap getDeps . fn) ps + pm = M.fromList [(pfile, p) | p <- ps, pfile <- fn p ^.. _Just . preloadedId . moduleLocation . moduleFile] + files = S.fromList $ map fn ps ^.. each . _Just . preloadedId . moduleLocation . moduleFile + getDeps :: Preloaded -> Deps Path + getDeps p = deps mfile [ifile | ifile <- ifiles, S.member ifile files] where + H.Module _ _ _ idecls _ = _preloadedModule p + imods = [fromString iname | H.ModuleName _ iname <- map H.importModule idecls] + mfile = _preloadedId p ^?! moduleLocation . moduleFile + projRoot = _preloadedId p ^? moduleLocation . moduleProject . _Just . projectPath + mroot = fromMaybe + (sourceModuleRoot (view moduleName $ _preloadedId p) mfile) + projRoot + dirs = do + proj <- _preloadedId p ^.. moduleLocation . moduleProject . _Just + i <- fileTargets proj mfile + view infoSourceDirs i + ifiles = [normPath (joinPaths [mroot, dir, importPath imod]) | imod <- imods, dir <- if null dirs then [fromFilePath "."] else dirs] + +order :: [Preloaded] -> Either (DepsError Path) [Preloaded] +order = orderBy Just diff --git a/src/HsDev/Inspect/Resolve.hs b/src/HsDev/Inspect/Resolve.hs --- a/src/HsDev/Inspect/Resolve.hs +++ b/src/HsDev/Inspect/Resolve.hs @@ -1,383 +1,383 @@ -{-# LANGUAGE OverloadedStrings, TypeApplications, TypeOperators #-} - -module HsDev.Inspect.Resolve ( - -- * Prepare - loadEnv, saveEnv, - loadEnvironment, loadFixities, withEnv, - -- * Resolving - resolveModule, resolvePreloaded, resolve, - -- * Saving results - updateResolveds - ) where - -import Control.Lens hiding ((.=)) -import Control.Monad.Catch -import Data.Aeson -import Data.Generics.Uniplate.Operations -import Data.Functor -import Data.Function -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Ord -import Data.String -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Haskell.Exts as H -import qualified Language.Haskell.Names as N -import qualified Language.Haskell.Names.Open as N -import qualified Language.Haskell.Names.Annotated as N -import qualified Language.Haskell.Names.Imports as N -import qualified Language.Haskell.Names.Exports as N -import qualified Language.Haskell.Names.ModuleSymbols as N -import qualified Language.Haskell.Names.SyntaxUtils as N -import System.Log.Simple -import Text.Format - -import Data.LookupTable -import System.Directory.Paths -import HsDev.Database.SQLite as SQLite -import qualified HsDev.Display as Display -import HsDev.Error -import HsDev.Inspect.Definitions -import HsDev.Inspect.Types -import HsDev.Symbols -import qualified HsDev.Symbols.HaskellNames as HN -import HsDev.Symbols.Parsed as P -import HsDev.Server.Types -import HsDev.Util - --- | Try resolve module symbols -resolveModule :: MonadThrow m => Environment -> FixitiesTable -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved -resolveModule env fixities p = inspectTag ResolvedNamesTag $ inspectUntag OnlyHeaderTag $ case H.parseFileContentsWithMode (p' ^. preloadedMode) (T.unpack $ p ^. preloaded) of - H.ParseFailed loc reason -> hsdevError $ InspectError $ "Parse failed at " ++ show loc ++ ": " ++ reason - H.ParseOk m -> return (resolve env m) - where - qimps = M.keys $ N.importTable env (p ^. preloadedModule) - p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` fixities) qimps) } } - --- | Resolve just preloaded part of module, this will give imports and scope -resolvePreloaded :: MonadThrow m => Environment -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved -resolvePreloaded env = inspectTag ResolvedNamesTag . return . resolve env . view preloadedModule - --- | Resolve parsed module -resolve :: Environment -> H.Module H.SrcSpanInfo -> Resolved -resolve env m = Resolved { - _resolvedModule = void mn, - _resolvedSource = annotated, - _resolvedDefs = getSymbols decls', - _resolvedImports = map (toImport . dropScope) idecls', - _resolvedExports = N.exportedSymbols tbl m, - _resolvedScope = tbl, - _resolvedFixities = [H.Fixity (void assoc) (fromMaybe 0 pr) (fixName opName) - | H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops] } - where - getOpName (H.VarOp _ nm) = nm - getOpName (H.ConOp _ nm) = nm - fixName o = H.Qual () (void mn) (void o) - itbl = N.importTable env m - tbl = N.moduleTable itbl m - -- Not using 'annotate' because we already computed needed tables - annotated = H.Module (noScope l) mhead' mpragmas' idecls' decls' - H.Module l mhead mpragmas idecls decls = m - mhead' = fmap scopeHead mhead - mpragmas' = fmap withNoScope mpragmas - scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead (noScope lh) (withNoScope mname) (fmap withNoScope mwarns) $ - fmap (N.annotateExportSpecList tbl) mexports - idecls' = N.annotateImportDecls mn env idecls - decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl)) decls - mn = N.getModuleName m - --- | Load environment and fixities from cache or sql -loadEnv :: SessionMonad m => Maybe Path -> m (Environment, FixitiesTable) -loadEnv mcabal = do - envTable <- askSession sessionResolveEnvironment - cacheInTableM envTable mcabal $ (,) <$> loadEnvironment mcabal <*> loadFixities mcabal - --- | Save environment and fixities to cache -saveEnv :: SessionMonad m => Maybe Path -> Environment -> FixitiesTable -> m () -saveEnv mcabal env fixities = do - envTable <- askSession sessionResolveEnvironment - void $ insertTable mcabal (env, fixities) envTable - --- | Load environment from sql -loadEnvironment :: SessionMonad m => Maybe Path -> m Environment -loadEnvironment mcabal = transaction_ Deferred $ do - sendLog Trace $ "loading environment for {}" ~~ fromMaybe "" mcabal - env <- query @_ @(Only (H.ModuleName ()) :. N.Symbol) - (toQuery $ mconcat [ - select_ ["em.name"], - from_ ["projects_modules_scope as ps", "exports as e", "modules as em"], - where_ [ - "ps.cabal is ?", - "ps.module_id = em.id", - "e.symbol_id = s.id", - "e.module_id = em.id"], - qNSymbol "m" "s"]) - (Only mcabal) - return $ M.fromList $ do - group' <- groupBy ((==) `on` fst) . sortBy (comparing fst) $ [(m, s) | (Only m :. s) <- env] - let - (gmod:_, gsyms) = unzip group' - return (gmod, gsyms) - --- | Load fixities from sql -loadFixities :: SessionMonad m => Maybe Path -> m FixitiesTable -loadFixities mcabal = transaction_ Deferred $ do - fixities' <- query @_ @(Only Value) - (toQuery $ mconcat [ - select_ ["m.fixities"], - from_ ["projects_modules_scope as ps", "modules as m"], - where_ [ - "ps.cabal is ?", - "ps.module_id = m.id", - "m.fixities is not null"]]) - (Only mcabal) - return $ mconcat [M.singleton n f | - f@(H.Fixity _ _ n) <- concat (mapMaybe (fromJSON' . fromOnly) fixities')] - --- | Run with temporary table for environment -withEnv :: SessionMonad m => Maybe Path -> m a -> m a -withEnv mcabal = (initEnv >>) where - initEnv = do - execute_ "create temporary table if not exists resolve (cabal text);" - execute_ "create temporary table if not exists env (module text not null, name text not null, what text not null, id integer not null);" - execute_ "create unique index if not exists env_id_index on env (id);" - execute_ "create unique index if not exists env_symbol_index on env (module, name, what);" - - curEnv <- query_ "select cabal from resolve;" - unless (fmap fromOnly (listToMaybe curEnv) == Just mcabal) $ do - execute_ "delete from resolve;" - execute "insert into resolve values (?);" (Only mcabal) - execute_ "delete from env;" - executeNamed "insert into env select m.name, s.name, s.what, min(s.id) from modules as m, symbols as s where m.id = s.module_id and s.id in (select distinct e.symbol_id from exports as e where e.module_id in (select ps.module_id from projects_modules_scope as ps where ps.cabal is :cabal)) group by m.name, s.name, s.what;" [ - ":cabal" := mcabal] - - [Only cnt] <- query_ @(Only Int) "select count(*) from env;" - sendLog Trace $ "created env table with {} symbols" ~~ cnt - --- | Save results in sql, updated temporary env table -updateResolveds :: SessionMonad m => Maybe Path -> [InspectedResolved] -> m () -updateResolveds mcabal ims = scope "update-resolveds" $ withEnv mcabal $ do - ids <- upsertResolveds ims - updateResolvedsSymbols (zip ids ims) - -upsertResolveds :: SessionMonad m => [InspectedResolved] -> m [Int] -upsertResolveds ims = scope "upsert-resolveds" $ bracket_ initTemp removeTemp $ do - executeMany "insert into upserted_modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ map moduleData ims - execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location));" - execute_ "insert or replace into modules (id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is not null;" - execute_ "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is null;" - execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location)) where id is null;" - - liftM (map fromOnly) $ query_ "select id from upserted_modules order by rowid;" - where - initTemp :: SessionMonad m => m () - initTemp = do - execute_ "create temporary table upserted_modules as select * from modules where 0;" - execute_ "create index upserted_modules_id_index on upserted_modules (id);" - - removeTemp :: SessionMonad m => m () - removeTemp = execute_ "drop table if exists upserted_modules;" - - moduleData im = ( - im ^? inspectedKey . moduleFile . path, - im ^? inspectedKey . moduleProject . _Just . projectCabal, - fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs), - im ^? inspectedKey . modulePackage . packageName, - im ^? inspectedKey . modulePackage . packageVersion, - im ^? inspectedKey . installedModuleName, - im ^? inspectedKey . installedModuleExposed, - im ^? inspectedKey . otherLocationName) - :. ( - msum [im ^? inspected . resolvedModule . moduleName_, im ^? inspectedKey . installedModuleName], - Nothing @Text, - fmap encode $ im ^? inspected . resolvedFixities, - encode $ asDict $ im ^. inspectionTags, - fmap show $ im ^? inspectionResult . _Left) - :. - fromMaybe InspectionNone (im ^? inspection) - asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags] - -updateResolvedsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m () -updateResolvedsSymbols ims = bracket_ initTemps dropTemps $ do - initUpdatedIds ims - - removeModulesContents - transaction_ Immediate $ insertModulesDefs ims - transaction_ Immediate $ insertModulesImports ims - transaction_ Immediate $ insertExportsSymbols ims - transaction_ Immediate $ do - insertScopesSymbols ims - insertResolvedsNames ims - commitTemps - - where - initTemps :: SessionMonad m => m () - initTemps = do - execute_ "create temporary table updated_ids (id integer not null, cabal text, module text not null, only_header int not null, dirty int not null);" - execute_ "create temporary table updating_scopes as select * from scopes where 0;" - execute_ "create index updating_scopes_name_index on updating_scopes (module_id, name);" - execute_ "create temporary table updating_names as select * from names where 0;" - execute_ "create unique index updating_names_position_index on updating_names (module_id, line, column, line_to, column_to);" - - dropTemps :: SessionMonad m => m () - dropTemps = do - execute_ "drop table if exists updated_ids;" - execute_ "drop table if exists updating_scopes;" - execute_ "drop table if exists updating_names;" - - commitTemps :: SessionMonad m => m () - commitTemps = do - transaction_ Immediate $ execute_ "insert into scopes select * from updating_scopes;" - transaction_ Immediate $ execute_ "insert into names select * from updating_names;" - - initUpdatedIds :: SessionMonad m => [(Int, InspectedResolved)] -> m () - initUpdatedIds imods = transaction_ Immediate $ do - execute_ "create unique index updated_ids_id_index on updated_ids (id);" - execute_ "create index updated_ids_module_index on updated_ids (module);" - executeMany "insert into updated_ids (id, cabal, module, only_header, dirty) values (?, ?, ?, ?, ?);" $ do - (mid, im) <- imods - return ( - mid, - im ^? inspectedKey . moduleProject . _Just . projectCabal, - im ^?! inspected . resolvedModule . moduleName_, - hasTag OnlyHeaderTag im, - hasTag DirtyTag im) - - removeModulesContents :: SessionMonad m => m () - removeModulesContents = scope "remove-modules-contents" $ do - transaction_ Immediate $ do - execute_ "delete from symbols where module_id in (select id from updated_ids where not only_header or not dirty);" - execute_ "update symbols set line = null, column = null where module_id in (select id from updated_ids where only_header and dirty);" - execute_ "delete from imports where module_id in (select id from updated_ids);" - execute_ "delete from exports where module_id in (select id from updated_ids);" - - transaction_ Immediate $ execute_ "delete from scopes where module_id in (select id from updated_ids);" - transaction_ Immediate $ execute_ "delete from names where module_id in (select id from updated_ids);" - transaction_ Immediate $ execute_ "delete from types where module_id in (select id from updated_ids);" - - insertModulesImports :: SessionMonad m => [(Int, InspectedResolved)] -> m () - insertModulesImports imods = scope "imports" $ do - executeMany "insert into imports (module_id, line, column, module_name, qualified, alias, hiding, import_list) values (?, ?, ?, ?, ?, ?, ?, ?);" $ do - (mid, im) <- imods - let - p = im ^?! inspected . resolvedSource - idecl@(H.ImportDecl _ mname qual _ _ _ alias specList) <- childrenBi p :: [H.ImportDecl Ann] - return ( - mid, - idecl ^. pos . positionLine, - idecl ^. pos . positionColumn, - getModuleName mname, - qual, - fmap getModuleName alias, - maybe False getHiding specList, - fmap makeImportList specList) - execute_ "update imports set import_module_id = (select im.id from updated_ids as u, modules as im, projects_modules_scope as ps where ((ps.cabal is null and u.cabal is null) or (ps.cabal == u.cabal)) and ps.module_id == im.id and im.name == imports.module_name) where module_id in (select u.id from updated_ids as u);" - where - getModuleName (H.ModuleName _ s) = s - getHiding (H.ImportSpecList _ h _) = h - - makeImportList (H.ImportSpecList _ _ specs) = encode $ map asJson specs - asJson (H.IVar _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "var"] - asJson (H.IAbs _ ns nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "abs", "ns" .= fromNamespace ns] where - fromNamespace :: H.Namespace l -> Maybe String - fromNamespace (H.NoNamespace _) = Nothing - fromNamespace (H.TypeNamespace _) = Just "type" - fromNamespace (H.PatternNamespace _) = Just "pat" - asJson (H.IThingAll _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "all"] - asJson (H.IThingWith _ nm cs) = object ["name" .= fromName_ (void nm), "what" .= id @String "with", "list" .= map (fromName_ . void . toName') cs] where - toName' (H.VarName _ n') = n' - toName' (H.ConName _ n') = n' - - insertModulesDefs :: SessionMonad m => [(Int, InspectedResolved)] -> m () - insertModulesDefs imods = scope "defs" $ do - executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do - (mid, im) <- imods - sym <- im ^.. inspected . resolvedDefs . each - return $ ( - sym ^. symbolId . symbolName, - mid, - sym ^. symbolDocs, - sym ^? symbolPosition . _Just . positionLine, - sym ^? symbolPosition . _Just . positionColumn) - :. - (sym ^. symbolInfo) - execute_ "insert or replace into env (module, name, what, id) select m.name, s.name, s.what, s.id from modules as m, symbols as s where m.id in (select id from updated_ids) and s.module_id = m.id;" - - insertExportsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m () - insertExportsSymbols imods = scope "exports" $ executeMany "insert into exports (module_id, symbol_id) select ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do - (mid, im) <- imods - sym <- im ^.. inspected . resolvedExports . each - return ( - mid, - N.symbolModule sym, - N.symbolName sym, - symbolType (HN.fromSymbol sym)) - - insertScopesSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m () - insertScopesSymbols imods = scope "scope" $ executeMany "insert into updating_scopes (module_id, qualifier, name, symbol_id) select ?, ?, ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do - (mid, im) <- imods - (qn, syms) <- M.toList (im ^. inspected . resolvedScope) - sym <- syms - return ( - mid, - nameModule qn, - nameIdent qn, - N.symbolModule sym, - N.symbolName sym, - symbolType (HN.fromSymbol sym)) - - insertResolvedsNames :: SessionMonad m => [(Int, InspectedResolved)] -> m () - insertResolvedsNames imods = scope "names" $ do - insertNames - replaceQNames - resolveGlobalBinders - setResolvedsSymbolIds - where - insertNames = executeMany insertQuery namesData - replaceQNames = executeMany insertQuery qnamesData - resolveGlobalBinders = execute_ "update updating_names set (resolved_module, resolved_name, resolved_what) = (select u.module, s.name, s.what from updated_ids as u, symbols as s where u.id = s.module_id and s.module_id = updating_names.module_id and s.line = updating_names.line and s.column = updating_names.column) where (line, column) = (def_line, def_column) and resolved_module is null and resolved_name is null;" - setResolvedsSymbolIds = execute_ "update updating_names set symbol_id = (select sc.symbol_id from updating_scopes as sc, symbols as s, modules as m where updating_names.module_id == sc.module_id and ((updating_names.qualifier is null and sc.qualifier is null) or (updating_names.qualifier == sc.qualifier)) and updating_names.name == sc.name and s.id == sc.symbol_id and m.id == s.module_id and s.name == updating_names.resolved_name and s.what == updating_names.resolved_what and m.name == updating_names.resolved_module) where resolved_module is not null and resolved_name is not null and resolved_what is not null;" - insertQuery = "insert or replace into updating_names (module_id, qualifier, name, line, column, line_to, column_to, def_line, def_column, resolved_module, resolved_name, resolved_what, resolve_error) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" - - namesData = map (uncurry toData) $ do - (mid, im) <- imods - n <- im ^.. inspected . resolvedSource . P.names - return (mid, n) - qnamesData = map (uncurry toQData) $ do - (mid, im) <- imods - n <- im ^.. inspected . resolvedSource . P.qnames - return (mid, n) - - toData mid name = ( - mid, - Nothing :: Maybe Text, - fromName_ $ void name, - name ^. P.pos . positionLine, - name ^. P.pos . positionColumn, - name ^. P.regionL . regionTo . positionLine, - name ^. P.regionL . regionTo . positionColumn) - :. ( - name ^? P.defPos . positionLine, - name ^? P.defPos . positionColumn, - (name ^? P.resolvedName) >>= nameModule, - nameIdent <$> (name ^? P.resolvedName), - fmap (symbolType . HN.fromSymbol) $ name ^? P.symbolL, - P.resolveError name) - toQData mid qname = ( - mid, - nameModule $ void qname, - nameIdent $ void qname, - qname ^. P.pos . positionLine, - qname ^. P.pos . positionColumn, - qname ^. P.regionL . regionTo . positionLine, - qname ^. P.regionL . regionTo . positionColumn) - :. ( - qname ^? P.defPos . positionLine, - qname ^? P.defPos . positionColumn, - (qname ^? P.resolvedName) >>= nameModule, - nameIdent <$> (qname ^? P.resolvedName), - fmap (symbolType . HN.fromSymbol) $ qname ^? P.symbolL, - P.resolveError qname) +{-# LANGUAGE OverloadedStrings, TypeApplications, TypeOperators #-} + +module HsDev.Inspect.Resolve ( + -- * Prepare + loadEnv, saveEnv, + loadEnvironment, loadFixities, withEnv, + -- * Resolving + resolveModule, resolvePreloaded, resolve, + -- * Saving results + updateResolveds + ) where + +import Control.Lens hiding ((.=)) +import Control.Monad.Catch +import Data.Aeson +import Data.Generics.Uniplate.Operations +import Data.Functor +import Data.Function +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Ord +import Data.String +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Language.Haskell.Exts as H +import qualified Language.Haskell.Names as N +import qualified Language.Haskell.Names.Open as N +import qualified Language.Haskell.Names.Annotated as N +import qualified Language.Haskell.Names.Imports as N +import qualified Language.Haskell.Names.Exports as N +import qualified Language.Haskell.Names.ModuleSymbols as N +import qualified Language.Haskell.Names.SyntaxUtils as N +import System.Log.Simple +import Text.Format + +import Data.LookupTable +import System.Directory.Paths +import HsDev.Database.SQLite as SQLite +import qualified HsDev.Display as Display +import HsDev.Error +import HsDev.Inspect.Definitions +import HsDev.Inspect.Types +import HsDev.Symbols +import qualified HsDev.Symbols.HaskellNames as HN +import HsDev.Symbols.Parsed as P +import HsDev.Server.Types +import HsDev.Util + +-- | Try resolve module symbols +resolveModule :: MonadThrow m => Environment -> FixitiesTable -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved +resolveModule env fixities p = inspectTag ResolvedNamesTag $ inspectUntag OnlyHeaderTag $ case H.parseFileContentsWithMode (p' ^. preloadedMode) (T.unpack $ p ^. preloaded) of + H.ParseFailed loc reason -> hsdevError $ InspectError $ "Parse failed at " ++ show loc ++ ": " ++ reason + H.ParseOk m -> return (resolve env m) + where + qimps = M.keys $ N.importTable env (p ^. preloadedModule) + p' = p { _preloadedMode = (_preloadedMode p) { H.fixities = Just (mapMaybe (`M.lookup` fixities) qimps) } } + +-- | Resolve just preloaded part of module, this will give imports and scope +resolvePreloaded :: MonadThrow m => Environment -> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved +resolvePreloaded env = inspectTag ResolvedNamesTag . return . resolve env . view preloadedModule + +-- | Resolve parsed module +resolve :: Environment -> H.Module H.SrcSpanInfo -> Resolved +resolve env m = Resolved { + _resolvedModule = void mn, + _resolvedSource = annotated, + _resolvedDefs = getSymbols decls', + _resolvedImports = map (toImport . dropScope) idecls', + _resolvedExports = N.exportedSymbols tbl m, + _resolvedScope = tbl, + _resolvedFixities = [H.Fixity (void assoc) (fromMaybe 0 pr) (fixName opName) + | H.InfixDecl _ assoc pr ops <- decls', opName <- map getOpName ops] } + where + getOpName (H.VarOp _ nm) = nm + getOpName (H.ConOp _ nm) = nm + fixName o = H.Qual () (void mn) (void o) + itbl = N.importTable env m + tbl = N.moduleTable itbl m + -- Not using 'annotate' because we already computed needed tables + annotated = H.Module (noScope l) mhead' mpragmas' idecls' decls' + H.Module l mhead mpragmas idecls decls = m + mhead' = fmap scopeHead mhead + mpragmas' = fmap withNoScope mpragmas + scopeHead (H.ModuleHead lh mname mwarns mexports) = H.ModuleHead (noScope lh) (withNoScope mname) (fmap withNoScope mwarns) $ + fmap (N.annotateExportSpecList tbl) mexports + idecls' = N.annotateImportDecls mn env idecls + decls' = map (N.annotateDecl (N.initialScope (N.dropAnn mn) tbl)) decls + mn = N.getModuleName m + +-- | Load environment and fixities from cache or sql +loadEnv :: SessionMonad m => Maybe Path -> m (Environment, FixitiesTable) +loadEnv mcabal = do + envTable <- askSession sessionResolveEnvironment + cacheInTableM envTable mcabal $ (,) <$> loadEnvironment mcabal <*> loadFixities mcabal + +-- | Save environment and fixities to cache +saveEnv :: SessionMonad m => Maybe Path -> Environment -> FixitiesTable -> m () +saveEnv mcabal env fixities = do + envTable <- askSession sessionResolveEnvironment + void $ insertTable mcabal (env, fixities) envTable + +-- | Load environment from sql +loadEnvironment :: SessionMonad m => Maybe Path -> m Environment +loadEnvironment mcabal = transaction_ Deferred $ do + sendLog Trace $ "loading environment for {}" ~~ fromMaybe "" mcabal + env <- query @_ @(Only (H.ModuleName ()) :. N.Symbol) + (toQuery $ mconcat [ + select_ ["em.name"], + from_ ["projects_modules_scope as ps", "exports as e", "modules as em"], + where_ [ + "ps.cabal is ?", + "ps.module_id = em.id", + "e.symbol_id = s.id", + "e.module_id = em.id"], + qNSymbol "m" "s"]) + (Only mcabal) + return $ M.fromList $ do + group' <- groupBy ((==) `on` fst) . sortBy (comparing fst) $ [(m, s) | (Only m :. s) <- env] + let + (gmod:_, gsyms) = unzip group' + return (gmod, gsyms) + +-- | Load fixities from sql +loadFixities :: SessionMonad m => Maybe Path -> m FixitiesTable +loadFixities mcabal = transaction_ Deferred $ do + fixities' <- query @_ @(Only Value) + (toQuery $ mconcat [ + select_ ["m.fixities"], + from_ ["projects_modules_scope as ps", "modules as m"], + where_ [ + "ps.cabal is ?", + "ps.module_id = m.id", + "m.fixities is not null"]]) + (Only mcabal) + return $ mconcat [M.singleton n f | + f@(H.Fixity _ _ n) <- concat (mapMaybe (fromJSON' . fromOnly) fixities')] + +-- | Run with temporary table for environment +withEnv :: SessionMonad m => Maybe Path -> m a -> m a +withEnv mcabal = (initEnv >>) where + initEnv = do + execute_ "create temporary table if not exists resolve (cabal text);" + execute_ "create temporary table if not exists env (module text not null, name text not null, what text not null, id integer not null);" + execute_ "create unique index if not exists env_id_index on env (id);" + execute_ "create unique index if not exists env_symbol_index on env (module, name, what);" + + curEnv <- query_ "select cabal from resolve;" + unless (fmap fromOnly (listToMaybe curEnv) == Just mcabal) $ do + execute_ "delete from resolve;" + execute "insert into resolve values (?);" (Only mcabal) + execute_ "delete from env;" + executeNamed "insert into env select m.name, s.name, s.what, min(s.id) from modules as m, symbols as s where m.id = s.module_id and s.id in (select distinct e.symbol_id from exports as e where e.module_id in (select ps.module_id from projects_modules_scope as ps where ps.cabal is :cabal)) group by m.name, s.name, s.what;" [ + ":cabal" := mcabal] + + [Only cnt] <- query_ @(Only Int) "select count(*) from env;" + sendLog Trace $ "created env table with {} symbols" ~~ cnt + +-- | Save results in sql, updated temporary env table +updateResolveds :: SessionMonad m => Maybe Path -> [InspectedResolved] -> m () +updateResolveds mcabal ims = scope "update-resolveds" $ withEnv mcabal $ do + ids <- upsertResolveds ims + updateResolvedsSymbols (zip ids ims) + +upsertResolveds :: SessionMonad m => [InspectedResolved] -> m [Int] +upsertResolveds ims = scope "upsert-resolveds" $ bracket_ initTemp removeTemp $ do + executeMany "insert into upserted_modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ map moduleData ims + execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location));" + execute_ "insert or replace into modules (id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select id, file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is not null;" + execute_ "insert into modules (file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts) select file, cabal, install_dirs, package_name, package_version, installed_name, exposed, other_location, name, docs, fixities, tags, inspection_error, inspection_time, inspection_opts from upserted_modules where id is null;" + execute_ "update upserted_modules set id = (select m.id from modules as m where (m.file = upserted_modules.file) or ((m.package_name = upserted_modules.package_name) and (m.package_version = upserted_modules.package_version) and (m.installed_name = upserted_modules.installed_name)) or (m.other_location = upserted_modules.other_location)) where id is null;" + + liftM (map fromOnly) $ query_ "select id from upserted_modules order by rowid;" + where + initTemp :: SessionMonad m => m () + initTemp = do + execute_ "create temporary table upserted_modules as select * from modules where 0;" + execute_ "create index upserted_modules_id_index on upserted_modules (id);" + + removeTemp :: SessionMonad m => m () + removeTemp = execute_ "drop table if exists upserted_modules;" + + moduleData im = ( + im ^? inspectedKey . moduleFile . path, + im ^? inspectedKey . moduleProject . _Just . projectCabal, + fmap (encode . map (view path)) (im ^? inspectedKey . moduleInstallDirs), + im ^? inspectedKey . modulePackage . packageName, + im ^? inspectedKey . modulePackage . packageVersion, + im ^? inspectedKey . installedModuleName, + im ^? inspectedKey . installedModuleExposed, + im ^? inspectedKey . otherLocationName) + :. ( + msum [im ^? inspected . resolvedModule . moduleName_, im ^? inspectedKey . installedModuleName], + Nothing @Text, + fmap encode $ im ^? inspected . resolvedFixities, + encode $ asDict $ im ^. inspectionTags, + fmap show $ im ^? inspectionResult . _Left) + :. + fromMaybe InspectionNone (im ^? inspection) + asDict tags = object [fromString (Display.display t) .= True | t <- S.toList tags] + +updateResolvedsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m () +updateResolvedsSymbols ims = bracket_ initTemps dropTemps $ do + initUpdatedIds ims + + removeModulesContents + transaction_ Immediate $ insertModulesDefs ims + transaction_ Immediate $ insertModulesImports ims + transaction_ Immediate $ insertExportsSymbols ims + transaction_ Immediate $ do + insertScopesSymbols ims + insertResolvedsNames ims + commitTemps + + where + initTemps :: SessionMonad m => m () + initTemps = do + execute_ "create temporary table updated_ids (id integer not null, cabal text, module text not null, only_header int not null, dirty int not null);" + execute_ "create temporary table updating_scopes as select * from scopes where 0;" + execute_ "create index updating_scopes_name_index on updating_scopes (module_id, name);" + execute_ "create temporary table updating_names as select * from names where 0;" + execute_ "create unique index updating_names_position_index on updating_names (module_id, line, column, line_to, column_to);" + + dropTemps :: SessionMonad m => m () + dropTemps = do + execute_ "drop table if exists updated_ids;" + execute_ "drop table if exists updating_scopes;" + execute_ "drop table if exists updating_names;" + + commitTemps :: SessionMonad m => m () + commitTemps = do + transaction_ Immediate $ execute_ "insert into scopes select * from updating_scopes;" + transaction_ Immediate $ execute_ "insert into names select * from updating_names;" + + initUpdatedIds :: SessionMonad m => [(Int, InspectedResolved)] -> m () + initUpdatedIds imods = transaction_ Immediate $ do + execute_ "create unique index updated_ids_id_index on updated_ids (id);" + execute_ "create index updated_ids_module_index on updated_ids (module);" + executeMany "insert into updated_ids (id, cabal, module, only_header, dirty) values (?, ?, ?, ?, ?);" $ do + (mid, im) <- imods + return ( + mid, + im ^? inspectedKey . moduleProject . _Just . projectCabal, + im ^?! inspected . resolvedModule . moduleName_, + hasTag OnlyHeaderTag im, + hasTag DirtyTag im) + + removeModulesContents :: SessionMonad m => m () + removeModulesContents = scope "remove-modules-contents" $ do + transaction_ Immediate $ do + execute_ "delete from symbols where module_id in (select id from updated_ids where not only_header or not dirty);" + execute_ "update symbols set line = null, column = null where module_id in (select id from updated_ids where only_header and dirty);" + execute_ "delete from imports where module_id in (select id from updated_ids);" + execute_ "delete from exports where module_id in (select id from updated_ids);" + + transaction_ Immediate $ execute_ "delete from scopes where module_id in (select id from updated_ids);" + transaction_ Immediate $ execute_ "delete from names where module_id in (select id from updated_ids);" + transaction_ Immediate $ execute_ "delete from types where module_id in (select id from updated_ids);" + + insertModulesImports :: SessionMonad m => [(Int, InspectedResolved)] -> m () + insertModulesImports imods = scope "imports" $ do + executeMany "insert into imports (module_id, line, column, module_name, qualified, alias, hiding, import_list) values (?, ?, ?, ?, ?, ?, ?, ?);" $ do + (mid, im) <- imods + let + p = im ^?! inspected . resolvedSource + idecl@(H.ImportDecl _ mname qual _ _ _ alias specList) <- childrenBi p :: [H.ImportDecl Ann] + return ( + mid, + idecl ^. pos . positionLine, + idecl ^. pos . positionColumn, + getModuleName mname, + qual, + fmap getModuleName alias, + maybe False getHiding specList, + fmap makeImportList specList) + execute_ "update imports set import_module_id = (select im.id from updated_ids as u, modules as im, projects_modules_scope as ps where ((ps.cabal is null and u.cabal is null) or (ps.cabal == u.cabal)) and ps.module_id == im.id and im.name == imports.module_name) where module_id in (select u.id from updated_ids as u);" + where + getModuleName (H.ModuleName _ s) = s + getHiding (H.ImportSpecList _ h _) = h + + makeImportList (H.ImportSpecList _ _ specs) = encode $ map asJson specs + asJson (H.IVar _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "var"] + asJson (H.IAbs _ ns nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "abs", "ns" .= fromNamespace ns] where + fromNamespace :: H.Namespace l -> Maybe String + fromNamespace (H.NoNamespace _) = Nothing + fromNamespace (H.TypeNamespace _) = Just "type" + fromNamespace (H.PatternNamespace _) = Just "pat" + asJson (H.IThingAll _ nm) = object ["name" .= fromName_ (void nm), "what" .= id @String "all"] + asJson (H.IThingWith _ nm cs) = object ["name" .= fromName_ (void nm), "what" .= id @String "with", "list" .= map (fromName_ . void . toName') cs] where + toName' (H.VarName _ n') = n' + toName' (H.ConName _ n') = n' + + insertModulesDefs :: SessionMonad m => [(Int, InspectedResolved)] -> m () + insertModulesDefs imods = scope "defs" $ do + executeMany "insert into symbols (name, module_id, docs, line, column, what, type, parent, constructors, args, context, associate, pat_type, pat_constructor) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" $ do + (mid, im) <- imods + sym <- im ^.. inspected . resolvedDefs . each + return $ ( + sym ^. symbolId . symbolName, + mid, + sym ^. symbolDocs, + sym ^? symbolPosition . _Just . positionLine, + sym ^? symbolPosition . _Just . positionColumn) + :. + (sym ^. symbolInfo) + execute_ "insert or replace into env (module, name, what, id) select m.name, s.name, s.what, s.id from modules as m, symbols as s where m.id in (select id from updated_ids) and s.module_id = m.id;" + + insertExportsSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m () + insertExportsSymbols imods = scope "exports" $ executeMany "insert into exports (module_id, symbol_id) select ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do + (mid, im) <- imods + sym <- im ^.. inspected . resolvedExports . each + return ( + mid, + N.symbolModule sym, + N.symbolName sym, + symbolType (HN.fromSymbol sym)) + + insertScopesSymbols :: SessionMonad m => [(Int, InspectedResolved)] -> m () + insertScopesSymbols imods = scope "scope" $ executeMany "insert into updating_scopes (module_id, qualifier, name, symbol_id) select ?, ?, ?, env.id from env where env.module = ? and env.name = ? and env.what = ?;" $ do + (mid, im) <- imods + (qn, syms) <- M.toList (im ^. inspected . resolvedScope) + sym <- syms + return ( + mid, + nameModule qn, + nameIdent qn, + N.symbolModule sym, + N.symbolName sym, + symbolType (HN.fromSymbol sym)) + + insertResolvedsNames :: SessionMonad m => [(Int, InspectedResolved)] -> m () + insertResolvedsNames imods = scope "names" $ do + insertNames + replaceQNames + resolveGlobalBinders + setResolvedsSymbolIds + where + insertNames = executeMany insertQuery namesData + replaceQNames = executeMany insertQuery qnamesData + resolveGlobalBinders = execute_ "update updating_names set (resolved_module, resolved_name, resolved_what) = (select u.module, s.name, s.what from updated_ids as u, symbols as s where u.id = s.module_id and s.module_id = updating_names.module_id and s.line = updating_names.line and s.column = updating_names.column) where (line, column) = (def_line, def_column) and resolved_module is null and resolved_name is null;" + setResolvedsSymbolIds = execute_ "update updating_names set symbol_id = (select sc.symbol_id from updating_scopes as sc, symbols as s, modules as m where updating_names.module_id == sc.module_id and ((updating_names.qualifier is null and sc.qualifier is null) or (updating_names.qualifier == sc.qualifier)) and updating_names.name == sc.name and s.id == sc.symbol_id and m.id == s.module_id and s.name == updating_names.resolved_name and s.what == updating_names.resolved_what and m.name == updating_names.resolved_module) where resolved_module is not null and resolved_name is not null and resolved_what is not null;" + insertQuery = "insert or replace into updating_names (module_id, qualifier, name, line, column, line_to, column_to, def_line, def_column, resolved_module, resolved_name, resolved_what, resolve_error) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" + + namesData = map (uncurry toData) $ do + (mid, im) <- imods + n <- im ^.. inspected . resolvedSource . P.names + return (mid, n) + qnamesData = map (uncurry toQData) $ do + (mid, im) <- imods + n <- im ^.. inspected . resolvedSource . P.qnames + return (mid, n) + + toData mid name = ( + mid, + Nothing :: Maybe Text, + fromName_ $ void name, + name ^. P.pos . positionLine, + name ^. P.pos . positionColumn, + name ^. P.regionL . regionTo . positionLine, + name ^. P.regionL . regionTo . positionColumn) + :. ( + name ^? P.defPos . positionLine, + name ^? P.defPos . positionColumn, + (name ^? P.resolvedName) >>= nameModule, + nameIdent <$> (name ^? P.resolvedName), + fmap (symbolType . HN.fromSymbol) $ name ^? P.symbolL, + P.resolveError name) + toQData mid qname = ( + mid, + nameModule $ void qname, + nameIdent $ void qname, + qname ^. P.pos . positionLine, + qname ^. P.pos . positionColumn, + qname ^. P.regionL . regionTo . positionLine, + qname ^. P.regionL . regionTo . positionColumn) + :. ( + qname ^? P.defPos . positionLine, + qname ^? P.defPos . positionColumn, + (qname ^? P.resolvedName) >>= nameModule, + nameIdent <$> (qname ^? P.resolvedName), + fmap (symbolType . HN.fromSymbol) $ qname ^? P.symbolL, + P.resolveError qname) diff --git a/src/HsDev/Inspect/Types.hs b/src/HsDev/Inspect/Types.hs --- a/src/HsDev/Inspect/Types.hs +++ b/src/HsDev/Inspect/Types.hs @@ -1,104 +1,104 @@ -{-# LANGUAGE TemplateHaskell #-} - -module HsDev.Inspect.Types ( - Preloaded(..), preloadedId, preloadedMode, preloadedModule, asModule, toImport, preloaded, - InspectedPreloaded, - Environment, FixitiesTable, - Resolved(..), resolvedModule, resolvedSource, resolvedDefs, resolvedImports, resolvedExports, resolvedScope, resolvedFixities, - InspectedResolved, - - resolvedEnv, resolvedFixitiesTable, - - dropScope, noScope, withNoScope - ) where - -import Control.DeepSeq -import Control.Lens -import Data.Map (Map) -import qualified Data.Map as M -import Data.String -import Data.Text (Text) -import qualified Language.Haskell.Exts as H -import qualified Language.Haskell.Names as N -import qualified Language.Haskell.Names.GlobalSymbolTable as N - -import HsDev.Symbols.Types -import HsDev.Symbols.Parsed (Parsed, pos) - --- | Preloaded module with contents and extensions -data Preloaded = Preloaded { - _preloadedId :: ModuleId, - _preloadedMode :: H.ParseMode, - _preloadedModule :: H.Module H.SrcSpanInfo, - -- ^ Loaded module head without declarations - _preloaded :: Text } - -instance NFData Preloaded where - rnf (Preloaded mid _ _ cts) = rnf mid `seq` rnf cts - -asModule :: Lens' Preloaded Module -asModule = lens g' s' where - g' p = Module { - _moduleId = _preloadedId p, - _moduleDocs = Nothing, - _moduleImports = map toImport idecls, - _moduleExports = mempty, - _moduleFixities = mempty, - _moduleScope = mempty, - _moduleSource = Just $ fmap (N.Scoped N.None) $ _preloadedModule p } - where - H.Module _ _ _ idecls _ = _preloadedModule p - s' p m = p { - _preloadedId = _moduleId m, - _preloadedModule = maybe (_preloadedModule p) dropScope (_moduleSource m) } - -toImport :: H.ImportDecl H.SrcSpanInfo -> Import -toImport idecl@(H.ImportDecl _ mname qual _ _ _ alias _) = Import (idecl ^. pos) (fromString $ getModuleName mname) qual (fmap (fromString . getModuleName) alias) where - getModuleName (H.ModuleName _ s) = s - -type InspectedPreloaded = Inspected ModuleLocation ModuleTag Preloaded - --- | Symbols environment, used to resolve names in source -type Environment = N.Environment - --- | Fixities environment, needed to parse source -type FixitiesTable = Map Name H.Fixity - --- | Resolved module -data Resolved = Resolved { - _resolvedModule :: H.ModuleName (), - _resolvedSource :: Parsed, - _resolvedDefs :: [Symbol], - _resolvedImports :: [Import], - _resolvedExports :: [N.Symbol], - _resolvedScope :: N.Table, - _resolvedFixities :: [H.Fixity] } - -instance NFData Resolved where - rnf (Resolved _ _ defs imps _ _ _) = rnf defs `seq` rnf imps - --- | Like @InspectedModule@, but for @Resolved@ -type InspectedResolved = Inspected ModuleLocation ModuleTag Resolved - --- | Get environment for resolved module -resolvedEnv :: Resolved -> Environment -resolvedEnv r = M.singleton (_resolvedModule r) (_resolvedExports r) - --- | Get fixities table from resolved module -resolvedFixitiesTable :: Resolved -> FixitiesTable -resolvedFixitiesTable r = mconcat [M.singleton n f | f@(H.Fixity _ _ n) <- _resolvedFixities r] - --- | Drop extra info -dropScope :: Functor f => f (N.Scoped l) -> f l -dropScope = fmap (\(N.Scoped _ a) -> a) - --- | Empty scope info -noScope :: l -> N.Scoped l -noScope = N.Scoped N.None - --- | Set empty scope -withNoScope :: Functor f => f l -> f (N.Scoped l) -withNoScope = fmap noScope - -makeLenses ''Preloaded -makeLenses ''Resolved +{-# LANGUAGE TemplateHaskell #-} + +module HsDev.Inspect.Types ( + Preloaded(..), preloadedId, preloadedMode, preloadedModule, asModule, toImport, preloaded, + InspectedPreloaded, + Environment, FixitiesTable, + Resolved(..), resolvedModule, resolvedSource, resolvedDefs, resolvedImports, resolvedExports, resolvedScope, resolvedFixities, + InspectedResolved, + + resolvedEnv, resolvedFixitiesTable, + + dropScope, noScope, withNoScope + ) where + +import Control.DeepSeq +import Control.Lens +import Data.Map (Map) +import qualified Data.Map as M +import Data.String +import Data.Text (Text) +import qualified Language.Haskell.Exts as H +import qualified Language.Haskell.Names as N +import qualified Language.Haskell.Names.GlobalSymbolTable as N + +import HsDev.Symbols.Types +import HsDev.Symbols.Parsed (Parsed, pos) + +-- | Preloaded module with contents and extensions +data Preloaded = Preloaded { + _preloadedId :: ModuleId, + _preloadedMode :: H.ParseMode, + _preloadedModule :: H.Module H.SrcSpanInfo, + -- ^ Loaded module head without declarations + _preloaded :: Text } + +instance NFData Preloaded where + rnf (Preloaded mid _ _ cts) = rnf mid `seq` rnf cts + +asModule :: Lens' Preloaded Module +asModule = lens g' s' where + g' p = Module { + _moduleId = _preloadedId p, + _moduleDocs = Nothing, + _moduleImports = map toImport idecls, + _moduleExports = mempty, + _moduleFixities = mempty, + _moduleScope = mempty, + _moduleSource = Just $ fmap (N.Scoped N.None) $ _preloadedModule p } + where + H.Module _ _ _ idecls _ = _preloadedModule p + s' p m = p { + _preloadedId = _moduleId m, + _preloadedModule = maybe (_preloadedModule p) dropScope (_moduleSource m) } + +toImport :: H.ImportDecl H.SrcSpanInfo -> Import +toImport idecl@(H.ImportDecl _ mname qual _ _ _ alias _) = Import (idecl ^. pos) (fromString $ getModuleName mname) qual (fmap (fromString . getModuleName) alias) where + getModuleName (H.ModuleName _ s) = s + +type InspectedPreloaded = Inspected ModuleLocation ModuleTag Preloaded + +-- | Symbols environment, used to resolve names in source +type Environment = N.Environment + +-- | Fixities environment, needed to parse source +type FixitiesTable = Map Name H.Fixity + +-- | Resolved module +data Resolved = Resolved { + _resolvedModule :: H.ModuleName (), + _resolvedSource :: Parsed, + _resolvedDefs :: [Symbol], + _resolvedImports :: [Import], + _resolvedExports :: [N.Symbol], + _resolvedScope :: N.Table, + _resolvedFixities :: [H.Fixity] } + +instance NFData Resolved where + rnf (Resolved _ _ defs imps _ _ _) = rnf defs `seq` rnf imps + +-- | Like @InspectedModule@, but for @Resolved@ +type InspectedResolved = Inspected ModuleLocation ModuleTag Resolved + +-- | Get environment for resolved module +resolvedEnv :: Resolved -> Environment +resolvedEnv r = M.singleton (_resolvedModule r) (_resolvedExports r) + +-- | Get fixities table from resolved module +resolvedFixitiesTable :: Resolved -> FixitiesTable +resolvedFixitiesTable r = mconcat [M.singleton n f | f@(H.Fixity _ _ n) <- _resolvedFixities r] + +-- | Drop extra info +dropScope :: Functor f => f (N.Scoped l) -> f l +dropScope = fmap (\(N.Scoped _ a) -> a) + +-- | Empty scope info +noScope :: l -> N.Scoped l +noScope = N.Scoped N.None + +-- | Set empty scope +withNoScope :: Functor f => f l -> f (N.Scoped l) +withNoScope = fmap noScope + +makeLenses ''Preloaded +makeLenses ''Resolved diff --git a/src/HsDev/PackageDb.hs b/src/HsDev/PackageDb.hs --- a/src/HsDev/PackageDb.hs +++ b/src/HsDev/PackageDb.hs @@ -1,70 +1,70 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HsDev.PackageDb ( - module HsDev.PackageDb.Types, - - packageDbPath, readPackageDb - ) where - -import Control.Lens -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe) -import Data.Text (pack, unpack) -import Data.Traversable -import Distribution.InstalledPackageInfo -import Distribution.Package -import Distribution.Text (disp) -import System.FilePath - -import GHC.Paths - -import HsDev.PackageDb.Types -import HsDev.Error -import HsDev.Symbols.Location -import HsDev.Tools.Base -import HsDev.Util (directoryContents, readFileUtf8) -import System.Directory.Paths - --- | Get path to package-db -packageDbPath :: PackageDb -> IO Path -packageDbPath GlobalDb = do - out <- fmap lines $ runTool_ ghc_pkg ["list", "--global"] - case out of - (fpath:_) -> return $ fromFilePath $ normalise fpath - [] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to global package-db" -packageDbPath UserDb = do - out <- fmap lines $ runTool_ ghc_pkg ["list", "--user"] - case out of - (fpath:_) -> return $ fromFilePath $ normalise fpath - -- Bailing on the user package db if there isn't one doesn't seem quite correct. 'stack' and 'cabal' - -- can report no path... - -- [] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to user package db" - -- Report an empty path instead. - [] -> return $ fromFilePath "" -packageDbPath (PackageDb fpath) = return fpath - --- | Read package-db conf files -readPackageDb :: PackageDb -> IO (Map ModulePackage [ModuleLocation]) -readPackageDb pdb = do - p <- packageDbPath pdb - mlibdir <- fmap (listToMaybe . lines) $ runTool_ ghc ["--print-libdir"] - confs <- fmap (filter isConf) $ directoryContents (p ^. path) - fmap M.unions $ forM confs $ \conf -> do - cts <- readFileUtf8 conf - case parseInstalledPackageInfo (unpack cts) of - ParseFailed _ -> return M.empty -- FIXME: Should log as warning - ParseOk _ res -> mapM (mapM canonicalize) $ - over (each . each . moduleInstallDirs . each) (subst mlibdir) $ listMods res - where - isConf f = takeExtension f == ".conf" - listMods pinfo = M.singleton pname pmods where - pname = ModulePackage - (pack . show . disp . pkgName $ sourcePackageId pinfo) - (pack . show . disp . pkgVersion $ sourcePackageId pinfo) - pmods = [InstalledModule (map fromFilePath $ libraryDirs pinfo) pname nm exposed' | (nm, exposed') <- names] - names = zip (map (pack . show . disp) (exposedModules pinfo)) (repeat True) ++ zip (map (pack . show . disp) (hiddenModules pinfo)) (repeat False) - subst Nothing f = f - subst (Just libdir') f = case splitPaths f of - ("$topdir":rest) -> joinPaths (fromFilePath libdir' : rest) - _ -> f +{-# LANGUAGE OverloadedStrings #-} + +module HsDev.PackageDb ( + module HsDev.PackageDb.Types, + + packageDbPath, readPackageDb + ) where + +import Control.Lens +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (listToMaybe) +import Data.Text (pack, unpack) +import Data.Traversable +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Text (disp) +import System.FilePath + +import GHC.Paths + +import HsDev.PackageDb.Types +import HsDev.Error +import HsDev.Symbols.Location +import HsDev.Tools.Base +import HsDev.Util (directoryContents, readFileUtf8) +import System.Directory.Paths + +-- | Get path to package-db +packageDbPath :: PackageDb -> IO Path +packageDbPath GlobalDb = do + out <- fmap lines $ runTool_ ghc_pkg ["list", "--global"] + case out of + (fpath:_) -> return $ fromFilePath $ normalise fpath + [] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to global package-db" +packageDbPath UserDb = do + out <- fmap lines $ runTool_ ghc_pkg ["list", "--user"] + case out of + (fpath:_) -> return $ fromFilePath $ normalise fpath + -- Bailing on the user package db if there isn't one doesn't seem quite correct. 'stack' and 'cabal' + -- can report no path... + -- [] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to user package db" + -- Report an empty path instead. + [] -> return $ fromFilePath "" +packageDbPath (PackageDb fpath) = return fpath + +-- | Read package-db conf files +readPackageDb :: PackageDb -> IO (Map ModulePackage [ModuleLocation]) +readPackageDb pdb = do + p <- packageDbPath pdb + mlibdir <- fmap (listToMaybe . lines) $ runTool_ ghc ["--print-libdir"] + confs <- fmap (filter isConf) $ directoryContents (p ^. path) + fmap M.unions $ forM confs $ \conf -> do + cts <- readFileUtf8 conf + case parseInstalledPackageInfo (unpack cts) of + ParseFailed _ -> return M.empty -- FIXME: Should log as warning + ParseOk _ res -> mapM (mapM canonicalize) $ + over (each . each . moduleInstallDirs . each) (subst mlibdir) $ listMods res + where + isConf f = takeExtension f == ".conf" + listMods pinfo = M.singleton pname pmods where + pname = ModulePackage + (pack . show . disp . pkgName $ sourcePackageId pinfo) + (pack . show . disp . pkgVersion $ sourcePackageId pinfo) + pmods = [InstalledModule (map fromFilePath $ libraryDirs pinfo) pname nm exposed' | (nm, exposed') <- names] + names = zip (map (pack . show . disp) (exposedModules pinfo)) (repeat True) ++ zip (map (pack . show . disp) (hiddenModules pinfo)) (repeat False) + subst Nothing f = f + subst (Just libdir') f = case splitPaths f of + ("$topdir":rest) -> joinPaths (fromFilePath libdir' : rest) + _ -> f diff --git a/src/HsDev/PackageDb/Types.hs b/src/HsDev/PackageDb/Types.hs --- a/src/HsDev/PackageDb/Types.hs +++ b/src/HsDev/PackageDb/Types.hs @@ -1,136 +1,136 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} - -module HsDev.PackageDb.Types ( - PackageDb(..), packageDb, - PackageDbStack(..), packageDbStack, mkPackageDbStack, - globalDb, userDb, fromPackageDbs, - topPackageDb, packageDbs, packageDbStacks, - isSubStack, - - packageDbOpt, packageDbStackOpts - ) where - -import Control.Applicative -import Control.Monad (guard) -import Control.Lens (makeLenses, each, (^.)) -import Control.DeepSeq (NFData(..)) -import Data.Aeson -import Data.List (tails, isSuffixOf, intercalate) -import qualified Data.Text as T -import Data.String -import Text.Format - -import System.Directory.Paths -import HsDev.Display - -data PackageDb = GlobalDb | UserDb | PackageDb { _packageDb :: Path } deriving (Eq, Ord) - -makeLenses ''PackageDb - -instance NFData PackageDb where - rnf GlobalDb = () - rnf UserDb = () - rnf (PackageDb p) = rnf p - -instance Show PackageDb where - show GlobalDb = "global-db" - show UserDb = "user-db" - show (PackageDb p) = "package-db:" ++ p ^. path - -instance Display PackageDb where - display GlobalDb = "global-db" - display UserDb = "user-db" - display (PackageDb p) = "package-db " ++ display p - displayType _ = "package-db" - -instance Formattable PackageDb where - formattable = formattable . display - -instance ToJSON PackageDb where - toJSON GlobalDb = "global-db" - toJSON UserDb = "user-db" - toJSON (PackageDb p) = fromString $ "package-db:" ++ p ^. path - -instance FromJSON PackageDb where - parseJSON v = globalP v <|> userP v <|> dbP v where - globalP = withText "global-db" (\s -> guard (s == "global-db") >> return GlobalDb) - userP = withText "user-db" (\s -> guard (s == "user-db") >> return UserDb) - dbP = withText "package-db" $ \s -> case T.stripPrefix "package-db:" s of - Nothing -> fail ("Can't parse package-db: " ++ T.unpack s) - Just p' -> return $ PackageDb p' - -instance Paths PackageDb where - paths _ GlobalDb = pure GlobalDb - paths _ UserDb = pure UserDb - paths f (PackageDb p) = PackageDb <$> paths f p - --- | Stack of PackageDb in reverse order -newtype PackageDbStack = PackageDbStack { _packageDbStack :: [PackageDb] } deriving (Eq, Ord, Show) - -makeLenses ''PackageDbStack - -instance NFData PackageDbStack where - rnf (PackageDbStack ps) = rnf ps - -instance Display PackageDbStack where - display = intercalate "/" . map display . packageDbs - displayType _ = "package-db-stack" - -instance Formattable PackageDbStack where - formattable = formattable . display - -instance ToJSON PackageDbStack where - toJSON (PackageDbStack ps) = toJSON ps - -instance FromJSON PackageDbStack where - parseJSON = fmap PackageDbStack . parseJSON - -instance Paths PackageDbStack where - paths f (PackageDbStack ps) = PackageDbStack <$> (each . paths) f ps - --- | Make @PackageDbStack@ from list of @PackageDb@ -mkPackageDbStack :: [PackageDb] -> PackageDbStack -mkPackageDbStack = PackageDbStack . reverse . dropWhile (== GlobalDb) - --- | Global db stack -globalDb :: PackageDbStack -globalDb = PackageDbStack [] - --- | User db stack -userDb :: PackageDbStack -userDb = PackageDbStack [UserDb] - --- | Make package-db stack from paths -fromPackageDbs :: [Path] -> PackageDbStack -fromPackageDbs = PackageDbStack . map PackageDb . reverse - --- | Get top package-db for package-db stack -topPackageDb :: PackageDbStack -> PackageDb -topPackageDb (PackageDbStack []) = GlobalDb -topPackageDb (PackageDbStack (d:_)) = d - --- | Get list of package-db in stack, adds additional global-db at bottom -packageDbs :: PackageDbStack -> [PackageDb] -packageDbs = (GlobalDb :) . reverse . _packageDbStack - --- | Get stacks for each package-db in stack -packageDbStacks :: PackageDbStack -> [PackageDbStack] -packageDbStacks = map PackageDbStack . tails . _packageDbStack - --- | Is one package-db stack substack of another -isSubStack :: PackageDbStack -> PackageDbStack -> Bool -isSubStack (PackageDbStack l) (PackageDbStack r) = l `isSuffixOf` r - --- | Get ghc options for package-db -packageDbOpt :: PackageDb -> String -packageDbOpt GlobalDb = "-global-package-db" -packageDbOpt UserDb = "-user-package-db" -packageDbOpt (PackageDb p) = "-package-db " ++ p ^. path - --- | Get ghc options for package-db stack -packageDbStackOpts :: PackageDbStack -> [String] -packageDbStackOpts (PackageDbStack ps) - | "-user-package-db" `elem` opts' = opts' - | otherwise = "-no-user-package-db" : opts' - where - opts' = map packageDbOpt (reverse ps) +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} + +module HsDev.PackageDb.Types ( + PackageDb(..), packageDb, + PackageDbStack(..), packageDbStack, mkPackageDbStack, + globalDb, userDb, fromPackageDbs, + topPackageDb, packageDbs, packageDbStacks, + isSubStack, + + packageDbOpt, packageDbStackOpts + ) where + +import Control.Applicative +import Control.Monad (guard) +import Control.Lens (makeLenses, each, (^.)) +import Control.DeepSeq (NFData(..)) +import Data.Aeson +import Data.List (tails, isSuffixOf, intercalate) +import qualified Data.Text as T +import Data.String +import Text.Format + +import System.Directory.Paths +import HsDev.Display + +data PackageDb = GlobalDb | UserDb | PackageDb { _packageDb :: Path } deriving (Eq, Ord) + +makeLenses ''PackageDb + +instance NFData PackageDb where + rnf GlobalDb = () + rnf UserDb = () + rnf (PackageDb p) = rnf p + +instance Show PackageDb where + show GlobalDb = "global-db" + show UserDb = "user-db" + show (PackageDb p) = "package-db:" ++ p ^. path + +instance Display PackageDb where + display GlobalDb = "global-db" + display UserDb = "user-db" + display (PackageDb p) = "package-db " ++ display p + displayType _ = "package-db" + +instance Formattable PackageDb where + formattable = formattable . display + +instance ToJSON PackageDb where + toJSON GlobalDb = "global-db" + toJSON UserDb = "user-db" + toJSON (PackageDb p) = fromString $ "package-db:" ++ p ^. path + +instance FromJSON PackageDb where + parseJSON v = globalP v <|> userP v <|> dbP v where + globalP = withText "global-db" (\s -> guard (s == "global-db") >> return GlobalDb) + userP = withText "user-db" (\s -> guard (s == "user-db") >> return UserDb) + dbP = withText "package-db" $ \s -> case T.stripPrefix "package-db:" s of + Nothing -> fail ("Can't parse package-db: " ++ T.unpack s) + Just p' -> return $ PackageDb p' + +instance Paths PackageDb where + paths _ GlobalDb = pure GlobalDb + paths _ UserDb = pure UserDb + paths f (PackageDb p) = PackageDb <$> paths f p + +-- | Stack of PackageDb in reverse order +newtype PackageDbStack = PackageDbStack { _packageDbStack :: [PackageDb] } deriving (Eq, Ord, Show) + +makeLenses ''PackageDbStack + +instance NFData PackageDbStack where + rnf (PackageDbStack ps) = rnf ps + +instance Display PackageDbStack where + display = intercalate "/" . map display . packageDbs + displayType _ = "package-db-stack" + +instance Formattable PackageDbStack where + formattable = formattable . display + +instance ToJSON PackageDbStack where + toJSON (PackageDbStack ps) = toJSON ps + +instance FromJSON PackageDbStack where + parseJSON = fmap PackageDbStack . parseJSON + +instance Paths PackageDbStack where + paths f (PackageDbStack ps) = PackageDbStack <$> (each . paths) f ps + +-- | Make @PackageDbStack@ from list of @PackageDb@ +mkPackageDbStack :: [PackageDb] -> PackageDbStack +mkPackageDbStack = PackageDbStack . reverse . dropWhile (== GlobalDb) + +-- | Global db stack +globalDb :: PackageDbStack +globalDb = PackageDbStack [] + +-- | User db stack +userDb :: PackageDbStack +userDb = PackageDbStack [UserDb] + +-- | Make package-db stack from paths +fromPackageDbs :: [Path] -> PackageDbStack +fromPackageDbs = PackageDbStack . map PackageDb . reverse + +-- | Get top package-db for package-db stack +topPackageDb :: PackageDbStack -> PackageDb +topPackageDb (PackageDbStack []) = GlobalDb +topPackageDb (PackageDbStack (d:_)) = d + +-- | Get list of package-db in stack, adds additional global-db at bottom +packageDbs :: PackageDbStack -> [PackageDb] +packageDbs = (GlobalDb :) . reverse . _packageDbStack + +-- | Get stacks for each package-db in stack +packageDbStacks :: PackageDbStack -> [PackageDbStack] +packageDbStacks = map PackageDbStack . tails . _packageDbStack + +-- | Is one package-db stack substack of another +isSubStack :: PackageDbStack -> PackageDbStack -> Bool +isSubStack (PackageDbStack l) (PackageDbStack r) = l `isSuffixOf` r + +-- | Get ghc options for package-db +packageDbOpt :: PackageDb -> String +packageDbOpt GlobalDb = "-global-package-db" +packageDbOpt UserDb = "-user-package-db" +packageDbOpt (PackageDb p) = "-package-db " ++ p ^. path + +-- | Get ghc options for package-db stack +packageDbStackOpts :: PackageDbStack -> [String] +packageDbStackOpts (PackageDbStack ps) + | "-user-package-db" `elem` opts' = opts' + | otherwise = "-no-user-package-db" : opts' + where + opts' = map packageDbOpt (reverse ps) diff --git a/src/HsDev/Project.hs b/src/HsDev/Project.hs --- a/src/HsDev/Project.hs +++ b/src/HsDev/Project.hs @@ -1,198 +1,198 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} - -module HsDev.Project ( - module HsDev.Project.Types, - - infoSourceDirsDef, targetFiles, projectTargetFiles, - analyzeCabal, - readProject, loadProject, - withExtensions, - fileInTarget, fileTarget, fileTargets, findSourceDir, sourceDirs, - targetOpts, - - -- * Helpers - showExtension, flagExtension, extensionFlag, - extensionsOpts - ) where - -import Control.Arrow -import Control.Lens hiding ((.=), (%=), (<.>), set') -import Control.Monad.Except -import Control.Monad.Loops -import Data.List -import Data.Maybe -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T (intercalate) -import Data.Text.Lens (unpacked) -import Distribution.Compiler (CompilerFlavor(GHC)) -import qualified Distribution.Package as P -import qualified Distribution.PackageDescription as PD -import qualified Distribution.ModuleName as PD (toFilePath) -import Distribution.ModuleName (components) -import Distribution.Text (display) -import Language.Haskell.Extension -import System.FilePath -import System.Log.Simple hiding (Level(..)) -import qualified System.Log.Simple as Log (Level(..)) -import Text.Format - -import System.Directory.Paths -import HsDev.Project.Compat -import HsDev.Project.Types -import HsDev.Error -import HsDev.Util - --- | infoSourceDirs lens with default -infoSourceDirsDef :: Lens' Info [Path] -infoSourceDirsDef = lens get' set' where - get' i = case _infoSourceDirs i of - [] -> ["."] - dirs -> dirs - set' i ["."] = i { _infoSourceDirs = [] } - set' i dirs = i { _infoSourceDirs = dirs } - --- | Get all source file names of target without prepending them with source-dirs -targetFiles :: Target t => t -> [Path] -targetFiles target' = concat [ - maybeToList (targetMain target'), - map toFile $ targetModules target', - map toFile $ target' ^.. buildInfo . infoOtherModules . each] - where - toFile ps = fromFilePath (joinPath (ps ^.. each . unpacked) <.> "hs") - --- | Get all source file names relative to project root -projectTargetFiles :: (MonadLog m, Target t) => Project -> t -> m [Path] -projectTargetFiles proj t = do - liftM concat $ forM files $ \file' -> do - candidate <- liftIO $ firstM (fileExists . absolutise (proj ^. projectPath)) [subPath srcDir file' | srcDir <- srcDirs] - case candidate of - Nothing -> do - sendLog Log.Warning $ "Unable to locate source file: {} in source-dirs: {}" ~~ file' ~~ (T.intercalate ", " srcDirs) - return [] - Just file'' -> return [normPath file''] - where - files = targetFiles t - srcDirs = t ^.. buildInfo . infoSourceDirsDef . each - --- | Analyze cabal file -analyzeCabal :: String -> Either String ProjectDescription -analyzeCabal source = case liftM flattenDescr $ parsePackageDesc source of - Right r -> Right ProjectDescription { - _projectVersion = pack $ showVer $ P.pkgVersion $ PD.package r, - _projectLibrary = fmap toLibrary $ PD.library r, - _projectExecutables = fmap toExecutable $ PD.executables r, - _projectTests = fmap toTest $ PD.testSuites r } - Left e -> Left $ "Parse failed: " ++ e - where - toLibrary lib = Library (map (map pack . components) $ PD.exposedModules lib) (toInfo $ PD.libBuildInfo lib) - toExecutable exe = Executable (componentName $ PD.exeName exe) (fromFilePath $ PD.modulePath exe) (toInfo $ PD.buildInfo exe) - toTest test = Test (componentName $ PD.testName test) (testSuiteEnabled test) (fmap fromFilePath mainFile) (toInfo $ PD.testBuildInfo test) where - mainFile = case PD.testInterface test of - PD.TestSuiteExeV10 _ fpath -> Just fpath - PD.TestSuiteLibV09 _ mname -> Just $ PD.toFilePath mname - _ -> Nothing - toInfo info = Info { - _infoDepends = map pkgName (PD.targetBuildDepends info), - _infoLanguage = PD.defaultLanguage info, - _infoExtensions = PD.defaultExtensions info ++ PD.otherExtensions info ++ PD.oldExtensions info, - _infoGHCOptions = maybe [] (map pack) $ lookup GHC (PD.options info), - _infoSourceDirs = map pack $ PD.hsSourceDirs info, - _infoOtherModules = map (map pack . components) (PD.otherModules info) } - - pkgName :: P.Dependency -> Text - pkgName (P.Dependency dep _) = pack $ P.unPackageName dep - - flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription - flattenDescr gpkg = pkg { - PD.library = flip fmap mlib $ flattenCondTree - (insertInfo PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })), - PD.executables = flip fmap mexes $ - second (flattenCondTree (insertInfo PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>> - (\(n, e) -> e { PD.exeName = n }), - PD.testSuites = flip fmap mtests $ - second (flattenCondTree (insertInfo PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>> - (\(n, t) -> t { PD.testName = n }) } - where - pkg = PD.packageDescription gpkg - mlib = PD.condLibrary gpkg - mexes = PD.condExecutables gpkg - mtests = PD.condTestSuites gpkg - - insertInfo :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a - insertInfo f s deps' x = s ((f x) { PD.targetBuildDepends = deps' }) x - --- | Read project info from .cabal -readProject :: FilePath -> IO Project -readProject file' = do - source <- readFile file' - length source `seq` either (hsdevError . InspectCabalError file') (return . mkProject) $ analyzeCabal source - where - mkProject desc = (project file') { - _projectDescription = Just desc } - --- | Load project description -loadProject :: Project -> IO Project -loadProject p - | isJust (_projectDescription p) = return p - | otherwise = do - p' <- readProject (_projectCabal p ^. path) - return $ set projectBuildTool (view projectBuildTool p) p' - --- | Extensions for target -withExtensions :: a -> Info -> Extensions a -withExtensions x i = Extensions { - _extensions = _infoExtensions i, - _ghcOptions = _infoGHCOptions i, - _entity = x } - --- | Check if source related to target, source must be relative to project directory -fileInTarget :: Path -> Info -> Bool -fileInTarget src info = any (`isParent` src) $ view infoSourceDirsDef info - --- | Get first target for source file -fileTarget :: Project -> Path -> Maybe Info -fileTarget p f = listToMaybe $ fileTargets p f - --- | Get possible targets for source file --- There can be many candidates in case of module related to several executables or tests -fileTargets :: Project -> Path -> [Info] -fileTargets p f = case filter ((`isParent` f') . view executablePath) exes of - [] -> filter (f' `fileInTarget`) (p ^.. projectDescription . _Just . infos) - exes' -> map _executableBuildInfo exes' - where - f' = relPathTo (_projectPath p) f - exes = p ^. projectDescription . _Just . projectExecutables - --- | Finds source dir file belongs to -findSourceDir :: Project -> Path -> Maybe (Extensions Path) -findSourceDir p f = do - info <- listToMaybe $ fileTargets p f - fmap (`withExtensions` info) $ listToMaybe $ filter (`isParent` f) $ map (_projectPath p `subPath`) (info ^. infoSourceDirsDef) - --- | Returns source dirs for library, executables and tests -sourceDirs :: ProjectDescription -> [Extensions Path] -sourceDirs = ordNub . concatMap dirs . toListOf infos where - dirs i = map (`withExtensions` i) (i ^. infoSourceDirsDef) - --- | Get options for specific target -targetOpts :: Info -> [String] -targetOpts info' = concat [ - ["-i" ++ unpack s | s <- _infoSourceDirs info'], - extensionsOpts $ withExtensions () info', - ["-package " ++ unpack p | p <- _infoDepends info']] - --- | Extension as flag name -showExtension :: Extension -> String -showExtension = display - --- | Convert -Xext to ext -flagExtension :: String -> Maybe String -flagExtension = stripPrefix "-X" - --- | Convert ext to -Xext -extensionFlag :: String -> String -extensionFlag = ("-X" ++) - --- | Extensions as opts to GHC -extensionsOpts :: Extensions a -> [String] -extensionsOpts e = map (extensionFlag . showExtension) (_extensions e) ++ map unpack (_ghcOptions e) +{-# LANGUAGE OverloadedStrings, CPP #-} + +module HsDev.Project ( + module HsDev.Project.Types, + + infoSourceDirsDef, targetFiles, projectTargetFiles, + analyzeCabal, + readProject, loadProject, + withExtensions, + fileInTarget, fileTarget, fileTargets, findSourceDir, sourceDirs, + targetOpts, + + -- * Helpers + showExtension, flagExtension, extensionFlag, + extensionsOpts + ) where + +import Control.Arrow +import Control.Lens hiding ((.=), (%=), (<.>), set') +import Control.Monad.Except +import Control.Monad.Loops +import Data.List +import Data.Maybe +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T (intercalate) +import Data.Text.Lens (unpacked) +import Distribution.Compiler (CompilerFlavor(GHC)) +import qualified Distribution.Package as P +import qualified Distribution.PackageDescription as PD +import qualified Distribution.ModuleName as PD (toFilePath) +import Distribution.ModuleName (components) +import Distribution.Text (display) +import Language.Haskell.Extension +import System.FilePath +import System.Log.Simple hiding (Level(..)) +import qualified System.Log.Simple as Log (Level(..)) +import Text.Format + +import System.Directory.Paths +import HsDev.Project.Compat +import HsDev.Project.Types +import HsDev.Error +import HsDev.Util + +-- | infoSourceDirs lens with default +infoSourceDirsDef :: Lens' Info [Path] +infoSourceDirsDef = lens get' set' where + get' i = case _infoSourceDirs i of + [] -> ["."] + dirs -> dirs + set' i ["."] = i { _infoSourceDirs = [] } + set' i dirs = i { _infoSourceDirs = dirs } + +-- | Get all source file names of target without prepending them with source-dirs +targetFiles :: Target t => t -> [Path] +targetFiles target' = concat [ + maybeToList (targetMain target'), + map toFile $ targetModules target', + map toFile $ target' ^.. buildInfo . infoOtherModules . each] + where + toFile ps = fromFilePath (joinPath (ps ^.. each . unpacked) <.> "hs") + +-- | Get all source file names relative to project root +projectTargetFiles :: (MonadLog m, Target t) => Project -> t -> m [Path] +projectTargetFiles proj t = do + liftM concat $ forM files $ \file' -> do + candidate <- liftIO $ firstM (fileExists . absolutise (proj ^. projectPath)) [subPath srcDir file' | srcDir <- srcDirs] + case candidate of + Nothing -> do + sendLog Log.Warning $ "Unable to locate source file: {} in source-dirs: {}" ~~ file' ~~ (T.intercalate ", " srcDirs) + return [] + Just file'' -> return [normPath file''] + where + files = targetFiles t + srcDirs = t ^.. buildInfo . infoSourceDirsDef . each + +-- | Analyze cabal file +analyzeCabal :: String -> Either String ProjectDescription +analyzeCabal source = case liftM flattenDescr $ parsePackageDesc source of + Right r -> Right ProjectDescription { + _projectVersion = pack $ showVer $ P.pkgVersion $ PD.package r, + _projectLibrary = fmap toLibrary $ PD.library r, + _projectExecutables = fmap toExecutable $ PD.executables r, + _projectTests = fmap toTest $ PD.testSuites r } + Left e -> Left $ "Parse failed: " ++ e + where + toLibrary lib = Library (map (map pack . components) $ PD.exposedModules lib) (toInfo $ PD.libBuildInfo lib) + toExecutable exe = Executable (componentName $ PD.exeName exe) (fromFilePath $ PD.modulePath exe) (toInfo $ PD.buildInfo exe) + toTest test = Test (componentName $ PD.testName test) (testSuiteEnabled test) (fmap fromFilePath mainFile) (toInfo $ PD.testBuildInfo test) where + mainFile = case PD.testInterface test of + PD.TestSuiteExeV10 _ fpath -> Just fpath + PD.TestSuiteLibV09 _ mname -> Just $ PD.toFilePath mname + _ -> Nothing + toInfo info = Info { + _infoDepends = map pkgName (PD.targetBuildDepends info), + _infoLanguage = PD.defaultLanguage info, + _infoExtensions = PD.defaultExtensions info ++ PD.otherExtensions info ++ PD.oldExtensions info, + _infoGHCOptions = maybe [] (map pack) $ lookup GHC (PD.options info), + _infoSourceDirs = map pack $ PD.hsSourceDirs info, + _infoOtherModules = map (map pack . components) (PD.otherModules info) } + + pkgName :: P.Dependency -> Text + pkgName (P.Dependency dep _) = pack $ P.unPackageName dep + + flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription + flattenDescr gpkg = pkg { + PD.library = flip fmap mlib $ flattenCondTree + (insertInfo PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })), + PD.executables = flip fmap mexes $ + second (flattenCondTree (insertInfo PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>> + (\(n, e) -> e { PD.exeName = n }), + PD.testSuites = flip fmap mtests $ + second (flattenCondTree (insertInfo PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>> + (\(n, t) -> t { PD.testName = n }) } + where + pkg = PD.packageDescription gpkg + mlib = PD.condLibrary gpkg + mexes = PD.condExecutables gpkg + mtests = PD.condTestSuites gpkg + + insertInfo :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a + insertInfo f s deps' x = s ((f x) { PD.targetBuildDepends = deps' }) x + +-- | Read project info from .cabal +readProject :: FilePath -> IO Project +readProject file' = do + source <- readFile file' + length source `seq` either (hsdevError . InspectCabalError file') (return . mkProject) $ analyzeCabal source + where + mkProject desc = (project file') { + _projectDescription = Just desc } + +-- | Load project description +loadProject :: Project -> IO Project +loadProject p + | isJust (_projectDescription p) = return p + | otherwise = do + p' <- readProject (_projectCabal p ^. path) + return $ set projectBuildTool (view projectBuildTool p) p' + +-- | Extensions for target +withExtensions :: a -> Info -> Extensions a +withExtensions x i = Extensions { + _extensions = _infoExtensions i, + _ghcOptions = _infoGHCOptions i, + _entity = x } + +-- | Check if source related to target, source must be relative to project directory +fileInTarget :: Path -> Info -> Bool +fileInTarget src info = any (`isParent` src) $ view infoSourceDirsDef info + +-- | Get first target for source file +fileTarget :: Project -> Path -> Maybe Info +fileTarget p f = listToMaybe $ fileTargets p f + +-- | Get possible targets for source file +-- There can be many candidates in case of module related to several executables or tests +fileTargets :: Project -> Path -> [Info] +fileTargets p f = case filter ((`isParent` f') . view executablePath) exes of + [] -> filter (f' `fileInTarget`) (p ^.. projectDescription . _Just . infos) + exes' -> map _executableBuildInfo exes' + where + f' = relPathTo (_projectPath p) f + exes = p ^. projectDescription . _Just . projectExecutables + +-- | Finds source dir file belongs to +findSourceDir :: Project -> Path -> Maybe (Extensions Path) +findSourceDir p f = do + info <- listToMaybe $ fileTargets p f + fmap (`withExtensions` info) $ listToMaybe $ filter (`isParent` f) $ map (_projectPath p `subPath`) (info ^. infoSourceDirsDef) + +-- | Returns source dirs for library, executables and tests +sourceDirs :: ProjectDescription -> [Extensions Path] +sourceDirs = ordNub . concatMap dirs . toListOf infos where + dirs i = map (`withExtensions` i) (i ^. infoSourceDirsDef) + +-- | Get options for specific target +targetOpts :: Info -> [String] +targetOpts info' = concat [ + ["-i" ++ unpack s | s <- _infoSourceDirs info'], + extensionsOpts $ withExtensions () info', + ["-package " ++ unpack p | p <- _infoDepends info']] + +-- | Extension as flag name +showExtension :: Extension -> String +showExtension = display + +-- | Convert -Xext to ext +flagExtension :: String -> Maybe String +flagExtension = stripPrefix "-X" + +-- | Convert ext to -Xext +extensionFlag :: String -> String +extensionFlag = ("-X" ++) + +-- | Extensions as opts to GHC +extensionsOpts :: Extensions a -> [String] +extensionsOpts e = map (extensionFlag . showExtension) (_extensions e) ++ map unpack (_ghcOptions e) diff --git a/src/HsDev/Project/Compat.hs b/src/HsDev/Project/Compat.hs --- a/src/HsDev/Project/Compat.hs +++ b/src/HsDev/Project/Compat.hs @@ -1,79 +1,79 @@ -{-# LANGUAGE CPP #-} - -module HsDev.Project.Compat ( - showVer, componentName, testSuiteEnabled, - flattenCondTree, - parsePackageDesc - ) where - -import Data.Maybe (maybeToList) -import Data.Text (Text, pack) -import qualified Distribution.PackageDescription as PD -import Distribution.Version (Version) -import Distribution.Text (display) - -#if MIN_VERSION_Cabal(2,2,0) -import Distribution.PackageDescription.Parsec -import Distribution.Parsec.Common (showPError) -import qualified Data.ByteString.Char8 as C8 (pack) -#else -import Distribution.PackageDescription.Parse -#endif - -#if MIN_VERSION_Cabal(2,0,0) -import Distribution.Types.CondTree -#else -import Distribution.PackageDescription (CondTree(..)) -#endif - -#if MIN_VERSION_Cabal(2,0,0) -import Distribution.Types.UnqualComponentName -#else -import Data.Version (showVersion) -#endif - -showVer :: Version -> String -#if MIN_VERSION_Cabal(2,0,0) -showVer = display -#else -showVer = showVersion -#endif - -#if MIN_VERSION_Cabal(2,0,0) -componentName :: UnqualComponentName -> Text -componentName = pack . unUnqualComponentName -#else -componentName :: String -> Text -componentName = pack -#endif - -testSuiteEnabled :: PD.TestSuite -> Bool -#if MIN_VERSION_Cabal(2,0,0) -testSuiteEnabled _ = True -#else -testSuiteEnabled = PD.testEnabled -#endif - -flattenCondTree :: Monoid a => (c -> a -> a) -> CondTree v c a -> a -flattenCondTree f (PD.CondNode x cs cmps) = f cs x `mappend` mconcat (concatMap flattenBranch cmps) where -#if MIN_VERSION_Cabal(2,0,0) - flattenBranch (CondBranch _ t mb) = go t mb -#else - flattenBranch (_, t, mb) = go t mb -#endif - go t mb = flattenCondTree f t : map (flattenCondTree f) (maybeToList mb) - -parsePackageDesc :: String -> Either String PD.GenericPackageDescription -#if MIN_VERSION_Cabal(2,2,0) -parsePackageDesc s = case snd . runParseResult . parseGenericPackageDescription . C8.pack $ s of - Left (_, errs) -> Left $ unlines $ map (showPError "cabal") errs - Right r -> Right r -#elif MIN_VERSION_Cabal(2,0,0) -parsePackageDesc s = case parseGenericPackageDescription s of - ParseOk _ r -> Right r - ParseFailed e -> Left $ show e -#else -parsePackageDesc s = case parsePackageDescription s of - ParseOk _ r -> Right r - ParseFailed e -> Left $ show e -#endif +{-# LANGUAGE CPP #-} + +module HsDev.Project.Compat ( + showVer, componentName, testSuiteEnabled, + flattenCondTree, + parsePackageDesc + ) where + +import Data.Maybe (maybeToList) +import Data.Text (Text, pack) +import qualified Distribution.PackageDescription as PD +import Distribution.Version (Version) +import Distribution.Text (display) + +#if MIN_VERSION_Cabal(2,2,0) +import Distribution.PackageDescription.Parsec +import Distribution.Parsec.Common (showPError) +import qualified Data.ByteString.Char8 as C8 (pack) +#else +import Distribution.PackageDescription.Parse +#endif + +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Types.CondTree +#else +import Distribution.PackageDescription (CondTree(..)) +#endif + +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Types.UnqualComponentName +#else +import Data.Version (showVersion) +#endif + +showVer :: Version -> String +#if MIN_VERSION_Cabal(2,0,0) +showVer = display +#else +showVer = showVersion +#endif + +#if MIN_VERSION_Cabal(2,0,0) +componentName :: UnqualComponentName -> Text +componentName = pack . unUnqualComponentName +#else +componentName :: String -> Text +componentName = pack +#endif + +testSuiteEnabled :: PD.TestSuite -> Bool +#if MIN_VERSION_Cabal(2,0,0) +testSuiteEnabled _ = True +#else +testSuiteEnabled = PD.testEnabled +#endif + +flattenCondTree :: Monoid a => (c -> a -> a) -> CondTree v c a -> a +flattenCondTree f (PD.CondNode x cs cmps) = f cs x `mappend` mconcat (concatMap flattenBranch cmps) where +#if MIN_VERSION_Cabal(2,0,0) + flattenBranch (CondBranch _ t mb) = go t mb +#else + flattenBranch (_, t, mb) = go t mb +#endif + go t mb = flattenCondTree f t : map (flattenCondTree f) (maybeToList mb) + +parsePackageDesc :: String -> Either String PD.GenericPackageDescription +#if MIN_VERSION_Cabal(2,2,0) +parsePackageDesc s = case snd . runParseResult . parseGenericPackageDescription . C8.pack $ s of + Left (_, errs) -> Left $ unlines $ map (showPError "cabal") errs + Right r -> Right r +#elif MIN_VERSION_Cabal(2,0,0) +parsePackageDesc s = case parseGenericPackageDescription s of + ParseOk _ r -> Right r + ParseFailed e -> Left $ show e +#else +parsePackageDesc s = case parsePackageDescription s of + ParseOk _ r -> Right r + ParseFailed e -> Left $ show e +#endif diff --git a/src/HsDev/Project/Types.hs b/src/HsDev/Project/Types.hs --- a/src/HsDev/Project/Types.hs +++ b/src/HsDev/Project/Types.hs @@ -1,429 +1,429 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeApplications, LambdaCase #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Project.Types ( - BuildTool(..), Sandbox(..), sandboxType, sandbox, - Project(..), projectName, projectPath, projectCabal, projectDescription, projectBuildTool, projectPackageDbStack, project, - ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests, infos, targetInfos, - Target(..), TargetInfo(..), targetInfoName, targetBuildInfo, targetInfoMain, targetInfoModules, targetInfo, - Library(..), libraryModules, libraryBuildInfo, - Executable(..), executableName, executablePath, executableBuildInfo, - Test(..), testName, testEnabled, testBuildInfo, testMain, - Info(..), infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs, infoOtherModules, - Extensions(..), extensions, ghcOptions, entity, - ) where - -import Control.DeepSeq (NFData(..)) -import Control.Lens hiding ((.=), (<.>)) -import Data.Aeson -import Data.Maybe -import Data.Monoid hiding ((<>)) -import Data.Ord -import Data.Semigroup (Semigroup(..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Distribution.Text as D (display) -import Language.Haskell.Extension -import System.FilePath -import Text.Format - -import System.Directory.Paths -import HsDev.Display -import HsDev.PackageDb.Types -import HsDev.Util - --- | Project build tool -data BuildTool = CabalTool | StackTool deriving (Eq, Ord, Read, Show, Enum, Bounded) - -instance NFData BuildTool where - rnf CabalTool = () - rnf StackTool = () - -instance Display BuildTool where - display CabalTool = "cabal" - display StackTool = "stack" - displayType _ = "build-tool" - -instance Formattable BuildTool where - formattable = formattable . display - -instance ToJSON BuildTool where - toJSON CabalTool = toJSON @String "cabal" - toJSON StackTool = toJSON @String "stack" - -instance FromJSON BuildTool where - parseJSON = withText "build-tool" $ \case - "cabal" -> return CabalTool - "stack" -> return StackTool - other -> fail $ "Can't parse BuildTool, unknown tool: {}" ~~ other - -data Sandbox = Sandbox { _sandboxType :: BuildTool, _sandbox :: Path } deriving (Eq, Ord) - -makeLenses ''Sandbox - -instance NFData Sandbox where - rnf (Sandbox t p) = rnf t `seq` rnf p - -instance Show Sandbox where - show (Sandbox _ p) = T.unpack p - -instance Display Sandbox where - display (Sandbox _ fpath) = display fpath - displayType (Sandbox CabalTool _) = "cabal-sandbox" - displayType (Sandbox StackTool _) = "stack-work" - -instance Formattable Sandbox where - formattable = formattable . display - -instance ToJSON Sandbox where - toJSON (Sandbox t p) = object ["type" .= t, "path" .= p] - -instance FromJSON Sandbox where - parseJSON = withObject "sandbox" $ \v -> Sandbox <$> - v .:: "type" <*> - v .:: "path" - -instance Paths Sandbox where - paths f (Sandbox st p) = Sandbox st <$> paths f p - --- | Cabal project -data Project = Project { - _projectName :: Text, - _projectPath :: Path, - _projectCabal :: Path, - _projectDescription :: Maybe ProjectDescription, - _projectBuildTool :: BuildTool, - _projectPackageDbStack :: Maybe PackageDbStack } - -instance NFData Project where - rnf (Project n p c _ t dbs) = rnf n `seq` rnf p `seq` rnf c `seq` rnf t `seq` rnf dbs - -instance Eq Project where - l == r = _projectCabal l == _projectCabal r - -instance Ord Project where - compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r) - -instance Show Project where - show p = unlines $ [ - "project " ++ _projectName p ^. path, - "\tcabal: " ++ _projectCabal p ^. path, - "\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p) - -instance Display Project where - display = T.unpack . _projectName - displayType _ = "project" - -instance Formattable Project where - formattable = formattable . display - -instance ToJSON Project where - toJSON p = object [ - "name" .= _projectName p, - "path" .= _projectPath p, - "cabal" .= _projectCabal p, - "description" .= _projectDescription p, - "build-tool" .= _projectBuildTool p, - "package-db-stack" .= _projectPackageDbStack p] - -instance FromJSON Project where - parseJSON = withObject "project" $ \v -> Project <$> - v .:: "name" <*> - v .:: "path" <*> - v .:: "cabal" <*> - v .:: "description" <*> - v .:: "build-tool" <*> - v .::? "package-db-stack" - -instance Paths Project where - paths f (Project nm p c desc t dbs) = Project nm <$> paths f p <*> paths f c <*> traverse (paths f) desc <*> pure t <*> pure dbs - --- | Make project by .cabal file -project :: FilePath -> Project -project file = Project { - -- Should not be the directory of the cabal, s/b the base name of the cabal file. - _projectName = fromFilePath . dropExtension . takeBaseName $ cabal, - _projectPath = fromFilePath . takeDirectory $ cabal, - _projectCabal = fromFilePath cabal, - _projectDescription = Nothing, - _projectBuildTool = CabalTool, - _projectPackageDbStack = Nothing } - where - file' = dropTrailingPathSeparator $ normalise file - cabal - | takeExtension file' == ".cabal" = file' - | otherwise = file' (takeBaseName file' <.> "cabal") - -data ProjectDescription = ProjectDescription { - _projectVersion :: Text, - _projectLibrary :: Maybe Library, - _projectExecutables :: [Executable], - _projectTests :: [Test] } - deriving (Eq, Read) - --- | Build target infos -infos :: Traversal' ProjectDescription Info -infos f desc = (\lib exes tests -> desc { _projectLibrary = lib, _projectExecutables = exes, _projectTests = tests }) <$> - (_Just . buildInfo) f (_projectLibrary desc) <*> - (each . buildInfo) f (_projectExecutables desc) <*> - (each . buildInfo) f (_projectTests desc) - --- | Build target infos, more detailed -targetInfos :: ProjectDescription -> [TargetInfo] -targetInfos desc = concat [ - map targetInfo $ maybeToList (_projectLibrary desc), - map targetInfo $ _projectExecutables desc, - map targetInfo $ _projectTests desc] - -instance Show ProjectDescription where - show pd = unlines $ - concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++ - concatMap (lines . show) (_projectExecutables pd) ++ - concatMap (lines . show) (_projectTests pd) - -instance ToJSON ProjectDescription where - toJSON d = object [ - "version" .= _projectVersion d, - "library" .= _projectLibrary d, - "executables" .= _projectExecutables d, - "tests" .= _projectTests d] - -instance FromJSON ProjectDescription where - parseJSON = withObject "project description" $ \v -> ProjectDescription <$> - v .:: "version" <*> - v .:: "library" <*> - v .:: "executables" <*> - v .:: "tests" - -instance Paths ProjectDescription where - paths f (ProjectDescription v lib exes tests) = ProjectDescription v <$> traverse (paths f) lib <*> traverse (paths f) exes <*> traverse (paths f) tests - -class Target a where - targetName :: Traversal' a Text - buildInfo :: Lens' a Info - targetMain :: a -> Maybe Path - targetModules :: a -> [[Text]] - -data TargetInfo = TargetInfo { - _targetInfoName :: Maybe Text, - _targetBuildInfo :: Info, - _targetInfoMain :: Maybe Path, - _targetInfoModules :: [[Text]] } - deriving (Eq, Ord, Show) - -targetInfo :: Target a => a -> TargetInfo -targetInfo t = TargetInfo (t ^? targetName) (t ^. buildInfo) (targetMain t) (targetModules t) - -instance Paths TargetInfo where - paths f (TargetInfo n i mp ms) = TargetInfo n <$> paths f i <*> traverse (paths f) mp <*> pure ms - --- | Library in project -data Library = Library { - _libraryModules :: [[Text]], - _libraryBuildInfo :: Info } - deriving (Eq, Read) - -instance Show Library where - show l = unlines $ - ["library", "\tmodules:"] ++ - (map (tab 2 . T.unpack . T.intercalate ".") $ _libraryModules l) ++ - (map (tab 1) . lines . show $ _libraryBuildInfo l) - -instance ToJSON Library where - toJSON l = object [ - "modules" .= fmap (T.intercalate ".") (_libraryModules l), - "info" .= _libraryBuildInfo l] - -instance FromJSON Library where - parseJSON = withObject "library" $ \v -> Library <$> (fmap (T.split (== '.')) <$> v .:: "modules") <*> v .:: "info" - -instance Paths Library where - paths f (Library ms info) = Library ms <$> paths f info - --- | Executable -data Executable = Executable { - _executableName :: Text, - _executablePath :: Path, - _executableBuildInfo :: Info } - deriving (Eq, Read) - -instance Show Executable where - show e = unlines $ - ["executable " ++ T.unpack (_executableName e), "\tpath: " ++ (_executablePath e ^. path)] ++ - (map (tab 1) . lines . show $ _executableBuildInfo e) - -instance ToJSON Executable where - toJSON e = object [ - "name" .= _executableName e, - "path" .= _executablePath e, - "info" .= _executableBuildInfo e] - -instance FromJSON Executable where - parseJSON = withObject "executable" $ \v -> Executable <$> - v .:: "name" <*> - v .:: "path" <*> - v .:: "info" - -instance Paths Executable where - paths f (Executable n p info) = Executable n <$> paths f p <*> paths f info - --- | Test -data Test = Test { - _testName :: Text, - _testEnabled :: Bool, - _testMain :: Maybe Path, - _testBuildInfo :: Info } - deriving (Eq, Read) - -instance Show Test where - show t = unlines $ - ["test " ++ T.unpack (_testName t), "\tenabled: " ++ show (_testEnabled t)] ++ - maybe [] (\f -> ["\tmain-is: " ++ f ^. path]) (_testMain t) ++ - (map (tab 1) . lines . show $ _testBuildInfo t) - -instance ToJSON Test where - toJSON t = object [ - "name" .= _testName t, - "enabled" .= _testEnabled t, - "main" .= _testMain t, - "info" .= _testBuildInfo t] - -instance FromJSON Test where - parseJSON = withObject "test" $ \v -> Test <$> - v .:: "name" <*> - v .:: "enabled" <*> - v .::? "main" <*> - v .:: "info" - -instance Paths Test where - paths f (Test n e m info) = Test n e <$> traverse (paths f) m <*> paths f info - --- | Build info -data Info = Info { - _infoDepends :: [Text], - _infoLanguage :: Maybe Language, - _infoExtensions :: [Extension], - _infoGHCOptions :: [Text], - _infoSourceDirs :: [Path], - _infoOtherModules :: [[Text]] } - deriving (Eq, Read) - -instance Semigroup Info where - l <> r = Info - (ordNub $ _infoDepends l ++ _infoDepends r) - (getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r)) - (_infoExtensions l ++ _infoExtensions r) - (_infoGHCOptions l ++ _infoGHCOptions r) - (ordNub $ _infoSourceDirs l ++ _infoSourceDirs r) - (ordNub $ _infoOtherModules l ++ _infoOtherModules r) - -instance Monoid Info where - mempty = Info [] Nothing [] [] [] [] - mappend l r = l <> r - -instance Ord Info where - compare l r = compare (_infoSourceDirs l, _infoDepends l, _infoGHCOptions l) (_infoSourceDirs r, _infoDepends r, _infoGHCOptions r) - -instance Show Info where - show i = unlines $ lang ++ exts ++ opts ++ sources ++ otherMods where - lang = maybe [] (\l -> ["default-language: " ++ D.display l]) $ _infoLanguage i - exts - | null (_infoExtensions i) = [] - | otherwise = "extensions:" : map (tab 1 . D.display) (_infoExtensions i) - opts - | null (_infoGHCOptions i) = [] - | otherwise = "ghc-options:" : map (tab 1 . T.unpack) (_infoGHCOptions i) - sources = "source-dirs:" : map (tab 1 . T.unpack) (_infoSourceDirs i) - otherMods = "other-modules:" : (map (tab 1 . T.unpack) . fmap (T.intercalate ".") $ _infoOtherModules i) - -instance ToJSON Info where - toJSON i = object [ - "build-depends" .= _infoDepends i, - "language" .= _infoLanguage i, - "extensions" .= _infoExtensions i, - "ghc-options" .= _infoGHCOptions i, - "source-dirs" .= _infoSourceDirs i, - "other-modules" .= _infoOtherModules i] - -instance FromJSON Info where - parseJSON = withObject "info" $ \v -> Info <$> - v .: "build-depends" <*> - v .:: "language" <*> - v .:: "extensions" <*> - v .:: "ghc-options" <*> - v .:: "source-dirs" <*> - v .:: "other-modules" - -instance ToJSON Language where - toJSON = toJSON . D.display - -instance FromJSON Language where - parseJSON = withText "language" $ \txt -> parseDT "Language" (T.unpack txt) - -instance ToJSON Extension where - toJSON = toJSON . D.display - -instance FromJSON Extension where - parseJSON = withText "extension" $ \txt -> parseDT "Extension" (T.unpack txt) - -instance Paths Info where - paths f (Info deps lang exts opts dirs omods) = Info deps lang exts opts <$> traverse (paths f) dirs <*> pure omods - --- | Entity with project extensions -data Extensions a = Extensions { - _extensions :: [Extension], - _ghcOptions :: [Text], - _entity :: a } - deriving (Eq, Read, Show) - -instance Ord a => Ord (Extensions a) where - compare = comparing _entity - -instance Functor Extensions where - fmap f (Extensions e o x) = Extensions e o (f x) - -instance Applicative Extensions where - pure = Extensions [] [] - (Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x) - -instance Foldable Extensions where - foldMap f (Extensions _ _ x) = f x - -instance Traversable Extensions where - traverse f (Extensions e o x) = Extensions e o <$> f x - -makeLenses ''Project -makeLenses ''ProjectDescription -makeLenses ''TargetInfo -makeLenses ''Library -makeLenses ''Executable -makeLenses ''Test -makeLenses ''Info -makeLenses ''Extensions - -instance Target Library where - targetName _ = pure - buildInfo = libraryBuildInfo - targetMain _ = Nothing - targetModules lib' = lib' ^.. libraryModules . each - -instance Target Executable where - targetName = executableName - buildInfo = executableBuildInfo - targetMain exe' = Just $ exe' ^. executablePath - targetModules _ = [] - -instance Target Test where - targetName = testName - buildInfo = testBuildInfo - targetMain test' = fmap toPath (test' ^? testMain . _Just . path) where - toPath f - | haskellSource f = fromFilePath f - | otherwise = fromFilePath (f <.> "hs") - targetModules _ = [] - -instance Target TargetInfo where - targetName = targetInfoName . _Just - buildInfo = targetBuildInfo - targetMain = _targetInfoMain - targetModules = _targetInfoModules +{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeApplications, LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Project.Types ( + BuildTool(..), Sandbox(..), sandboxType, sandbox, + Project(..), projectName, projectPath, projectCabal, projectDescription, projectBuildTool, projectPackageDbStack, project, + ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests, infos, targetInfos, + Target(..), TargetInfo(..), targetInfoName, targetBuildInfo, targetInfoMain, targetInfoModules, targetInfo, + Library(..), libraryModules, libraryBuildInfo, + Executable(..), executableName, executablePath, executableBuildInfo, + Test(..), testName, testEnabled, testBuildInfo, testMain, + Info(..), infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs, infoOtherModules, + Extensions(..), extensions, ghcOptions, entity, + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Lens hiding ((.=), (<.>)) +import Data.Aeson +import Data.Maybe +import Data.Monoid hiding ((<>)) +import Data.Ord +import Data.Semigroup (Semigroup(..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Distribution.Text as D (display) +import Language.Haskell.Extension +import System.FilePath +import Text.Format + +import System.Directory.Paths +import HsDev.Display +import HsDev.PackageDb.Types +import HsDev.Util + +-- | Project build tool +data BuildTool = CabalTool | StackTool deriving (Eq, Ord, Read, Show, Enum, Bounded) + +instance NFData BuildTool where + rnf CabalTool = () + rnf StackTool = () + +instance Display BuildTool where + display CabalTool = "cabal" + display StackTool = "stack" + displayType _ = "build-tool" + +instance Formattable BuildTool where + formattable = formattable . display + +instance ToJSON BuildTool where + toJSON CabalTool = toJSON @String "cabal" + toJSON StackTool = toJSON @String "stack" + +instance FromJSON BuildTool where + parseJSON = withText "build-tool" $ \case + "cabal" -> return CabalTool + "stack" -> return StackTool + other -> fail $ "Can't parse BuildTool, unknown tool: {}" ~~ other + +data Sandbox = Sandbox { _sandboxType :: BuildTool, _sandbox :: Path } deriving (Eq, Ord) + +makeLenses ''Sandbox + +instance NFData Sandbox where + rnf (Sandbox t p) = rnf t `seq` rnf p + +instance Show Sandbox where + show (Sandbox _ p) = T.unpack p + +instance Display Sandbox where + display (Sandbox _ fpath) = display fpath + displayType (Sandbox CabalTool _) = "cabal-sandbox" + displayType (Sandbox StackTool _) = "stack-work" + +instance Formattable Sandbox where + formattable = formattable . display + +instance ToJSON Sandbox where + toJSON (Sandbox t p) = object ["type" .= t, "path" .= p] + +instance FromJSON Sandbox where + parseJSON = withObject "sandbox" $ \v -> Sandbox <$> + v .:: "type" <*> + v .:: "path" + +instance Paths Sandbox where + paths f (Sandbox st p) = Sandbox st <$> paths f p + +-- | Cabal project +data Project = Project { + _projectName :: Text, + _projectPath :: Path, + _projectCabal :: Path, + _projectDescription :: Maybe ProjectDescription, + _projectBuildTool :: BuildTool, + _projectPackageDbStack :: Maybe PackageDbStack } + +instance NFData Project where + rnf (Project n p c _ t dbs) = rnf n `seq` rnf p `seq` rnf c `seq` rnf t `seq` rnf dbs + +instance Eq Project where + l == r = _projectCabal l == _projectCabal r + +instance Ord Project where + compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r) + +instance Show Project where + show p = unlines $ [ + "project " ++ _projectName p ^. path, + "\tcabal: " ++ _projectCabal p ^. path, + "\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p) + +instance Display Project where + display = T.unpack . _projectName + displayType _ = "project" + +instance Formattable Project where + formattable = formattable . display + +instance ToJSON Project where + toJSON p = object [ + "name" .= _projectName p, + "path" .= _projectPath p, + "cabal" .= _projectCabal p, + "description" .= _projectDescription p, + "build-tool" .= _projectBuildTool p, + "package-db-stack" .= _projectPackageDbStack p] + +instance FromJSON Project where + parseJSON = withObject "project" $ \v -> Project <$> + v .:: "name" <*> + v .:: "path" <*> + v .:: "cabal" <*> + v .:: "description" <*> + v .:: "build-tool" <*> + v .::? "package-db-stack" + +instance Paths Project where + paths f (Project nm p c desc t dbs) = Project nm <$> paths f p <*> paths f c <*> traverse (paths f) desc <*> pure t <*> pure dbs + +-- | Make project by .cabal file +project :: FilePath -> Project +project file = Project { + -- Should not be the directory of the cabal, s/b the base name of the cabal file. + _projectName = fromFilePath . dropExtension . takeBaseName $ cabal, + _projectPath = fromFilePath . takeDirectory $ cabal, + _projectCabal = fromFilePath cabal, + _projectDescription = Nothing, + _projectBuildTool = CabalTool, + _projectPackageDbStack = Nothing } + where + file' = dropTrailingPathSeparator $ normalise file + cabal + | takeExtension file' == ".cabal" = file' + | otherwise = file' (takeBaseName file' <.> "cabal") + +data ProjectDescription = ProjectDescription { + _projectVersion :: Text, + _projectLibrary :: Maybe Library, + _projectExecutables :: [Executable], + _projectTests :: [Test] } + deriving (Eq, Read) + +-- | Build target infos +infos :: Traversal' ProjectDescription Info +infos f desc = (\lib exes tests -> desc { _projectLibrary = lib, _projectExecutables = exes, _projectTests = tests }) <$> + (_Just . buildInfo) f (_projectLibrary desc) <*> + (each . buildInfo) f (_projectExecutables desc) <*> + (each . buildInfo) f (_projectTests desc) + +-- | Build target infos, more detailed +targetInfos :: ProjectDescription -> [TargetInfo] +targetInfos desc = concat [ + map targetInfo $ maybeToList (_projectLibrary desc), + map targetInfo $ _projectExecutables desc, + map targetInfo $ _projectTests desc] + +instance Show ProjectDescription where + show pd = unlines $ + concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++ + concatMap (lines . show) (_projectExecutables pd) ++ + concatMap (lines . show) (_projectTests pd) + +instance ToJSON ProjectDescription where + toJSON d = object [ + "version" .= _projectVersion d, + "library" .= _projectLibrary d, + "executables" .= _projectExecutables d, + "tests" .= _projectTests d] + +instance FromJSON ProjectDescription where + parseJSON = withObject "project description" $ \v -> ProjectDescription <$> + v .:: "version" <*> + v .:: "library" <*> + v .:: "executables" <*> + v .:: "tests" + +instance Paths ProjectDescription where + paths f (ProjectDescription v lib exes tests) = ProjectDescription v <$> traverse (paths f) lib <*> traverse (paths f) exes <*> traverse (paths f) tests + +class Target a where + targetName :: Traversal' a Text + buildInfo :: Lens' a Info + targetMain :: a -> Maybe Path + targetModules :: a -> [[Text]] + +data TargetInfo = TargetInfo { + _targetInfoName :: Maybe Text, + _targetBuildInfo :: Info, + _targetInfoMain :: Maybe Path, + _targetInfoModules :: [[Text]] } + deriving (Eq, Ord, Show) + +targetInfo :: Target a => a -> TargetInfo +targetInfo t = TargetInfo (t ^? targetName) (t ^. buildInfo) (targetMain t) (targetModules t) + +instance Paths TargetInfo where + paths f (TargetInfo n i mp ms) = TargetInfo n <$> paths f i <*> traverse (paths f) mp <*> pure ms + +-- | Library in project +data Library = Library { + _libraryModules :: [[Text]], + _libraryBuildInfo :: Info } + deriving (Eq, Read) + +instance Show Library where + show l = unlines $ + ["library", "\tmodules:"] ++ + (map (tab 2 . T.unpack . T.intercalate ".") $ _libraryModules l) ++ + (map (tab 1) . lines . show $ _libraryBuildInfo l) + +instance ToJSON Library where + toJSON l = object [ + "modules" .= fmap (T.intercalate ".") (_libraryModules l), + "info" .= _libraryBuildInfo l] + +instance FromJSON Library where + parseJSON = withObject "library" $ \v -> Library <$> (fmap (T.split (== '.')) <$> v .:: "modules") <*> v .:: "info" + +instance Paths Library where + paths f (Library ms info) = Library ms <$> paths f info + +-- | Executable +data Executable = Executable { + _executableName :: Text, + _executablePath :: Path, + _executableBuildInfo :: Info } + deriving (Eq, Read) + +instance Show Executable where + show e = unlines $ + ["executable " ++ T.unpack (_executableName e), "\tpath: " ++ (_executablePath e ^. path)] ++ + (map (tab 1) . lines . show $ _executableBuildInfo e) + +instance ToJSON Executable where + toJSON e = object [ + "name" .= _executableName e, + "path" .= _executablePath e, + "info" .= _executableBuildInfo e] + +instance FromJSON Executable where + parseJSON = withObject "executable" $ \v -> Executable <$> + v .:: "name" <*> + v .:: "path" <*> + v .:: "info" + +instance Paths Executable where + paths f (Executable n p info) = Executable n <$> paths f p <*> paths f info + +-- | Test +data Test = Test { + _testName :: Text, + _testEnabled :: Bool, + _testMain :: Maybe Path, + _testBuildInfo :: Info } + deriving (Eq, Read) + +instance Show Test where + show t = unlines $ + ["test " ++ T.unpack (_testName t), "\tenabled: " ++ show (_testEnabled t)] ++ + maybe [] (\f -> ["\tmain-is: " ++ f ^. path]) (_testMain t) ++ + (map (tab 1) . lines . show $ _testBuildInfo t) + +instance ToJSON Test where + toJSON t = object [ + "name" .= _testName t, + "enabled" .= _testEnabled t, + "main" .= _testMain t, + "info" .= _testBuildInfo t] + +instance FromJSON Test where + parseJSON = withObject "test" $ \v -> Test <$> + v .:: "name" <*> + v .:: "enabled" <*> + v .::? "main" <*> + v .:: "info" + +instance Paths Test where + paths f (Test n e m info) = Test n e <$> traverse (paths f) m <*> paths f info + +-- | Build info +data Info = Info { + _infoDepends :: [Text], + _infoLanguage :: Maybe Language, + _infoExtensions :: [Extension], + _infoGHCOptions :: [Text], + _infoSourceDirs :: [Path], + _infoOtherModules :: [[Text]] } + deriving (Eq, Read) + +instance Semigroup Info where + l <> r = Info + (ordNub $ _infoDepends l ++ _infoDepends r) + (getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r)) + (_infoExtensions l ++ _infoExtensions r) + (_infoGHCOptions l ++ _infoGHCOptions r) + (ordNub $ _infoSourceDirs l ++ _infoSourceDirs r) + (ordNub $ _infoOtherModules l ++ _infoOtherModules r) + +instance Monoid Info where + mempty = Info [] Nothing [] [] [] [] + mappend l r = l <> r + +instance Ord Info where + compare l r = compare (_infoSourceDirs l, _infoDepends l, _infoGHCOptions l) (_infoSourceDirs r, _infoDepends r, _infoGHCOptions r) + +instance Show Info where + show i = unlines $ lang ++ exts ++ opts ++ sources ++ otherMods where + lang = maybe [] (\l -> ["default-language: " ++ D.display l]) $ _infoLanguage i + exts + | null (_infoExtensions i) = [] + | otherwise = "extensions:" : map (tab 1 . D.display) (_infoExtensions i) + opts + | null (_infoGHCOptions i) = [] + | otherwise = "ghc-options:" : map (tab 1 . T.unpack) (_infoGHCOptions i) + sources = "source-dirs:" : map (tab 1 . T.unpack) (_infoSourceDirs i) + otherMods = "other-modules:" : (map (tab 1 . T.unpack) . fmap (T.intercalate ".") $ _infoOtherModules i) + +instance ToJSON Info where + toJSON i = object [ + "build-depends" .= _infoDepends i, + "language" .= _infoLanguage i, + "extensions" .= _infoExtensions i, + "ghc-options" .= _infoGHCOptions i, + "source-dirs" .= _infoSourceDirs i, + "other-modules" .= _infoOtherModules i] + +instance FromJSON Info where + parseJSON = withObject "info" $ \v -> Info <$> + v .: "build-depends" <*> + v .:: "language" <*> + v .:: "extensions" <*> + v .:: "ghc-options" <*> + v .:: "source-dirs" <*> + v .:: "other-modules" + +instance ToJSON Language where + toJSON = toJSON . D.display + +instance FromJSON Language where + parseJSON = withText "language" $ \txt -> parseDT "Language" (T.unpack txt) + +instance ToJSON Extension where + toJSON = toJSON . D.display + +instance FromJSON Extension where + parseJSON = withText "extension" $ \txt -> parseDT "Extension" (T.unpack txt) + +instance Paths Info where + paths f (Info deps lang exts opts dirs omods) = Info deps lang exts opts <$> traverse (paths f) dirs <*> pure omods + +-- | Entity with project extensions +data Extensions a = Extensions { + _extensions :: [Extension], + _ghcOptions :: [Text], + _entity :: a } + deriving (Eq, Read, Show) + +instance Ord a => Ord (Extensions a) where + compare = comparing _entity + +instance Functor Extensions where + fmap f (Extensions e o x) = Extensions e o (f x) + +instance Applicative Extensions where + pure = Extensions [] [] + (Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x) + +instance Foldable Extensions where + foldMap f (Extensions _ _ x) = f x + +instance Traversable Extensions where + traverse f (Extensions e o x) = Extensions e o <$> f x + +makeLenses ''Project +makeLenses ''ProjectDescription +makeLenses ''TargetInfo +makeLenses ''Library +makeLenses ''Executable +makeLenses ''Test +makeLenses ''Info +makeLenses ''Extensions + +instance Target Library where + targetName _ = pure + buildInfo = libraryBuildInfo + targetMain _ = Nothing + targetModules lib' = lib' ^.. libraryModules . each + +instance Target Executable where + targetName = executableName + buildInfo = executableBuildInfo + targetMain exe' = Just $ exe' ^. executablePath + targetModules _ = [] + +instance Target Test where + targetName = testName + buildInfo = testBuildInfo + targetMain test' = fmap toPath (test' ^? testMain . _Just . path) where + toPath f + | haskellSource f = fromFilePath f + | otherwise = fromFilePath (f <.> "hs") + targetModules _ = [] + +instance Target TargetInfo where + targetName = targetInfoName . _Just + buildInfo = targetBuildInfo + targetMain = _targetInfoMain + targetModules = _targetInfoModules diff --git a/src/HsDev/Sandbox.hs b/src/HsDev/Sandbox.hs --- a/src/HsDev/Sandbox.hs +++ b/src/HsDev/Sandbox.hs @@ -1,171 +1,171 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HsDev.Sandbox ( - Sandbox(..), sandboxType, sandbox, - isSandbox, guessSandboxType, sandboxFromPath, - findSandbox, searchSandbox, searchSandboxes, - projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack, - - -- * package-db - userPackageDb, - - -- * cabal-sandbox util - cabalSandboxPackageDb, - - getModuleOpts, getProjectTargetOpts, - - getProjectSandbox, - getProjectPackageDbStack - ) where - -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.Except -import Control.Lens (view) -import Data.List (find, intercalate) -import Data.Maybe (isJust, fromMaybe, catMaybes) -import Data.Maybe.JustIf -import System.Directory (getAppUserDataDirectory, doesDirectoryExist) -import System.FilePath -import System.Log.Simple (MonadLog(..)) -import Text.Format - -import System.Directory.Paths -import HsDev.Error -import HsDev.PackageDb -import HsDev.Project.Types -import HsDev.Scan.Browse (browsePackages) -import HsDev.Stack hiding (path) -import HsDev.Symbols (moduleOpts, projectTargetOpts) -import HsDev.Symbols.Types (moduleId, Module(..), ModuleLocation(..), moduleLocation) -import HsDev.Tools.Ghc.Worker (GhcM) -import HsDev.Tools.Ghc.System (buildPath) -import HsDev.Util (searchPath, directoryContents, cabalFile) - -isSandbox :: Path -> Bool -isSandbox = isJust . guessSandboxType - -guessSandboxType :: Path -> Maybe BuildTool -guessSandboxType fpath - | takeFileName (view path fpath) == ".cabal-sandbox" = Just CabalTool - | takeFileName (view path fpath) == ".stack-work" = Just StackTool - | otherwise = Nothing - -sandboxFromPath :: Path -> Maybe Sandbox -sandboxFromPath fpath = Sandbox <$> guessSandboxType fpath <*> pure fpath - --- | Find sandbox in path -findSandbox :: Path -> IO (Maybe Sandbox) -findSandbox fpath = do - fpath' <- canonicalize fpath - isDir <- dirExists fpath' - if isDir - then do - dirs <- liftM ((fpath' :) . map fromFilePath) $ directoryContents (view path fpath') - return $ msum $ map sandboxFromDir dirs - else return Nothing - where - sandboxFromDir :: Path -> Maybe Sandbox - sandboxFromDir fdir - | takeFileName (view path fdir) == "stack.yaml" = sandboxFromPath (fromFilePath (takeDirectory (view path fdir) ".stack-work")) - | otherwise = sandboxFromPath fdir - --- | Search sandbox by parent directory -searchSandbox :: Path -> IO (Maybe Sandbox) -searchSandbox p = runMaybeT $ searchPath (view path p) (MaybeT . findSandbox . fromFilePath) - --- | Search sandboxes up from current directory -searchSandboxes :: Path -> IO [Sandbox] -searchSandboxes p = do - mcabal <- searchFor CabalTool ".cabal-sandbox" ".cabal-sandbox" - mstack <- searchFor StackTool "stack.yaml" ".stack-work" - return $ catMaybes [mcabal, mstack] - where - searchFor :: BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox) - searchFor tool lookFor sandboxDir = runMaybeT $ do - root <- searchPath (view path p) (MaybeT . getRoot) - return $ Sandbox tool $ fromFilePath (takeDirectory root sandboxDir) - where - getRoot = directoryContents >=> return . find ((== lookFor) . takeFileName) - --- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents -projectSandbox :: BuildTool -> Path -> IO (Maybe Sandbox) -projectSandbox tool fpath = runMaybeT $ do - p <- searchPath (view path fpath) (MaybeT . getCabalFile) - sboxes <- liftIO $ searchSandboxes (fromFilePath $ takeDirectory p) - MaybeT $ return $ find ((== tool) . view sandboxType) sboxes - where - getCabalFile = directoryContents >=> return . find cabalFile - --- | Get package-db stack for sandbox -sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack -sandboxPackageDbStack (Sandbox CabalTool fpath) = do - dir <- cabalSandboxPackageDb $ view path fpath - return $ PackageDbStack [PackageDb $ fromFilePath dir] -sandboxPackageDbStack (Sandbox StackTool fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory (view path fpath) - --- | Search package-db stack with user-db as default -searchPackageDbStack :: BuildTool -> Path -> GhcM PackageDbStack -searchPackageDbStack tool p = do - mbox <- liftIO $ projectSandbox tool p - case mbox of - Nothing -> return userDb - Just sbox -> sandboxPackageDbStack sbox - --- | Restore package-db stack by package-db -restorePackageDbStack :: PackageDb -> GhcM PackageDbStack -restorePackageDbStack GlobalDb = return globalDb -restorePackageDbStack UserDb = return userDb -restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDbs [p]) $ runMaybeT $ do - sbox <- MaybeT $ liftIO $ searchSandbox p - lift $ sandboxPackageDbStack sbox - --- | User package-db: -- -userPackageDb :: GhcM FilePath -userPackageDb = do - root <- liftIO $ getAppUserDataDirectory "ghc" - dir <- buildPath "{arch}-{os}-{version}" - return $ root dir - --- | Get sandbox package-db: ----packages.conf.d -cabalSandboxPackageDb :: FilePath -> GhcM FilePath -cabalSandboxPackageDb root = do - dirs <- mapM (fmap (root ) . buildPath) [ - "{arch}-{os}-{compiler}-{version}-packages.conf.d", - "{arch}-{os/cabal}-{compiler}-{version}-packages.conf.d"] - mdir <- liftM msum $ forM dirs $ \dir -> do - justIf dir <$> liftIO (doesDirectoryExist dir) - case mdir of - Nothing -> hsdevError $ OtherError $ unlines [ - "No suitable package-db found in sandbox, is it configured?", - "Searched in: {}" ~~ intercalate ", " dirs] - Just dir -> return dir - --- | Options for GHC for module and project -getModuleOpts :: [String] -> Module -> GhcM (PackageDbStack, [String]) -getModuleOpts opts m = do - pdbs <- case view (moduleId . moduleLocation) m of - FileModule fpath mproj -> searchPackageDbStack (maybe CabalTool (view projectBuildTool) mproj) fpath - InstalledModule{} -> return userDb - _ -> return userDb - pkgs <- browsePackages opts pdbs - return $ (pdbs, concat [ - moduleOpts pkgs m, - opts]) - --- | Options for GHC for project target -getProjectTargetOpts :: [String] -> Project -> Info -> GhcM (PackageDbStack, [String]) -getProjectTargetOpts opts proj t = do - pdbs <- searchPackageDbStack (view projectBuildTool proj) (view projectPath proj) - pkgs <- browsePackages opts pdbs - return $ (pdbs, concat [ - projectTargetOpts pkgs proj t, - opts]) - --- | Get sandbox of project (if any) -getProjectSandbox :: MonadLog m => Project -> m (Maybe Sandbox) -getProjectSandbox p = liftIO . projectSandbox (view projectBuildTool p) . view projectPath $ p - --- | Get project package-db stack -getProjectPackageDbStack :: Project -> GhcM PackageDbStack -getProjectPackageDbStack = getProjectSandbox >=> maybe (return userDb) sandboxPackageDbStack +{-# LANGUAGE OverloadedStrings #-} + +module HsDev.Sandbox ( + Sandbox(..), sandboxType, sandbox, + isSandbox, guessSandboxType, sandboxFromPath, + findSandbox, searchSandbox, searchSandboxes, + projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack, + + -- * package-db + userPackageDb, + + -- * cabal-sandbox util + cabalSandboxPackageDb, + + getModuleOpts, getProjectTargetOpts, + + getProjectSandbox, + getProjectPackageDbStack + ) where + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Control.Lens (view) +import Data.List (find, intercalate) +import Data.Maybe (isJust, fromMaybe, catMaybes) +import Data.Maybe.JustIf +import System.Directory (getAppUserDataDirectory, doesDirectoryExist) +import System.FilePath +import System.Log.Simple (MonadLog(..)) +import Text.Format + +import System.Directory.Paths +import HsDev.Error +import HsDev.PackageDb +import HsDev.Project.Types +import HsDev.Scan.Browse (browsePackages) +import HsDev.Stack hiding (path) +import HsDev.Symbols (moduleOpts, projectTargetOpts) +import HsDev.Symbols.Types (moduleId, Module(..), ModuleLocation(..), moduleLocation) +import HsDev.Tools.Ghc.Worker (GhcM) +import HsDev.Tools.Ghc.System (buildPath) +import HsDev.Util (searchPath, directoryContents, cabalFile) + +isSandbox :: Path -> Bool +isSandbox = isJust . guessSandboxType + +guessSandboxType :: Path -> Maybe BuildTool +guessSandboxType fpath + | takeFileName (view path fpath) == ".cabal-sandbox" = Just CabalTool + | takeFileName (view path fpath) == ".stack-work" = Just StackTool + | otherwise = Nothing + +sandboxFromPath :: Path -> Maybe Sandbox +sandboxFromPath fpath = Sandbox <$> guessSandboxType fpath <*> pure fpath + +-- | Find sandbox in path +findSandbox :: Path -> IO (Maybe Sandbox) +findSandbox fpath = do + fpath' <- canonicalize fpath + isDir <- dirExists fpath' + if isDir + then do + dirs <- liftM ((fpath' :) . map fromFilePath) $ directoryContents (view path fpath') + return $ msum $ map sandboxFromDir dirs + else return Nothing + where + sandboxFromDir :: Path -> Maybe Sandbox + sandboxFromDir fdir + | takeFileName (view path fdir) == "stack.yaml" = sandboxFromPath (fromFilePath (takeDirectory (view path fdir) ".stack-work")) + | otherwise = sandboxFromPath fdir + +-- | Search sandbox by parent directory +searchSandbox :: Path -> IO (Maybe Sandbox) +searchSandbox p = runMaybeT $ searchPath (view path p) (MaybeT . findSandbox . fromFilePath) + +-- | Search sandboxes up from current directory +searchSandboxes :: Path -> IO [Sandbox] +searchSandboxes p = do + mcabal <- searchFor CabalTool ".cabal-sandbox" ".cabal-sandbox" + mstack <- searchFor StackTool "stack.yaml" ".stack-work" + return $ catMaybes [mcabal, mstack] + where + searchFor :: BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox) + searchFor tool lookFor sandboxDir = runMaybeT $ do + root <- searchPath (view path p) (MaybeT . getRoot) + return $ Sandbox tool $ fromFilePath (takeDirectory root sandboxDir) + where + getRoot = directoryContents >=> return . find ((== lookFor) . takeFileName) + +-- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents +projectSandbox :: BuildTool -> Path -> IO (Maybe Sandbox) +projectSandbox tool fpath = runMaybeT $ do + p <- searchPath (view path fpath) (MaybeT . getCabalFile) + sboxes <- liftIO $ searchSandboxes (fromFilePath $ takeDirectory p) + MaybeT $ return $ find ((== tool) . view sandboxType) sboxes + where + getCabalFile = directoryContents >=> return . find cabalFile + +-- | Get package-db stack for sandbox +sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack +sandboxPackageDbStack (Sandbox CabalTool fpath) = do + dir <- cabalSandboxPackageDb $ view path fpath + return $ PackageDbStack [PackageDb $ fromFilePath dir] +sandboxPackageDbStack (Sandbox StackTool fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory (view path fpath) + +-- | Search package-db stack with user-db as default +searchPackageDbStack :: BuildTool -> Path -> GhcM PackageDbStack +searchPackageDbStack tool p = do + mbox <- liftIO $ projectSandbox tool p + case mbox of + Nothing -> return userDb + Just sbox -> sandboxPackageDbStack sbox + +-- | Restore package-db stack by package-db +restorePackageDbStack :: PackageDb -> GhcM PackageDbStack +restorePackageDbStack GlobalDb = return globalDb +restorePackageDbStack UserDb = return userDb +restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDbs [p]) $ runMaybeT $ do + sbox <- MaybeT $ liftIO $ searchSandbox p + lift $ sandboxPackageDbStack sbox + +-- | User package-db: -- +userPackageDb :: GhcM FilePath +userPackageDb = do + root <- liftIO $ getAppUserDataDirectory "ghc" + dir <- buildPath "{arch}-{os}-{version}" + return $ root dir + +-- | Get sandbox package-db: ----packages.conf.d +cabalSandboxPackageDb :: FilePath -> GhcM FilePath +cabalSandboxPackageDb root = do + dirs <- mapM (fmap (root ) . buildPath) [ + "{arch}-{os}-{compiler}-{version}-packages.conf.d", + "{arch}-{os/cabal}-{compiler}-{version}-packages.conf.d"] + mdir <- liftM msum $ forM dirs $ \dir -> do + justIf dir <$> liftIO (doesDirectoryExist dir) + case mdir of + Nothing -> hsdevError $ OtherError $ unlines [ + "No suitable package-db found in sandbox, is it configured?", + "Searched in: {}" ~~ intercalate ", " dirs] + Just dir -> return dir + +-- | Options for GHC for module and project +getModuleOpts :: [String] -> Module -> GhcM (PackageDbStack, [String]) +getModuleOpts opts m = do + pdbs <- case view (moduleId . moduleLocation) m of + FileModule fpath mproj -> searchPackageDbStack (maybe CabalTool (view projectBuildTool) mproj) fpath + InstalledModule{} -> return userDb + _ -> return userDb + pkgs <- browsePackages opts pdbs + return $ (pdbs, concat [ + moduleOpts pkgs m, + opts]) + +-- | Options for GHC for project target +getProjectTargetOpts :: [String] -> Project -> Info -> GhcM (PackageDbStack, [String]) +getProjectTargetOpts opts proj t = do + pdbs <- searchPackageDbStack (view projectBuildTool proj) (view projectPath proj) + pkgs <- browsePackages opts pdbs + return $ (pdbs, concat [ + projectTargetOpts pkgs proj t, + opts]) + +-- | Get sandbox of project (if any) +getProjectSandbox :: MonadLog m => Project -> m (Maybe Sandbox) +getProjectSandbox p = liftIO . projectSandbox (view projectBuildTool p) . view projectPath $ p + +-- | Get project package-db stack +getProjectPackageDbStack :: Project -> GhcM PackageDbStack +getProjectPackageDbStack = getProjectSandbox >=> maybe (return userDb) sandboxPackageDbStack diff --git a/src/HsDev/Scan.hs b/src/HsDev/Scan.hs --- a/src/HsDev/Scan.hs +++ b/src/HsDev/Scan.hs @@ -1,259 +1,259 @@ -{-# LANGUAGE FlexibleInstances, TypeOperators, TypeApplications, OverloadedStrings #-} - -module HsDev.Scan ( - -- * Enumerate functions - CompileFlag, ModuleToScan, ProjectToScan, PackageDbToScan, ScanContents(..), - EnumContents(..), - enumRescan, enumDependent, enumProject, enumSandbox, enumDirectory, - - -- * Scan - scanProjectFile, - scanModify, - upToDate, changedModules, - getFileContents, - - -- * Reexportss - module HsDev.Symbols.Types, - module Control.Monad.Except, - ) where - -import Control.DeepSeq -import Control.Lens -import Control.Monad.Except -import Data.Deps -import Data.Maybe (catMaybes, isJust, listToMaybe) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.List (intercalate) -import Data.Text (Text) -import Data.Text.Lens (unpacked) -import qualified Data.Text as T -import Data.Time.Clock.POSIX (POSIXTime) -import Data.Traversable (for) -import Data.Semigroup -import Data.String (IsString, fromString) -import qualified Data.Set as S -import System.Directory -import Text.Format -import qualified System.Log.Simple as Log - -import HsDev.Error -import qualified HsDev.Database.SQLite as SQLite -import HsDev.Database.SQLite.Select -import HsDev.Scan.Browse (browsePackages) -import HsDev.Server.Types (FileSource(..), SessionMonad(..), CommandMonad(..), inSessionGhc, postSessionUpdater) -import HsDev.Sandbox -import HsDev.Symbols -import HsDev.Symbols.Types -import HsDev.Display -import HsDev.Inspect -import HsDev.Util -import System.Directory.Paths - --- | Compile flags -type CompileFlag = String --- | Module with flags ready to scan -type ModuleToScan = (ModuleLocation, [CompileFlag], Maybe Text) --- | Project ready to scan -type ProjectToScan = (Project, [ModuleToScan]) --- | Package-db sandbox to scan (top of stack) -type PackageDbToScan = PackageDbStack - --- | Scan info -data ScanContents = ScanContents { - modulesToScan :: [ModuleToScan], - projectsToScan :: [ProjectToScan], - sandboxesToScan :: [PackageDbStack] } - -instance NFData ScanContents where - rnf (ScanContents ms ps ss) = rnf ms `seq` rnf ps `seq` rnf ss - -instance Semigroup ScanContents where - ScanContents lm lp ls <> ScanContents rm rp rs = ScanContents - (uniqueBy (view _1) $ lm ++ rm) - (uniqueBy (view _1) $ lp ++ rp) - (ordNub $ ls ++ rs) - -instance Monoid ScanContents where - mempty = ScanContents [] [] [] - mappend l r = l <> r - -instance Formattable ScanContents where - formattable (ScanContents ms ps cs) = formattable str where - str :: String - str = format "modules: {}, projects: {}, package-dbs: {}" - ~~ (T.intercalate comma $ ms ^.. each . _1 . moduleFile) - ~~ (T.intercalate comma $ ps ^.. each . _1 . projectPath) - ~~ (intercalate comma $ map (display . topPackageDb) $ cs ^.. each) - comma :: IsString s => s - comma = fromString ", " - -class EnumContents a where - enumContents :: CommandMonad m => a -> m ScanContents - -instance EnumContents ModuleLocation where - enumContents mloc = return $ ScanContents [(mloc, [], Nothing)] [] [] - -instance EnumContents (Extensions ModuleLocation) where - enumContents ex = return $ ScanContents [(view entity ex, extensionsOpts ex, Nothing)] [] [] - -instance EnumContents Project where - enumContents = enumProject - -instance EnumContents PackageDbStack where - enumContents pdbs = return $ ScanContents [] [] (packageDbStacks pdbs) - -instance EnumContents Sandbox where - enumContents = enumSandbox - -instance {-# OVERLAPPABLE #-} EnumContents a => EnumContents [a] where - enumContents = liftM mconcat . tries . map enumContents - -instance {-# OVERLAPPING #-} EnumContents FilePath where - enumContents f - | haskellSource f = hsdevLiftIO $ do - mproj <- liftIO $ locateProject f - case mproj of - Nothing -> enumContents $ FileModule (fromFilePath f) Nothing - Just proj -> do - ScanContents _ [(_, mods)] _ <- enumContents proj - return $ ScanContents (filter ((== Just f) . preview (_1 . moduleFile . path)) mods) [] [] - | otherwise = enumDirectory f - -instance {-# OVERLAPPING #-} EnumContents Path where - enumContents = enumContents . view path - -instance EnumContents FileSource where - enumContents (FileSource f mcts) - | haskellSource (view path f) = do - ScanContents [(m, opts, _)] _ _ <- enumContents f - return $ ScanContents [(m, opts, mcts)] [] [] - | otherwise = return mempty - --- | Enum rescannable (i.e. already scanned) file -enumRescan :: CommandMonad m => FilePath -> m ScanContents -enumRescan fpath = Log.scope "enum-rescan" $ do - ms <- SQLite.query @_ @(ModuleLocation SQLite.:. Inspection) - (toQuery $ mconcat [ - qModuleLocation "ml", - select_ ["ml.inspection_time", "ml.inspection_opts"], - where_ ["ml.file == ?"]]) - (SQLite.Only fpath) - case ms of - [] -> do - Log.sendLog Log.Warning $ "file {} not found" ~~ fpath - return mempty - ((mloc SQLite.:. insp):_) -> do - when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath - return $ ScanContents [(mloc, insp ^.. inspectionOpts . each . unpacked, Nothing)] [] [] - --- | Enum file dependent -enumDependent :: CommandMonad m => FilePath -> m ScanContents -enumDependent fpath = Log.scope "enum-dependent" $ do - ms <- SQLite.query @_ @ModuleId - (toQuery $ qModuleId `mappend` where_ ["mu.file == ?"]) (SQLite.Only fpath) - case ms of - [] -> do - Log.sendLog Log.Warning $ "file {} not found" ~~ fpath - return mempty - (mid:_) -> do - when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath - let - mcabal = mid ^? moduleLocation . moduleProject . _Just . projectCabal - depList <- SQLite.query @_ @(Path, Path) "select d.module_file, d.depends_file from sources_depends as d, projects_modules_scope as ps where ps.cabal is ? and ps.module_id == d.module_id;" - (SQLite.Only mcabal) - let - rdeps = inverse . either (const mempty) id . flatten . mconcat . map (uncurry dep) $ depList - dependent = rdeps ^. ix (fromFilePath fpath) - liftM mconcat $ mapM (enumRescan . view path) dependent - --- | Enum project sources -enumProject :: CommandMonad m => Project -> m ScanContents -enumProject p = hsdevLiftIO $ do - p' <- liftIO $ loadProject p - pdbs <- inSessionGhc $ searchPackageDbStack (view projectBuildTool p') (view projectPath p') - pkgs <- inSessionGhc $ liftM (S.fromList . map (view (package . packageName))) $ browsePackages [] pdbs - let - projOpts :: Path -> [Text] - projOpts f = map fromString $ concatMap makeOpts $ fileTargets p' f where - makeOpts :: Info -> [String] - makeOpts i = concat [ - ["-hide-all-packages"], - ["-package " ++ view (projectName . path) p'], - ["-package " ++ T.unpack dep' | dep' <- view infoDepends i, dep' `S.member` pkgs]] - srcs <- liftIO $ projectSources p' - let - mlocs = over each (\src -> over ghcOptions (++ projOpts (view entity src)) . over entity (\f -> FileModule f (Just p')) $ src) srcs - mods <- liftM modulesToScan $ enumContents mlocs - return $ ScanContents [] [(p', mods)] [] -- (sandboxCabals sboxes) - --- | Enum sandbox -enumSandbox :: CommandMonad m => Sandbox -> m ScanContents -enumSandbox = (inSessionGhc . sandboxPackageDbStack) >=> enumContents - --- | Enum directory modules -enumDirectory :: CommandMonad m => FilePath -> m ScanContents -enumDirectory dir = hsdevLiftIO $ do - cts <- liftIO $ traverseDirectory dir - let - projects = filter cabalFile cts - sources = filter haskellSource cts - dirs <- liftIO $ filterM doesDirectoryExist cts - sboxes <- liftM catMaybes $ triesMap (liftIO . findSandbox . fromFilePath) dirs - pdbs <- mapM enumSandbox sboxes - projs <- liftM mconcat $ triesMap (enumProject . project) projects - let - projPaths = map (view projectPath . fst) $ projectsToScan projs - standalone = map (`FileModule` Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) $ map fromFilePath sources - return $ mconcat [ - ScanContents [(s, [], Nothing) | s <- standalone] [] [], - projs, - mconcat pdbs] - --- | Scan project file -scanProjectFile :: CommandMonad m => [String] -> Path -> m Project -scanProjectFile _ f = hsdevLiftIO $ do - proj <- (liftIO $ locateProject (view path f)) >>= maybe (hsdevError $ FileNotFound f) return - liftIO $ loadProject proj - --- | Scan additional info and modify scanned module -scanModify :: CommandMonad m => ([String] -> Module -> m Module) -> InspectedModule -> m InspectedModule -scanModify f im = traverse f' im where - f' m = f (toListOf (inspection . inspectionOpts . each . unpacked) im) m - --- | Is inspected module up to date? -upToDate :: SessionMonad m => ModuleLocation -> [String] -> Inspection -> m Bool -upToDate mloc opts insp = do - insp' <- liftIO $ moduleInspection mloc opts - mfinsp <- fmap join $ for (mloc ^? moduleFile) $ \fpath -> do - tm <- SQLite.query @_ @(SQLite.Only Double) "select mtime from file_contents where file = ?;" (SQLite.Only fpath) - return $ fmap (fileContentsInspection_ opts . fromRational . toRational . SQLite.fromOnly) (listToMaybe tm) - let - lastInsp = maybe insp' (max insp') mfinsp - return $ fresh insp lastInsp - --- | Returns new (to scan) and changed (to rescan) modules -changedModules :: SessionMonad m => Map ModuleLocation Inspection -> [String] -> [ModuleToScan] -> m [ModuleToScan] -changedModules inspMap opts = filterM $ \m -> if isJust (m ^. _3) - then return True - else maybe - (return True) - (liftM not . upToDate (m ^. _1) (opts ++ (m ^. _2))) - (M.lookup (m ^. _1) inspMap) - --- | Returns file contents if it was set and still actual -getFileContents :: SessionMonad m => Path -> m (Maybe (POSIXTime, Text)) -getFileContents fpath = do - mcts <- SQLite.query @_ @(Double, Text) "select mtime, contents from file_contents where file = ?;" (SQLite.Only fpath) - insp <- liftIO $ fileInspection fpath [] - case listToMaybe mcts of - Nothing -> return Nothing - Just (tm, cts) -> do - let - tm' = fromRational (toRational tm) - fmtime <- maybe (hsdevError $ OtherError "impossible: inspection time not set after call to `fileInspection`") return $ insp ^? inspectionAt - if fmtime < tm' - then return (Just (tm', cts)) - else do - void $ postSessionUpdater $ SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath) - return Nothing +{-# LANGUAGE FlexibleInstances, TypeOperators, TypeApplications, OverloadedStrings #-} + +module HsDev.Scan ( + -- * Enumerate functions + CompileFlag, ModuleToScan, ProjectToScan, PackageDbToScan, ScanContents(..), + EnumContents(..), + enumRescan, enumDependent, enumProject, enumSandbox, enumDirectory, + + -- * Scan + scanProjectFile, + scanModify, + upToDate, changedModules, + getFileContents, + + -- * Reexportss + module HsDev.Symbols.Types, + module Control.Monad.Except, + ) where + +import Control.DeepSeq +import Control.Lens +import Control.Monad.Except +import Data.Deps +import Data.Maybe (catMaybes, isJust, listToMaybe) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.List (intercalate) +import Data.Text (Text) +import Data.Text.Lens (unpacked) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Traversable (for) +import Data.Semigroup +import Data.String (IsString, fromString) +import qualified Data.Set as S +import System.Directory +import Text.Format +import qualified System.Log.Simple as Log + +import HsDev.Error +import qualified HsDev.Database.SQLite as SQLite +import HsDev.Database.SQLite.Select +import HsDev.Scan.Browse (browsePackages) +import HsDev.Server.Types (FileSource(..), SessionMonad(..), CommandMonad(..), inSessionGhc, postSessionUpdater) +import HsDev.Sandbox +import HsDev.Symbols +import HsDev.Symbols.Types +import HsDev.Display +import HsDev.Inspect +import HsDev.Util +import System.Directory.Paths + +-- | Compile flags +type CompileFlag = String +-- | Module with flags ready to scan +type ModuleToScan = (ModuleLocation, [CompileFlag], Maybe Text) +-- | Project ready to scan +type ProjectToScan = (Project, [ModuleToScan]) +-- | Package-db sandbox to scan (top of stack) +type PackageDbToScan = PackageDbStack + +-- | Scan info +data ScanContents = ScanContents { + modulesToScan :: [ModuleToScan], + projectsToScan :: [ProjectToScan], + sandboxesToScan :: [PackageDbStack] } + +instance NFData ScanContents where + rnf (ScanContents ms ps ss) = rnf ms `seq` rnf ps `seq` rnf ss + +instance Semigroup ScanContents where + ScanContents lm lp ls <> ScanContents rm rp rs = ScanContents + (uniqueBy (view _1) $ lm ++ rm) + (uniqueBy (view _1) $ lp ++ rp) + (ordNub $ ls ++ rs) + +instance Monoid ScanContents where + mempty = ScanContents [] [] [] + mappend l r = l <> r + +instance Formattable ScanContents where + formattable (ScanContents ms ps cs) = formattable str where + str :: String + str = format "modules: {}, projects: {}, package-dbs: {}" + ~~ (T.intercalate comma $ ms ^.. each . _1 . moduleFile) + ~~ (T.intercalate comma $ ps ^.. each . _1 . projectPath) + ~~ (intercalate comma $ map (display . topPackageDb) $ cs ^.. each) + comma :: IsString s => s + comma = fromString ", " + +class EnumContents a where + enumContents :: CommandMonad m => a -> m ScanContents + +instance EnumContents ModuleLocation where + enumContents mloc = return $ ScanContents [(mloc, [], Nothing)] [] [] + +instance EnumContents (Extensions ModuleLocation) where + enumContents ex = return $ ScanContents [(view entity ex, extensionsOpts ex, Nothing)] [] [] + +instance EnumContents Project where + enumContents = enumProject + +instance EnumContents PackageDbStack where + enumContents pdbs = return $ ScanContents [] [] (packageDbStacks pdbs) + +instance EnumContents Sandbox where + enumContents = enumSandbox + +instance {-# OVERLAPPABLE #-} EnumContents a => EnumContents [a] where + enumContents = liftM mconcat . tries . map enumContents + +instance {-# OVERLAPPING #-} EnumContents FilePath where + enumContents f + | haskellSource f = hsdevLiftIO $ do + mproj <- liftIO $ locateProject f + case mproj of + Nothing -> enumContents $ FileModule (fromFilePath f) Nothing + Just proj -> do + ScanContents _ [(_, mods)] _ <- enumContents proj + return $ ScanContents (filter ((== Just f) . preview (_1 . moduleFile . path)) mods) [] [] + | otherwise = enumDirectory f + +instance {-# OVERLAPPING #-} EnumContents Path where + enumContents = enumContents . view path + +instance EnumContents FileSource where + enumContents (FileSource f mcts) + | haskellSource (view path f) = do + ScanContents [(m, opts, _)] _ _ <- enumContents f + return $ ScanContents [(m, opts, mcts)] [] [] + | otherwise = return mempty + +-- | Enum rescannable (i.e. already scanned) file +enumRescan :: CommandMonad m => FilePath -> m ScanContents +enumRescan fpath = Log.scope "enum-rescan" $ do + ms <- SQLite.query @_ @(ModuleLocation SQLite.:. Inspection) + (toQuery $ mconcat [ + qModuleLocation "ml", + select_ ["ml.inspection_time", "ml.inspection_opts"], + where_ ["ml.file == ?"]]) + (SQLite.Only fpath) + case ms of + [] -> do + Log.sendLog Log.Warning $ "file {} not found" ~~ fpath + return mempty + ((mloc SQLite.:. insp):_) -> do + when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath + return $ ScanContents [(mloc, insp ^.. inspectionOpts . each . unpacked, Nothing)] [] [] + +-- | Enum file dependent +enumDependent :: CommandMonad m => FilePath -> m ScanContents +enumDependent fpath = Log.scope "enum-dependent" $ do + ms <- SQLite.query @_ @ModuleId + (toQuery $ qModuleId `mappend` where_ ["mu.file == ?"]) (SQLite.Only fpath) + case ms of + [] -> do + Log.sendLog Log.Warning $ "file {} not found" ~~ fpath + return mempty + (mid:_) -> do + when (length ms > 1) $ Log.sendLog Log.Warning $ "several modules with file == {} found, taking first one" ~~ fpath + let + mcabal = mid ^? moduleLocation . moduleProject . _Just . projectCabal + depList <- SQLite.query @_ @(Path, Path) "select d.module_file, d.depends_file from sources_depends as d, projects_modules_scope as ps where ps.cabal is ? and ps.module_id == d.module_id;" + (SQLite.Only mcabal) + let + rdeps = inverse . either (const mempty) id . flatten . mconcat . map (uncurry dep) $ depList + dependent = rdeps ^. ix (fromFilePath fpath) + liftM mconcat $ mapM (enumRescan . view path) dependent + +-- | Enum project sources +enumProject :: CommandMonad m => Project -> m ScanContents +enumProject p = hsdevLiftIO $ do + p' <- liftIO $ loadProject p + pdbs <- inSessionGhc $ searchPackageDbStack (view projectBuildTool p') (view projectPath p') + pkgs <- inSessionGhc $ liftM (S.fromList . map (view (package . packageName))) $ browsePackages [] pdbs + let + projOpts :: Path -> [Text] + projOpts f = map fromString $ concatMap makeOpts $ fileTargets p' f where + makeOpts :: Info -> [String] + makeOpts i = concat [ + ["-hide-all-packages"], + ["-package " ++ view (projectName . path) p'], + ["-package " ++ T.unpack dep' | dep' <- view infoDepends i, dep' `S.member` pkgs]] + srcs <- liftIO $ projectSources p' + let + mlocs = over each (\src -> over ghcOptions (++ projOpts (view entity src)) . over entity (\f -> FileModule f (Just p')) $ src) srcs + mods <- liftM modulesToScan $ enumContents mlocs + return $ ScanContents [] [(p', mods)] [] -- (sandboxCabals sboxes) + +-- | Enum sandbox +enumSandbox :: CommandMonad m => Sandbox -> m ScanContents +enumSandbox = (inSessionGhc . sandboxPackageDbStack) >=> enumContents + +-- | Enum directory modules +enumDirectory :: CommandMonad m => FilePath -> m ScanContents +enumDirectory dir = hsdevLiftIO $ do + cts <- liftIO $ traverseDirectory dir + let + projects = filter cabalFile cts + sources = filter haskellSource cts + dirs <- liftIO $ filterM doesDirectoryExist cts + sboxes <- liftM catMaybes $ triesMap (liftIO . findSandbox . fromFilePath) dirs + pdbs <- mapM enumSandbox sboxes + projs <- liftM mconcat $ triesMap (enumProject . project) projects + let + projPaths = map (view projectPath . fst) $ projectsToScan projs + standalone = map (`FileModule` Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) $ map fromFilePath sources + return $ mconcat [ + ScanContents [(s, [], Nothing) | s <- standalone] [] [], + projs, + mconcat pdbs] + +-- | Scan project file +scanProjectFile :: CommandMonad m => [String] -> Path -> m Project +scanProjectFile _ f = hsdevLiftIO $ do + proj <- (liftIO $ locateProject (view path f)) >>= maybe (hsdevError $ FileNotFound f) return + liftIO $ loadProject proj + +-- | Scan additional info and modify scanned module +scanModify :: CommandMonad m => ([String] -> Module -> m Module) -> InspectedModule -> m InspectedModule +scanModify f im = traverse f' im where + f' m = f (toListOf (inspection . inspectionOpts . each . unpacked) im) m + +-- | Is inspected module up to date? +upToDate :: SessionMonad m => ModuleLocation -> [String] -> Inspection -> m Bool +upToDate mloc opts insp = do + insp' <- liftIO $ moduleInspection mloc opts + mfinsp <- fmap join $ for (mloc ^? moduleFile) $ \fpath -> do + tm <- SQLite.query @_ @(SQLite.Only Double) "select mtime from file_contents where file = ?;" (SQLite.Only fpath) + return $ fmap (fileContentsInspection_ opts . fromRational . toRational . SQLite.fromOnly) (listToMaybe tm) + let + lastInsp = maybe insp' (max insp') mfinsp + return $ fresh insp lastInsp + +-- | Returns new (to scan) and changed (to rescan) modules +changedModules :: SessionMonad m => Map ModuleLocation Inspection -> [String] -> [ModuleToScan] -> m [ModuleToScan] +changedModules inspMap opts = filterM $ \m -> if isJust (m ^. _3) + then return True + else maybe + (return True) + (liftM not . upToDate (m ^. _1) (opts ++ (m ^. _2))) + (M.lookup (m ^. _1) inspMap) + +-- | Returns file contents if it was set and still actual +getFileContents :: SessionMonad m => Path -> m (Maybe (POSIXTime, Text)) +getFileContents fpath = do + mcts <- SQLite.query @_ @(Double, Text) "select mtime, contents from file_contents where file = ?;" (SQLite.Only fpath) + insp <- liftIO $ fileInspection fpath [] + case listToMaybe mcts of + Nothing -> return Nothing + Just (tm, cts) -> do + let + tm' = fromRational (toRational tm) + fmtime <- maybe (hsdevError $ OtherError "impossible: inspection time not set after call to `fileInspection`") return $ insp ^? inspectionAt + if fmtime < tm' + then return (Just (tm', cts)) + else do + void $ postSessionUpdater $ SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath) + return Nothing diff --git a/src/HsDev/Scan/Browse.hs b/src/HsDev/Scan/Browse.hs --- a/src/HsDev/Scan/Browse.hs +++ b/src/HsDev/Scan/Browse.hs @@ -1,229 +1,234 @@ -module HsDev.Scan.Browse ( - -- * List all packages - browsePackages, browsePackagesDeps, - -- * Scan cabal modules - listModules, - browseModules, browseModules', - -- * Helpers - uniqueModuleLocations, - readPackage, readPackageConfig, ghcModuleLocation, - packageConfigs, packageDbModules, lookupModule_, - modulesPackages, modulesPackagesGroups, withEachPackage, - - module Control.Monad.Except - ) where - -import Control.Arrow -import Control.Lens (preview) -import Control.Monad.Catch (MonadCatch, catch, SomeException) -import Control.Monad.Except -import Data.Function (on) -import Data.List (groupBy, sort) -import Data.Maybe -import Data.String (fromString) -import qualified Data.Set as S -import Data.Version -import Language.Haskell.Exts.Fixity -import Language.Haskell.Exts.Syntax (Assoc(..), QName(..), Name(Ident), ModuleName(..)) - -import Data.Deps -import Data.LookupTable -import HsDev.PackageDb -import HsDev.Symbols -import HsDev.Error -import HsDev.Tools.Ghc.Worker (GhcM, tmpSession, formatType) -import HsDev.Tools.Ghc.Compat as Compat -import HsDev.Util (ordNub, uniqueBy) -import System.Directory.Paths (fromFilePath, normalize) - -import qualified ConLike as GHC -import qualified DataCon as GHC -import qualified DynFlags as GHC -import qualified GHC -import qualified GHC.PackageDb as GHC -import qualified GhcMonad as GHC (liftIO) -import qualified Name as GHC -import qualified IdInfo as GHC -import qualified Packages as GHC -import qualified PatSyn as GHC -import qualified TyCon as GHC -import qualified Type as GHC -import qualified Var as GHC - --- | Browse packages -browsePackages :: [String] -> PackageDbStack -> GhcM [PackageConfig] -browsePackages opts dbs = do - tmpSession dbs opts - liftM (map readPackageConfig) packageConfigs - --- | Get packages with deps -browsePackagesDeps :: [String] -> PackageDbStack -> GhcM (Deps PackageConfig) -browsePackagesDeps opts dbs = do - tmpSession dbs opts - df <- GHC.getSessionDynFlags - cfgs <- packageConfigs - return $ mapDeps (toPkg df) $ mconcat [deps (Compat.unitId cfg) (Compat.depends df cfg) | cfg <- cfgs] - where - toPkg df' = readPackageConfig . getPackageDetails df' - --- | List modules from ghc, accepts ghc-opts, stack of package-db to get modules for --- and list of packages to explicitely expose them with '-package' flag, --- otherwise hidden packages won't be loaded -listModules :: [String] -> PackageDbStack -> [ModulePackage] -> GhcM [ModuleLocation] -listModules opts dbs pkgs = do - tmpSession dbs (opts ++ packagesOpts) - ms <- packageDbModules - return $ ordNub [ghcModuleLocation p m e | (p, m, e) <- ms] - where - packagesOpts = ["-package " ++ show p | p <- pkgs] - --- | Like @browseModules@, but groups modules by package and inspects each package separately --- Trying to fix error: when there are several same packages (of different version), only @Module@ from --- one of them can be lookuped and therefore modules from different version packages won't be actually inspected -browseModules :: [String] -> PackageDbStack -> [ModuleLocation] -> GhcM [InspectedModule] -browseModules opts dbs mlocs = do - tmpSession dbs opts - liftM concat . withEachPackage (const $ browseModules' opts) $ ordNub mlocs - --- | Inspect installed modules, doesn't set session and package flags! -browseModules' :: [String] -> [ModuleLocation] -> GhcM [InspectedModule] -browseModules' opts mlocs = do - ms <- packageDbModules - midTbl <- newLookupTable - sidTbl <- newLookupTable - let - lookupModuleId p' m' e' = lookupTable (ghcModuleLocation p' m' e') (ghcModuleId p' m' e') midTbl - liftM catMaybes $ sequence [browseModule' lookupModuleId (cacheInTableM sidTbl) p m e | (p, m, e) <- ms, ghcModuleLocation p m e `S.member` mlocs'] - where - browseModule' :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM (Maybe InspectedModule) - browseModule' modId' sym' p m e = tryT $ runInspect (ghcModuleLocation p m e) $ inspect_ (return $ InspectionAt 0 (map fromString opts)) (browseModule modId' sym' p m e) - mlocs' = S.fromList mlocs - -browseModule :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM Module -browseModule modId lookSym package' m exposed' = do - df <- GHC.getSessionDynFlags - mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return - ds <- mapM (\n -> lookSym n (toDecl df mi n)) (GHC.modInfoExports mi) - myModId <- modId package' m exposed' - let - dirAssoc GHC.InfixL = AssocLeft () - dirAssoc GHC.InfixR = AssocRight () - dirAssoc GHC.InfixN = AssocNone () - fixName o = Qual () (ModuleName () thisModule) (Ident () (GHC.occNameString o)) - return Module { - _moduleId = myModId, - _moduleDocs = Nothing, - _moduleImports = [], - _moduleExports = ds, - _moduleFixities = [Fixity (dirAssoc dir) pr (fixName oname) | (oname, (pr, dir)) <- map (second Compat.getFixity) (maybe [] GHC.mi_fixities (GHC.modInfoIface mi))], - _moduleScope = mempty, - _moduleSource = Nothing } - where - thisModule = GHC.moduleNameString (GHC.moduleName m) - mloc df m' = do - pkg' <- maybe (hsdevError $ OtherError $ "Error getting module package: " ++ GHC.moduleNameString (GHC.moduleName m')) return $ - GHC.lookupPackage df (moduleUnitId m') - modId pkg' m' (GHC.moduleName m `notElem` GHC.hiddenModules pkg') - toDecl df minfo n = do - tyInfo <- GHC.modInfoLookupName minfo n - tyResult <- maybe (GHC.lookupName n) (return . Just) tyInfo - declModId <- mloc df (GHC.nameModule n) - return Symbol { - _symbolId = SymbolId (fromString $ GHC.getOccString n) declModId, - _symbolDocs = Nothing, - _symbolPosition = Nothing, - _symbolInfo = fromMaybe (Function Nothing) (tyResult >>= showResult df) } - showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe SymbolInfo - showResult dflags (GHC.AnId i) = case GHC.idDetails i of - GHC.RecSelId p _ -> Just $ Selector (Just $ fromString $ formatType dflags $ GHC.varType i) parent ctors where - parent = fromString $ Compat.recSelParent p - ctors = map fromString $ Compat.recSelCtors p - GHC.ClassOpId cls -> Just $ Method (Just $ fromString $ formatType dflags $ GHC.varType i) (fromString $ GHC.getOccString cls) - _ -> Just $ Function (Just $ fromString $ formatType dflags $GHC.varType i) - showResult dflags (GHC.AConLike c) = case c of - GHC.RealDataCon d -> Just $ Constructor - (map (fromString . formatType dflags) $ GHC.dataConOrigArgTys d) - (fromString $ GHC.getOccString (GHC.dataConTyCon d)) - GHC.PatSynCon p -> Just $ PatConstructor - (map (fromString . formatType dflags) $ GHC.patSynArgs p) - Nothing - -- TODO: Deal with `patSynFieldLabels` and `patSynFieldType` - showResult dflags (GHC.ATyCon t) - | GHC.isTypeSynonymTyCon t = Just $ Type args ctx - | GHC.isPrimTyCon t = Just $ Type [] [] - | GHC.isNewTyCon t = Just $ NewType args ctx - | GHC.isDataTyCon t = Just $ Data args ctx - | GHC.isClassTyCon t = Just $ Class args ctx - | GHC.isTypeFamilyTyCon t = Just $ TypeFam args ctx Nothing - | GHC.isDataFamilyTyCon t = Just $ DataFam args ctx Nothing - | otherwise = Just $ Type [] [] - where - args = map (fromString . formatType dflags . GHC.mkTyVarTy) $ GHC.tyConTyVars t - ctx = case GHC.tyConClass_maybe t of - Nothing -> [] - Just cls -> map (fromString . formatType dflags) $ GHC.classSCTheta cls - showResult _ _ = Nothing - -tryT :: MonadCatch m => m a -> m (Maybe a) -tryT act = catch (fmap Just act) (const (return Nothing) . (id :: SomeException -> SomeException)) - --- | There can be same modules (same package name, version and module name) installed in different locations --- Select first one of such modules -uniqueModuleLocations :: [ModuleLocation] -> [ModuleLocation] -uniqueModuleLocations = uniqueBy nameId' where - nameId' mloc = (,) <$> (preview modulePackage mloc) <*> (preview installedModuleName mloc) - -readPackage :: GHC.PackageConfig -> ModulePackage -readPackage pc = ModulePackage (fromString $ GHC.packageNameString pc) (fromString $ showVersion (GHC.packageVersion pc)) - -readPackageConfig :: GHC.PackageConfig -> PackageConfig -readPackageConfig pc = PackageConfig - (readPackage pc) - (map (fromString . GHC.moduleNameString . Compat.exposedModuleName) $ GHC.exposedModules pc) - (GHC.exposed pc) - -ghcModuleLocation :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleLocation -ghcModuleLocation p m = InstalledModule (map (normalize . fromFilePath) $ GHC.libraryDirs p) (readPackage p) (fromString $ GHC.moduleNameString $ GHC.moduleName m) - -ghcModuleId :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleId -ghcModuleId p m e = ModuleId (fromString mname') (ghcModuleLocation p m e) where - mname' = GHC.moduleNameString $ GHC.moduleName m - -packageConfigs :: GhcM [GHC.PackageConfig] -packageConfigs = liftM (fromMaybe [] . pkgDatabase) GHC.getSessionDynFlags - -packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module, Bool)] -packageDbModules = do - pkgs <- packageConfigs - dflags <- GHC.getSessionDynFlags - return [(p, m, exposed') | - p <- pkgs, - (mn, exposed') <- zip (map Compat.exposedModuleName (GHC.exposedModules p)) (repeat True) ++ zip (GHC.hiddenModules p) (repeat False), - m <- lookupModule_ dflags mn] - --- Lookup module everywhere -lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module] -lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of - GHC.LookupFound m' _ -> [m'] - GHC.LookupMultiple ms -> map fst ms - GHC.LookupHidden ls rs -> map fst $ ls ++ rs - GHC.LookupNotFound _ -> [] - --- | Get modules packages -modulesPackages :: [ModuleLocation] -> [ModulePackage] -modulesPackages = ordNub . mapMaybe (preview modulePackage) - --- | Group modules by packages -modulesPackagesGroups :: [ModuleLocation] -> [(ModulePackage, [ModuleLocation])] -modulesPackagesGroups = map (first head . unzip) . groupBy ((==) `on` fst) . sort . mapMaybe (\m -> (,) <$> preview modulePackage m <*> pure m) - --- | Run action for each package with prepared '-package' flags -withEachPackage :: (ModulePackage -> [ModuleLocation] -> GhcM a) -> [ModuleLocation] -> GhcM [a] -withEachPackage act = mapM (uncurry act') . modulesPackagesGroups where - act' mpkg mlocs = setPackagesOpts >> act mpkg mlocs where - packagesOpts = "-hide-all-packages" : ["-package " ++ show p | p <- modulesPackages mlocs] - setPackagesOpts = void $ do - fs <- GHC.getSessionDynFlags - (fs', _, _) <- GHC.parseDynamicFlags (fs { GHC.packageFlags = [] }) (map GHC.noLoc packagesOpts) - (fs'', _) <- GHC.liftIO $ GHC.initPackages fs' - GHC.setSessionDynFlags fs'' +module HsDev.Scan.Browse ( + -- * List all packages + browsePackages, browsePackagesDeps, + -- * Scan cabal modules + listModules, + browseModules, browseModules', + -- * Helpers + uniqueModuleLocations, + readPackage, readPackageConfig, ghcModuleLocation, + packageConfigs, packageDbModules, lookupModule_, + modulesPackages, modulesPackagesGroups, withEachPackage, + + module Control.Monad.Except + ) where + +import Control.Arrow +import Control.Lens (view, preview) +import Control.Monad.Catch (MonadCatch, catch, SomeException) +import Control.Monad.Except +import Data.Function (on) +import Data.List (groupBy, sort) +import Data.Maybe +import Data.String (fromString) +import qualified Data.Set as S +import Data.Version +import Language.Haskell.Exts.Fixity +import Language.Haskell.Exts.Syntax (Assoc(..), QName(..), Name(Ident), ModuleName(..)) + +import Data.Deps +import Data.LookupTable +import HsDev.PackageDb +import HsDev.Symbols +import HsDev.Error +import HsDev.Tools.Ghc.Worker (GhcM, tmpSession, formatType) +import HsDev.Tools.Ghc.Compat as Compat +import HsDev.Util (ordNub, uniqueBy) +import System.Directory.Paths (fromFilePath, normalize) + +import qualified ConLike as GHC +import qualified DataCon as GHC +import qualified DynFlags as GHC +import qualified GHC +import qualified GHC.PackageDb as GHC +import qualified GhcMonad as GHC (liftIO) +import qualified Name as GHC +import qualified IdInfo as GHC +import qualified Packages as GHC +import qualified PatSyn as GHC +import qualified TyCon as GHC +import qualified Type as GHC +import qualified Var as GHC + +-- | Browse packages +browsePackages :: [String] -> PackageDbStack -> GhcM [PackageConfig] +browsePackages opts dbs = do + tmpSession dbs opts + liftM (map readPackageConfig) packageConfigs + +-- | Get packages with deps +browsePackagesDeps :: [String] -> PackageDbStack -> GhcM (Deps PackageConfig) +browsePackagesDeps opts dbs = do + tmpSession dbs opts + df <- GHC.getSessionDynFlags + cfgs <- packageConfigs + return $ mapDeps (toPkg df) $ mconcat [deps (Compat.unitId cfg) (Compat.depends df cfg) | cfg <- cfgs] + where + toPkg df' = readPackageConfig . getPackageDetails df' + +-- | List modules from ghc, accepts ghc-opts, stack of package-db to get modules for +-- and list of packages to explicitely expose them with '-package' flag, +-- otherwise hidden packages won't be loaded +listModules :: [String] -> PackageDbStack -> [ModulePackage] -> GhcM [ModuleLocation] +listModules opts dbs pkgs = do + tmpSession dbs (opts ++ packagesOpts) + ms <- packageDbModules + return $ ordNub [ghcModuleLocation p m e | (p, m, e) <- ms] + where + packagesOpts = ["-package " ++ show p | p <- pkgs] + +-- | Like @browseModules@, but groups modules by package and inspects each package separately +-- Trying to fix error: when there are several same packages (of different version), only @Module@ from +-- one of them can be lookuped and therefore modules from different version packages won't be actually inspected +browseModules :: [String] -> PackageDbStack -> [ModuleLocation] -> GhcM [InspectedModule] +browseModules opts dbs mlocs = do + tmpSession dbs opts + liftM (uniqueInspectedModules . concat) . withEachPackage (const $ browseModules' opts) $ ordNub mlocs + +-- | Inspect installed modules, doesn't set session and package flags! +browseModules' :: [String] -> [ModuleLocation] -> GhcM [InspectedModule] +browseModules' opts mlocs = do + ms <- packageDbModules + midTbl <- newLookupTable + sidTbl <- newLookupTable + let + lookupModuleId p' m' e' = lookupTable (ghcModuleLocation p' m' e') (ghcModuleId p' m' e') midTbl + liftM catMaybes $ sequence [browseModule' lookupModuleId (cacheInTableM sidTbl) p m e | (p, m, e) <- ms, ghcModuleLocation p m e `S.member` mlocs'] + where + browseModule' :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM (Maybe InspectedModule) + browseModule' modId' sym' p m e = tryT $ runInspect (ghcModuleLocation p m e) $ inspect_ (return $ InspectionAt 0 (map fromString opts)) (browseModule modId' sym' p m e) + mlocs' = S.fromList mlocs + +browseModule :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM Module +browseModule modId lookSym package' m exposed' = do + df <- GHC.getSessionDynFlags + mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return + ds <- mapM (\n -> lookSym n (toDecl df mi n)) (GHC.modInfoExports mi) + myModId <- modId package' m exposed' + let + dirAssoc GHC.InfixL = AssocLeft () + dirAssoc GHC.InfixR = AssocRight () + dirAssoc GHC.InfixN = AssocNone () + fixName o = Qual () (ModuleName () thisModule) (Ident () (GHC.occNameString o)) + return Module { + _moduleId = myModId, + _moduleDocs = Nothing, + _moduleImports = [], + _moduleExports = ds, + _moduleFixities = [Fixity (dirAssoc dir) pr (fixName oname) | (oname, (pr, dir)) <- map (second Compat.getFixity) (maybe [] GHC.mi_fixities (GHC.modInfoIface mi))], + _moduleScope = mempty, + _moduleSource = Nothing } + where + thisModule = GHC.moduleNameString (GHC.moduleName m) + mloc df m' = do + pkg' <- maybe (hsdevError $ OtherError $ "Error getting module package: " ++ GHC.moduleNameString (GHC.moduleName m')) return $ + GHC.lookupPackage df (moduleUnitId m') + modId pkg' m' (GHC.moduleName m `notElem` GHC.hiddenModules pkg') + toDecl df minfo n = do + tyInfo <- GHC.modInfoLookupName minfo n + tyResult <- maybe (GHC.lookupName n) (return . Just) tyInfo + declModId <- mloc df (GHC.nameModule n) + return Symbol { + _symbolId = SymbolId (fromString $ GHC.getOccString n) declModId, + _symbolDocs = Nothing, + _symbolPosition = Nothing, + _symbolInfo = fromMaybe (Function Nothing) (tyResult >>= showResult df) } + showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe SymbolInfo + showResult dflags (GHC.AnId i) = case GHC.idDetails i of + GHC.RecSelId p _ -> Just $ Selector (Just $ fromString $ formatType dflags $ GHC.varType i) parent ctors where + parent = fromString $ Compat.recSelParent p + ctors = map fromString $ Compat.recSelCtors p + GHC.ClassOpId cls -> Just $ Method (Just $ fromString $ formatType dflags $ GHC.varType i) (fromString $ GHC.getOccString cls) + _ -> Just $ Function (Just $ fromString $ formatType dflags $GHC.varType i) + showResult dflags (GHC.AConLike c) = case c of + GHC.RealDataCon d -> Just $ Constructor + (map (fromString . formatType dflags) $ GHC.dataConOrigArgTys d) + (fromString $ GHC.getOccString (GHC.dataConTyCon d)) + GHC.PatSynCon p -> Just $ PatConstructor + (map (fromString . formatType dflags) $ GHC.patSynArgs p) + Nothing + -- TODO: Deal with `patSynFieldLabels` and `patSynFieldType` + showResult dflags (GHC.ATyCon t) + | GHC.isTypeSynonymTyCon t = Just $ Type args ctx + | GHC.isPrimTyCon t = Just $ Type [] [] + | GHC.isNewTyCon t = Just $ NewType args ctx + | GHC.isDataTyCon t = Just $ Data args ctx + | GHC.isClassTyCon t = Just $ Class args ctx + | GHC.isTypeFamilyTyCon t = Just $ TypeFam args ctx Nothing + | GHC.isDataFamilyTyCon t = Just $ DataFam args ctx Nothing + | otherwise = Just $ Type [] [] + where + args = map (fromString . formatType dflags . GHC.mkTyVarTy) $ GHC.tyConTyVars t + ctx = case GHC.tyConClass_maybe t of + Nothing -> [] + Just cls -> map (fromString . formatType dflags) $ GHC.classSCTheta cls + showResult _ _ = Nothing + +tryT :: MonadCatch m => m a -> m (Maybe a) +tryT act = catch (fmap Just act) (const (return Nothing) . (id :: SomeException -> SomeException)) + +-- | There can be same modules (same package name, version and module name) installed in different locations +-- Select first one of such modules +uniqueModuleLocations :: [ModuleLocation] -> [ModuleLocation] +uniqueModuleLocations = uniqueBy nameId' where + nameId' mloc = (,) <$> (preview modulePackage mloc) <*> (preview installedModuleName mloc) + +-- | There can be one module inspected via different packages, we can leave only one of them +uniqueInspectedModules :: [InspectedModule] -> [InspectedModule] +uniqueInspectedModules = uniqueBy (nameId' . view inspectedKey) where + nameId' mloc = (,) <$> (preview modulePackage mloc) <*> (preview installedModuleName mloc) + +readPackage :: GHC.PackageConfig -> ModulePackage +readPackage pc = ModulePackage (fromString $ GHC.packageNameString pc) (fromString $ showVersion (GHC.packageVersion pc)) + +readPackageConfig :: GHC.PackageConfig -> PackageConfig +readPackageConfig pc = PackageConfig + (readPackage pc) + (map (fromString . GHC.moduleNameString . Compat.exposedModuleName) $ GHC.exposedModules pc) + (GHC.exposed pc) + +ghcModuleLocation :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleLocation +ghcModuleLocation p m = InstalledModule (map (normalize . fromFilePath) $ GHC.libraryDirs p) (readPackage p) (fromString $ GHC.moduleNameString $ GHC.moduleName m) + +ghcModuleId :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleId +ghcModuleId p m e = ModuleId (fromString mname') (ghcModuleLocation p m e) where + mname' = GHC.moduleNameString $ GHC.moduleName m + +packageConfigs :: GhcM [GHC.PackageConfig] +packageConfigs = liftM (fromMaybe [] . pkgDatabase) GHC.getSessionDynFlags + +packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module, Bool)] +packageDbModules = do + pkgs <- packageConfigs + dflags <- GHC.getSessionDynFlags + return [(p, m, exposed') | + p <- pkgs, + (mn, exposed') <- zip (map Compat.exposedModuleName (GHC.exposedModules p)) (repeat True) ++ zip (GHC.hiddenModules p) (repeat False), + m <- lookupModule_ dflags mn] + +-- Lookup module everywhere +lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module] +lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of + GHC.LookupFound m' _ -> [m'] + GHC.LookupMultiple ms -> map fst ms + GHC.LookupHidden ls rs -> map fst $ ls ++ rs + GHC.LookupNotFound _ -> [] + +-- | Get modules packages +modulesPackages :: [ModuleLocation] -> [ModulePackage] +modulesPackages = ordNub . mapMaybe (preview modulePackage) + +-- | Group modules by packages +modulesPackagesGroups :: [ModuleLocation] -> [(ModulePackage, [ModuleLocation])] +modulesPackagesGroups = map (first head . unzip) . groupBy ((==) `on` fst) . sort . mapMaybe (\m -> (,) <$> preview modulePackage m <*> pure m) + +-- | Run action for each package with prepared '-package' flags +withEachPackage :: (ModulePackage -> [ModuleLocation] -> GhcM a) -> [ModuleLocation] -> GhcM [a] +withEachPackage act = mapM (uncurry act') . modulesPackagesGroups where + act' mpkg mlocs = setPackagesOpts >> act mpkg mlocs where + packagesOpts = "-hide-all-packages" : ["-package " ++ show p | p <- modulesPackages mlocs] + setPackagesOpts = void $ do + fs <- GHC.getSessionDynFlags + (fs', _, _) <- GHC.parseDynamicFlags (fs { GHC.packageFlags = [] }) (map GHC.noLoc packagesOpts) + (fs'', _) <- GHC.liftIO $ GHC.initPackages fs' + GHC.setSessionDynFlags fs'' diff --git a/src/HsDev/Server/Base.hs b/src/HsDev/Server/Base.hs --- a/src/HsDev/Server/Base.hs +++ b/src/HsDev/Server/Base.hs @@ -1,414 +1,414 @@ -{-# LANGUAGE CPP, OverloadedStrings, CPP, PatternGuards, TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Server.Base ( - initLog, runServer, Server, - setupServer, shutdownServer, - startServer, startServer_, stopServer, withServer, withServer_, inServer, clientCommand, parseCommand, readCommand, - sendServer, sendServer_, - findPath, - processRequest, processClient, processClientSocket, - - unMmap, makeSocket, sockAddr, - - module HsDev.Server.Types, - module HsDev.Server.Message - ) where - -import Control.Concurrent -import Control.Concurrent.Async -import qualified Control.Concurrent.Chan as C -import Control.Lens (set, traverseOf, view) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Loops -import Control.Monad.Reader -import Control.Monad.Catch (bracket_, bracket, finally) -import Data.Aeson hiding (Result, Error) -import Data.Default -import qualified Data.ByteString.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Maybe -import Data.String (fromString) -import qualified Data.Text as T (pack) -import Data.Time.Clock.POSIX -import Options.Applicative (info, progDesc) -import System.Log.Simple hiding (Level(..), Message) -import qualified System.Log.Simple.Base as Log (level_) -import qualified System.Log.Simple as Log -import qualified Network.HTTP.Client as HTTP -import Network.Socket -import qualified Network.Socket.ByteString.Lazy as Net (getContents, sendAll) -import System.FilePath -import System.IO -import Text.Format ((~~)) - -import Control.Concurrent.Util -import qualified Control.Concurrent.FiniteChan as F -import Data.LookupTable -import Data.Maybe.JustIf -import System.Directory.Paths -import qualified System.Directory.Watcher as Watcher - -import qualified HsDev.Client.Commands as Client -import qualified HsDev.Database.SQLite as SQLite -import HsDev.Error -import qualified HsDev.Database.Update as Update -import HsDev.Inspect (getDefines) -import HsDev.Tools.Ghc.Worker hiding (Session) -import HsDev.Server.Types -import HsDev.Server.Message -import HsDev.Symbols.Location (ModuleLocation(..), globalDb) -import qualified HsDev.Watcher as W -import HsDev.Util - -#if mingw32_HOST_OS -import Data.Aeson.Types hiding (Result, Error) -import System.Win32.FileMapping.Memory (withMapFile, readMapFile) -import System.Win32.FileMapping.NamePool -#else -import System.Posix.Files (removeLink) -#endif - --- | Inits log chan and returns functions (print message, wait channel) -initLog :: ServerOpts -> IO SessionLog -initLog sopts = do - msgs <- C.newChan - l <- newLog (logCfg [("", Log.level_ . T.pack . serverLogLevel $ sopts)]) $ concat [ - [logHandler | not $ serverSilent sopts], - [chaner msgs], - [handler text (file f) | f <- maybeToList (serverLog sopts)]] - let - listenLog = C.dupChan msgs >>= C.getChanContents - return $ SessionLog l listenLog (stopLog l) - where - logHandler - | serverLogNoColor sopts = handler text console - | otherwise = handler text coloredConsole - --- | Run server -runServer :: ServerOpts -> ServerM IO () -> IO () -runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> maybeWithWatcher $ \mwatcher -> withLog (sessionLogger slog) $ do - waitSem <- liftIO $ newQSem 0 - sqlDb <- liftIO $ SQLite.initialize (fromMaybe SQLite.sharedMemory $ serverDbFile sopts) - clientChan <- liftIO F.newChan -#if mingw32_HOST_OS - mmapPool <- Just <$> liftIO (createPool "hsdev") -#endif - ghcw <- ghcWorker - liftIO $ inWorker ghcw $ tmpSession globalDb [] - defs <- liftIO getDefines - - session <- liftIO $ fixIO $ \sess -> do - let - setFileCts fpath Nothing = void $ withSession sess $ postSessionUpdater $ do - Log.sendLog Log.Trace $ "dropping file contents for {}" ~~ fpath - SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath) - setFileCts fpath (Just cts) = do - tm <- getPOSIXTime - withSession sess $ do - notChanged <- SQLite.query @_ @(SQLite.Only Bool) "select contents == ? from file_contents where file = ?;" (cts, fpath) - let - notChanged' = any SQLite.fromOnly notChanged - void $ postSessionUpdater $ do - Log.sendLog Log.Trace $ "setting file contents for {} with mtime = {}" ~~ fpath ~~ show tm - SQLite.execute "insert or replace into file_contents (file, contents, mtime) values (?, ?, ?);" (fpath, cts, (fromRational (toRational tm) :: Double)) - whenJustM (askSession sessionWatcher) $ \watcher -> unless notChanged' $ liftIO $ - writeChan (W.watcherChan watcher) (W.WatchedModule, W.Event W.Modified (view path fpath) tm) - - uw <- startWorker (withSession sess . withSqlConnection) id logAll - resolveEnvTable <- newLookupTable - httpManager <- HTTP.newManager HTTP.defaultManagerSettings - - return $ Session - sqlDb - (fromMaybe SQLite.sharedMemory $ serverDbFile sopts) - slog - mwatcher - setFileCts -#if mingw32_HOST_OS - mmapPool -#endif - ghcw - uw - resolveEnvTable - httpManager - (do - withLog (sessionLogger slog) $ Log.sendLog Log.Trace "stopping server" - signalQSem waitSem) - (waitQSem waitSem) - clientChan - defs - - _ <- fork $ do - emptyTask <- async $ return () - updaterTask <- newMVar emptyTask - tasksVar <- newMVar [] - whenJust mwatcher $ \watcher -> Update.onEvents_ watcher $ \evs -> withSession session $ - void $ Client.runClient def $ Update.processEvents (withSession session . inSessionUpdater . void . Client.runClient def . Update.applyUpdates def) updaterTask tasksVar evs - liftIO $ runReaderT (runServerM $ (watchDb >> act) `finally` closeSession) session - where - maybeWithWatcher fn - | serverWatchFS sopts = Watcher.withWatcher (fn . Just) - | otherwise = fn Nothing - closeSession = do - askSession sessionUpdater >>= liftIO . joinWorker - Log.sendLog Log.Info "updater worker stopped" - askSession sessionGhc >>= liftIO . joinWorker - Log.sendLog Log.Info "ghc worker stopped" - askSession sessionSqlDatabase >>= liftIO . SQLite.close - Log.sendLog Log.Info "sql connection closed" - - --- | Set initial watch: package-dbs, projects and standalone sources -watchDb :: SessionMonad m => m () -watchDb = do - whenJustM (askSession sessionWatcher) $ \w -> do - -- TODO: Implement watching package-dbs - cabals <- SQLite.query_ "select cabal from projects;" - projects <- mapM (SQLite.loadProject . SQLite.fromOnly) cabals - liftIO $ mapM_ (\proj -> W.watchProject w proj []) projects - - files <- SQLite.query_ "select file from modules where file is not null and cabal is null;" - liftIO $ mapM_ (\(SQLite.Only f) -> W.watchModule w (FileModule f Nothing)) files - -type Server = Worker (ServerM IO) - --- | Start listening for incoming connections -setupServer :: ServerOpts -> ServerM IO () -setupServer sopts = do - q <- liftIO $ newQSem 0 - clientChan <- askSession sessionClients - session <- getSession - _ <- liftIO $ async $ withSession session $ Log.scope "listener" $ flip finally serverExit $ - bracket (liftIO $ makeSocket (serverPort sopts)) (liftIO . close) $ \s -> do - liftIO $ do - setSocketOption s ReuseAddr 1 - sockAddr':_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just $ show $ serverPort sopts) - bind s (addrAddress sockAddr') - listen s maxListenQueue - forever $ logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ do - Log.sendLog Log.Trace "accepting connection..." - liftIO $ signalQSem q - (s', addr') <- liftIO $ accept s - Log.sendLog Log.Trace $ "accepted {}" ~~ show addr' - fork $ withSession session $ Log.scope (T.pack $ show addr') $ - logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ - flip finally (liftIO $ close s') $ - bracket (liftIO newEmptyMVar) (liftIO . (`putMVar` ())) $ \done -> do - me <- liftIO myThreadId - let - timeoutWait = withSession session $ do - notDone <- liftIO $ isEmptyMVar done - when notDone $ do - Log.sendLog Log.Trace $ "waiting for {} to complete" ~~ show addr' - waitAsync <- liftIO $ async $ do - threadDelay 1000000 - killThread me - liftIO $ void $ waitCatch waitAsync - liftIO $ void $ F.sendChan clientChan timeoutWait - processClientSocket (show addr') s' - - Log.sendLog Log.Trace "waiting for starting accept thread..." - liftIO $ waitQSem q - logIO "error writing to stdout: " (Log.sendLog Log.Error . fromString) $ liftIO $ putStrLn $ "Server started at port {}" ~~ serverPort sopts - Log.sendLog Log.Info $ "Server started at port {}" ~~ serverPort sopts - --- | Shutdown server -shutdownServer :: ServerOpts -> ServerM IO () -shutdownServer sopts = do - Log.sendLog Log.Trace "waiting for accept thread..." - serverWait - Log.sendLog Log.Trace "accept thread stopped" - liftIO $ unlink (serverPort sopts) - Log.sendLog Log.Trace "waiting for clients..." - serverWaitClients - Log.sendLog Log.Info "server stopped" - -startServer :: ServerOpts -> IO Server -startServer sopts = startWorker (runServer sopts) (bracket_ (setupServer sopts) (shutdownServer sopts)) logAll - --- Tiny version with no network stuff -startServer_ :: ServerOpts -> IO Server -startServer_ sopts = startWorker (runServer sopts) id logAll - -stopServer :: Server -> IO () -stopServer s = sendServer_ s ["exit"] >> joinWorker s - -withServer :: ServerOpts -> (Server -> IO a) -> IO a -withServer sopts = bracket (startServer sopts) stopServer - -withServer_ :: ServerOpts -> (Server -> IO a) -> IO a -withServer_ sopts = bracket (startServer_ sopts) stopServer - -inServer :: Server -> ServerM IO a -> IO a -inServer = inWorker - -clientCommand :: CommandOptions -> Command -> ServerM IO Result -clientCommand copts c = do - c' <- liftIO $ canonicalize c - Client.runClient copts (Client.runCommand c') - -parseCommand :: [String] -> Either String Command -parseCommand = parseArgs "hsdev" (info cmdP (progDesc "hsdev tool")) - -readCommand :: [String] -> Command -readCommand = either error id . parseCommand - -sendServer :: Server -> CommandOptions -> [String] -> IO Result -sendServer srv copts args = case parseCommand args of - Left e -> hsdevError $ RequestError e (unwords args) - Right c -> inServer srv (clientCommand copts c) - -sendServer_ :: Server -> [String] -> IO Result -sendServer_ srv = sendServer srv def - -chaner :: C.Chan Log.Message -> Consumer Log.Message -chaner ch = return $ C.writeChan ch - -findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath -findPath copts f = liftIO $ canonicalize (normalise f') where - f' = absolutise (fromFilePath $ commandOptionsRoot copts) f - --- | Process request, notifications can be sent during processing -processRequest :: SessionMonad m => CommandOptions -> Command -> m Result -processRequest copts c = do - c' <- paths (findPath copts) c - s <- getSession - withSession s $ Client.runClient copts $ Client.runCommand c' - --- | Process client, listen for requests and process them -processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m () -processClient name rchan send' = do - Log.sendLog Log.Info "connected" - respChan <- liftIO newChan - fork $ getChanContents respChan >>= mapM_ (send' . encodeMessage) - linkVar <- liftIO $ newMVar $ return () - s <- getSession - exit <- askSession sessionExit - let - answer :: SessionMonad m => Msg (Message Response) -> m () - answer m = do - unless (isNotification $ view (msg . message) m) $ - Log.sendLog Log.Trace $ "responsed << {}" ~~ ellipsis (fromUtf8 (encode $ view (msg . message) m)) - liftIO $ writeChan respChan m - where - ellipsis :: String -> String - ellipsis str - | length str < 100 = str - | otherwise = take 100 str ++ "..." - - flip finally (disconnected linkVar) $ - whileJust_ (liftIO $ F.getChan rchan) $ \req' -> do - Log.sendLog Log.Trace $ "received >> {}" ~~ fromUtf8 req' - case decodeMessage req' of - Left em -> do - Log.sendLog Log.Warning $ "Invalid request {}" ~~ fromUtf8 req' - answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em - Right m -> fork $ withSession s $ Log.scope (T.pack name) $ Log.scope "req" $ - Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do - resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do - let - onNotify n - | silent = return () - | otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer - Log.sendLog Log.Trace $ "requested >> {}" ~~ fromUtf8 (encode c) - resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $ - processRequest - CommandOptions { - commandOptionsRoot = cdir, - commandOptionsNotify = withSession s . onNotify, - commandOptionsLink = void (swapMVar linkVar exit), - commandOptionsHold = forever (F.getChan rchan) } - c - mmap' noFile resp - answer resp' - where - handleTimeout :: Int -> IO Result -> IO Result - handleTimeout 0 = id - handleTimeout tm = fmap (fromMaybe $ Error $ OtherError "timeout") . timeout tm - - mmap' :: SessionMonad m => Bool -> Response -> m Response -#if mingw32_HOST_OS - mmap' False r = do - mpool <- askSession sessionMmapPool - case mpool of - Just pool -> liftIO $ mmap pool r - Nothing -> return r -#endif - mmap' _ r = return r - - -- Call on disconnected, either no action or exit command - disconnected :: SessionMonad m => MVar (IO ()) -> m () - disconnected var = do - Log.sendLog Log.Info "disconnected" - liftIO $ join $ takeMVar var - --- | Process client by socket -processClientSocket :: SessionMonad m => String -> Socket -> m () -processClientSocket name s = do - recvChan <- liftIO F.newChan - fork $ finally - (Net.getContents s >>= mapM_ (F.sendChan recvChan) . L.lines) - (F.closeChan recvChan) - processClient name recvChan (sendLine s) - where - sendLine :: Socket -> ByteString -> IO () - sendLine sock bs = Net.sendAll sock $ L.snoc bs '\n' - -#if mingw32_HOST_OS -newtype MmapFile = MmapFile String - -instance ToJSON MmapFile where - toJSON (MmapFile f) = object ["file" .= f] - -instance FromJSON MmapFile where - parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file" - --- | Push message to mmap and return response which points to this mmap -mmap :: Pool -> Response -> IO Response -mmap mmapPool r - | L.length msg' <= 1024 = return r - | otherwise = do - rvar <- newEmptyMVar - _ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ catchError - (withMapFile mmapName (L.toStrict msg') $ liftIO $ do - _ <- tryPutMVar rvar $ result $ MmapFile mmapName - -- give 10 seconds for client to read data - threadDelay 10000000) - (\_ -> liftIO $ void $ tryPutMVar rvar r) - takeMVar rvar - where - msg' = encode r -#endif - --- | If response points to mmap, get its contents and parse -unMmap :: Response -> IO Response -#if mingw32_HOST_OS -unMmap (Response (Right (Result v))) - | Just (MmapFile f) <- parseMaybe parseJSON v = do - cts <- runExceptT (fmap L.fromStrict (readMapFile f)) - case cts of - Left _ -> return $ responseError $ ResponseError "can't read map view of file" f - Right r' -> case eitherDecode r' of - Left e' -> return $ responseError $ ResponseError ("can't parse response: {}" ~~ e') (fromUtf8 r') - Right r'' -> return r'' -#endif -unMmap r = return r - -makeSocket :: ConnectionPort -> IO Socket -makeSocket (NetworkPort _) = socket AF_INET Stream defaultProtocol -makeSocket (UnixPort _) = socket AF_UNIX Stream defaultProtocol - -sockAddr :: ConnectionPort -> HostAddress -> SockAddr -sockAddr (NetworkPort p) addr = SockAddrInet (fromIntegral p) addr -sockAddr (UnixPort s) _ = SockAddrUnix s - -unlink :: ConnectionPort -> IO () -unlink (NetworkPort _) = return () -#if mingw32_HOST_OS -unlink (UnixPort _) = return () -#else -unlink (UnixPort s) = removeLink s -#endif +{-# LANGUAGE CPP, OverloadedStrings, CPP, PatternGuards, TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Server.Base ( + initLog, runServer, Server, + setupServer, shutdownServer, + startServer, startServer_, stopServer, withServer, withServer_, inServer, clientCommand, parseCommand, readCommand, + sendServer, sendServer_, + findPath, + processRequest, processClient, processClientSocket, + + unMmap, makeSocket, sockAddr, + + module HsDev.Server.Types, + module HsDev.Server.Message + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Concurrent.Chan as C +import Control.Lens (set, traverseOf, view) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Loops +import Control.Monad.Reader +import Control.Monad.Catch (bracket_, bracket, finally) +import Data.Aeson hiding (Result, Error) +import Data.Default +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Maybe +import Data.String (fromString) +import qualified Data.Text as T (pack) +import Data.Time.Clock.POSIX +import Options.Applicative (info, progDesc) +import System.Log.Simple hiding (Level(..), Message) +import qualified System.Log.Simple.Base as Log (level_) +import qualified System.Log.Simple as Log +import qualified Network.HTTP.Client as HTTP +import Network.Socket +import qualified Network.Socket.ByteString.Lazy as Net (getContents, sendAll) +import System.FilePath +import System.IO +import Text.Format ((~~)) + +import Control.Concurrent.Util +import qualified Control.Concurrent.FiniteChan as F +import Data.LookupTable +import Data.Maybe.JustIf +import System.Directory.Paths +import qualified System.Directory.Watcher as Watcher + +import qualified HsDev.Client.Commands as Client +import qualified HsDev.Database.SQLite as SQLite +import HsDev.Error +import qualified HsDev.Database.Update as Update +import HsDev.Inspect (getDefines) +import HsDev.Tools.Ghc.Worker hiding (Session) +import HsDev.Server.Types +import HsDev.Server.Message +import HsDev.Symbols.Location (ModuleLocation(..), globalDb) +import qualified HsDev.Watcher as W +import HsDev.Util + +#if mingw32_HOST_OS +import Data.Aeson.Types hiding (Result, Error) +import System.Win32.FileMapping.Memory (withMapFile, readMapFile) +import System.Win32.FileMapping.NamePool +#else +import System.Posix.Files (removeLink) +#endif + +-- | Inits log chan and returns functions (print message, wait channel) +initLog :: ServerOpts -> IO SessionLog +initLog sopts = do + msgs <- C.newChan + l <- newLog (logCfg [("", Log.level_ . T.pack . serverLogLevel $ sopts)]) $ concat [ + [logHandler | not $ serverSilent sopts], + [chaner msgs], + [handler text (file f) | f <- maybeToList (serverLog sopts)]] + let + listenLog = C.dupChan msgs >>= C.getChanContents + return $ SessionLog l listenLog (stopLog l) + where + logHandler + | serverLogNoColor sopts = handler text console + | otherwise = handler text coloredConsole + +-- | Run server +runServer :: ServerOpts -> ServerM IO () -> IO () +runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> maybeWithWatcher $ \mwatcher -> withLog (sessionLogger slog) $ do + waitSem <- liftIO $ newQSem 0 + sqlDb <- liftIO $ SQLite.initialize (fromMaybe SQLite.sharedMemory $ serverDbFile sopts) + clientChan <- liftIO F.newChan +#if mingw32_HOST_OS + mmapPool <- Just <$> liftIO (createPool "hsdev") +#endif + ghcw <- ghcWorker + liftIO $ inWorker ghcw $ tmpSession globalDb [] + defs <- liftIO getDefines + + session <- liftIO $ fixIO $ \sess -> do + let + setFileCts fpath Nothing = void $ withSession sess $ postSessionUpdater $ do + Log.sendLog Log.Trace $ "dropping file contents for {}" ~~ fpath + SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath) + setFileCts fpath (Just cts) = do + tm <- getPOSIXTime + withSession sess $ do + notChanged <- SQLite.query @_ @(SQLite.Only Bool) "select contents == ? from file_contents where file = ?;" (cts, fpath) + let + notChanged' = any SQLite.fromOnly notChanged + void $ postSessionUpdater $ do + Log.sendLog Log.Trace $ "setting file contents for {} with mtime = {}" ~~ fpath ~~ show tm + SQLite.execute "insert or replace into file_contents (file, contents, mtime) values (?, ?, ?);" (fpath, cts, (fromRational (toRational tm) :: Double)) + whenJustM (askSession sessionWatcher) $ \watcher -> unless notChanged' $ liftIO $ + writeChan (W.watcherChan watcher) (W.WatchedModule, W.Event W.Modified (view path fpath) tm) + + uw <- startWorker (withSession sess . withSqlConnection) id logAll + resolveEnvTable <- newLookupTable + httpManager <- HTTP.newManager HTTP.defaultManagerSettings + + return $ Session + sqlDb + (fromMaybe SQLite.sharedMemory $ serverDbFile sopts) + slog + mwatcher + setFileCts +#if mingw32_HOST_OS + mmapPool +#endif + ghcw + uw + resolveEnvTable + httpManager + (do + withLog (sessionLogger slog) $ Log.sendLog Log.Trace "stopping server" + signalQSem waitSem) + (waitQSem waitSem) + clientChan + defs + + _ <- fork $ do + emptyTask <- async $ return () + updaterTask <- newMVar emptyTask + tasksVar <- newMVar [] + whenJust mwatcher $ \watcher -> Update.onEvents_ watcher $ \evs -> withSession session $ + void $ Client.runClient def $ Update.processEvents (withSession session . inSessionUpdater . void . Client.runClient def . Update.applyUpdates def) updaterTask tasksVar evs + liftIO $ runReaderT (runServerM $ (watchDb >> act) `finally` closeSession) session + where + maybeWithWatcher fn + | serverWatchFS sopts = Watcher.withWatcher (fn . Just) + | otherwise = fn Nothing + closeSession = do + askSession sessionUpdater >>= liftIO . joinWorker + Log.sendLog Log.Info "updater worker stopped" + askSession sessionGhc >>= liftIO . joinWorker + Log.sendLog Log.Info "ghc worker stopped" + askSession sessionSqlDatabase >>= liftIO . SQLite.close + Log.sendLog Log.Info "sql connection closed" + + +-- | Set initial watch: package-dbs, projects and standalone sources +watchDb :: SessionMonad m => m () +watchDb = do + whenJustM (askSession sessionWatcher) $ \w -> do + -- TODO: Implement watching package-dbs + cabals <- SQLite.query_ "select cabal from projects;" + projects <- mapM (SQLite.loadProject . SQLite.fromOnly) cabals + liftIO $ mapM_ (\proj -> W.watchProject w proj []) projects + + files <- SQLite.query_ "select file from modules where file is not null and cabal is null;" + liftIO $ mapM_ (\(SQLite.Only f) -> W.watchModule w (FileModule f Nothing)) files + +type Server = Worker (ServerM IO) + +-- | Start listening for incoming connections +setupServer :: ServerOpts -> ServerM IO () +setupServer sopts = do + q <- liftIO $ newQSem 0 + clientChan <- askSession sessionClients + session <- getSession + _ <- liftIO $ async $ withSession session $ Log.scope "listener" $ flip finally serverExit $ + bracket (liftIO $ makeSocket (serverPort sopts)) (liftIO . close) $ \s -> do + liftIO $ do + setSocketOption s ReuseAddr 1 + sockAddr':_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just $ show $ serverPort sopts) + bind s (addrAddress sockAddr') + listen s maxListenQueue + forever $ logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ do + Log.sendLog Log.Trace "accepting connection..." + liftIO $ signalQSem q + (s', addr') <- liftIO $ accept s + Log.sendLog Log.Trace $ "accepted {}" ~~ show addr' + fork $ withSession session $ Log.scope (T.pack $ show addr') $ + logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ + flip finally (liftIO $ close s') $ + bracket (liftIO newEmptyMVar) (liftIO . (`putMVar` ())) $ \done -> do + me <- liftIO myThreadId + let + timeoutWait = withSession session $ do + notDone <- liftIO $ isEmptyMVar done + when notDone $ do + Log.sendLog Log.Trace $ "waiting for {} to complete" ~~ show addr' + waitAsync <- liftIO $ async $ do + threadDelay 1000000 + killThread me + liftIO $ void $ waitCatch waitAsync + liftIO $ void $ F.sendChan clientChan timeoutWait + processClientSocket (show addr') s' + + Log.sendLog Log.Trace "waiting for starting accept thread..." + liftIO $ waitQSem q + logIO "error writing to stdout: " (Log.sendLog Log.Error . fromString) $ liftIO $ putStrLn $ "Server started at port {}" ~~ serverPort sopts + Log.sendLog Log.Info $ "Server started at port {}" ~~ serverPort sopts + +-- | Shutdown server +shutdownServer :: ServerOpts -> ServerM IO () +shutdownServer sopts = do + Log.sendLog Log.Trace "waiting for accept thread..." + serverWait + Log.sendLog Log.Trace "accept thread stopped" + liftIO $ unlink (serverPort sopts) + Log.sendLog Log.Trace "waiting for clients..." + serverWaitClients + Log.sendLog Log.Info "server stopped" + +startServer :: ServerOpts -> IO Server +startServer sopts = startWorker (runServer sopts) (bracket_ (setupServer sopts) (shutdownServer sopts)) logAll + +-- Tiny version with no network stuff +startServer_ :: ServerOpts -> IO Server +startServer_ sopts = startWorker (runServer sopts) id logAll + +stopServer :: Server -> IO () +stopServer s = sendServer_ s ["exit"] >> joinWorker s + +withServer :: ServerOpts -> (Server -> IO a) -> IO a +withServer sopts = bracket (startServer sopts) stopServer + +withServer_ :: ServerOpts -> (Server -> IO a) -> IO a +withServer_ sopts = bracket (startServer_ sopts) stopServer + +inServer :: Server -> ServerM IO a -> IO a +inServer = inWorker + +clientCommand :: CommandOptions -> Command -> ServerM IO Result +clientCommand copts c = do + c' <- liftIO $ canonicalize c + Client.runClient copts (Client.runCommand c') + +parseCommand :: [String] -> Either String Command +parseCommand = parseArgs "hsdev" (info cmdP (progDesc "hsdev tool")) + +readCommand :: [String] -> Command +readCommand = either error id . parseCommand + +sendServer :: Server -> CommandOptions -> [String] -> IO Result +sendServer srv copts args = case parseCommand args of + Left e -> hsdevError $ RequestError e (unwords args) + Right c -> inServer srv (clientCommand copts c) + +sendServer_ :: Server -> [String] -> IO Result +sendServer_ srv = sendServer srv def + +chaner :: C.Chan Log.Message -> Consumer Log.Message +chaner ch = return $ C.writeChan ch + +findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath +findPath copts f = liftIO $ canonicalize (normalise f') where + f' = absolutise (fromFilePath $ commandOptionsRoot copts) f + +-- | Process request, notifications can be sent during processing +processRequest :: SessionMonad m => CommandOptions -> Command -> m Result +processRequest copts c = do + c' <- paths (findPath copts) c + s <- getSession + withSession s $ Client.runClient copts $ Client.runCommand c' + +-- | Process client, listen for requests and process them +processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m () +processClient name rchan send' = do + Log.sendLog Log.Info "connected" + respChan <- liftIO newChan + fork $ getChanContents respChan >>= mapM_ (send' . encodeMessage) + linkVar <- liftIO $ newMVar $ return () + s <- getSession + exit <- askSession sessionExit + let + answer :: SessionMonad m => Msg (Message Response) -> m () + answer m = do + unless (isNotification $ view (msg . message) m) $ + Log.sendLog Log.Trace $ "responsed << {}" ~~ ellipsis (fromUtf8 (encode $ view (msg . message) m)) + liftIO $ writeChan respChan m + where + ellipsis :: String -> String + ellipsis str + | length str < 100 = str + | otherwise = take 100 str ++ "..." + + flip finally (disconnected linkVar) $ + whileJust_ (liftIO $ F.getChan rchan) $ \req' -> do + Log.sendLog Log.Trace $ "received >> {}" ~~ fromUtf8 req' + case decodeMessage req' of + Left em -> do + Log.sendLog Log.Warning $ "Invalid request {}" ~~ fromUtf8 req' + answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em + Right m -> fork $ withSession s $ Log.scope (T.pack name) $ Log.scope "req" $ + Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do + resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do + let + onNotify n + | silent = return () + | otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer + Log.sendLog Log.Trace $ "requested >> {}" ~~ fromUtf8 (encode c) + resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $ + processRequest + CommandOptions { + commandOptionsRoot = cdir, + commandOptionsNotify = withSession s . onNotify, + commandOptionsLink = void (swapMVar linkVar exit), + commandOptionsHold = forever (F.getChan rchan) } + c + mmap' noFile resp + answer resp' + where + handleTimeout :: Int -> IO Result -> IO Result + handleTimeout 0 = id + handleTimeout tm = fmap (fromMaybe $ Error $ OtherError "timeout") . timeout tm + + mmap' :: SessionMonad m => Bool -> Response -> m Response +#if mingw32_HOST_OS + mmap' False r = do + mpool <- askSession sessionMmapPool + case mpool of + Just pool -> liftIO $ mmap pool r + Nothing -> return r +#endif + mmap' _ r = return r + + -- Call on disconnected, either no action or exit command + disconnected :: SessionMonad m => MVar (IO ()) -> m () + disconnected var = do + Log.sendLog Log.Info "disconnected" + liftIO $ join $ takeMVar var + +-- | Process client by socket +processClientSocket :: SessionMonad m => String -> Socket -> m () +processClientSocket name s = do + recvChan <- liftIO F.newChan + fork $ finally + (Net.getContents s >>= mapM_ (F.sendChan recvChan) . L.lines) + (F.closeChan recvChan) + processClient name recvChan (sendLine s) + where + sendLine :: Socket -> ByteString -> IO () + sendLine sock bs = Net.sendAll sock $ L.snoc bs '\n' + +#if mingw32_HOST_OS +newtype MmapFile = MmapFile String + +instance ToJSON MmapFile where + toJSON (MmapFile f) = object ["file" .= f] + +instance FromJSON MmapFile where + parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file" + +-- | Push message to mmap and return response which points to this mmap +mmap :: Pool -> Response -> IO Response +mmap mmapPool r + | L.length msg' <= 1024 = return r + | otherwise = do + rvar <- newEmptyMVar + _ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ catchError + (withMapFile mmapName (L.toStrict msg') $ liftIO $ do + _ <- tryPutMVar rvar $ result $ MmapFile mmapName + -- give 10 seconds for client to read data + threadDelay 10000000) + (\_ -> liftIO $ void $ tryPutMVar rvar r) + takeMVar rvar + where + msg' = encode r +#endif + +-- | If response points to mmap, get its contents and parse +unMmap :: Response -> IO Response +#if mingw32_HOST_OS +unMmap (Response (Right (Result v))) + | Just (MmapFile f) <- parseMaybe parseJSON v = do + cts <- runExceptT (fmap L.fromStrict (readMapFile f)) + case cts of + Left _ -> return $ responseError $ ResponseError "can't read map view of file" f + Right r' -> case eitherDecode r' of + Left e' -> return $ responseError $ ResponseError ("can't parse response: {}" ~~ e') (fromUtf8 r') + Right r'' -> return r'' +#endif +unMmap r = return r + +makeSocket :: ConnectionPort -> IO Socket +makeSocket (NetworkPort _) = socket AF_INET Stream defaultProtocol +makeSocket (UnixPort _) = socket AF_UNIX Stream defaultProtocol + +sockAddr :: ConnectionPort -> HostAddress -> SockAddr +sockAddr (NetworkPort p) addr = SockAddrInet (fromIntegral p) addr +sockAddr (UnixPort s) _ = SockAddrUnix s + +unlink :: ConnectionPort -> IO () +unlink (NetworkPort _) = return () +#if mingw32_HOST_OS +unlink (UnixPort _) = return () +#else +unlink (UnixPort s) = removeLink s +#endif diff --git a/src/HsDev/Server/Commands.hs b/src/HsDev/Server/Commands.hs --- a/src/HsDev/Server/Commands.hs +++ b/src/HsDev/Server/Commands.hs @@ -1,193 +1,193 @@ -{-# LANGUAGE OverloadedStrings, CPP, LambdaCase, TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Server.Commands ( - ServerCommand(..), ServerOpts(..), ClientOpts(..), - Request(..), - Msg, isLisp, msg, jsonMsg, lispMsg, encodeMessage, decodeMessage, - sendCommand, runServerCommand, - findPath, - processRequest, processClient, processClientSocket, - module HsDev.Server.Types - ) where - -import Control.Concurrent.Async -import Control.Lens (set, view) -import Control.Monad -import Control.Monad.Catch (bracket, bracket_) -import Data.Aeson hiding (Result, Error) -import qualified Data.Aeson as A -import Data.Aeson.Encode.Pretty -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Maybe -import Network.Socket hiding (connect) -import qualified Network.Socket as Net hiding (send) -import System.Directory -import System.Exit -import System.IO -import qualified System.Log.Simple as Log - -import GHC (getSessionDynFlags) - -import Text.Format ((~~), (~%)) -import Text.Format.Colored (coloredLine) - -import HsDev.Server.Base -import HsDev.Server.Types -import HsDev.Error -import HsDev.Util -import HsDev.Version -import HsDev.PackageDb.Types (globalDb) -import HsDev.Tools.Ghc.Worker -import qualified HsDev.Tools.Ghc.System as System - -#if mingw32_HOST_OS -import Data.List -import HsDev.Tools.Base (runTool_) -import System.Environment -import System.Win32.PowerShell (escape, quote, quoteDouble) -#else -import Control.Exception (SomeException, handle) -import System.Posix.Process -import System.Posix.IO -#endif - -sendCommand :: ClientOpts -> Bool -> Command -> (Notification -> IO a) -> IO Result -sendCommand copts noFile c onNotification = do - asyncAct <- async sendReceive - res <- waitCatch asyncAct - case res of - Left e -> return $ Error $ OtherError (show e) - Right r -> return r - where - sendReceive = do - curDir <- getCurrentDirectory - input <- if clientStdin copts - then Just <$> L.getContents - else return $ toUtf8 <$> Nothing -- arg "data" copts - let - parseData :: L.ByteString -> IO Value - parseData cts = case eitherDecode cts of - Left err -> putStrLn ("Invalid data: " ++ err) >> exitFailure - Right v -> return v - _ <- traverse parseData input -- FIXME: Not used! - - s <- makeSocket (clientPort copts) - sockAddr':_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just $ show $ clientPort copts) - Net.connect s (addrAddress sockAddr') - bracket (socketToHandle s ReadWriteMode) hClose $ \h -> do - L.hPutStrLn h $ encode $ Message Nothing $ Request c curDir noFile (clientTimeout copts) (clientSilent copts) - hFlush h - peekResponse h - - peekResponse h = do - resp <- hGetLineBS h - parseResponse h resp - - parseResponse h str = case eitherDecode str of - Left e -> return $ Error $ ResponseError ("can't parse: {}" ~~ e) (fromUtf8 str) - Right (Message _ r) -> do - Response r' <- unMmap r - case r' of - Left n -> onNotification n >> peekResponse h - Right res -> return res - -runServerCommand :: ServerCommand -> IO () -runServerCommand (Version showCompiler) - | showCompiler = do - w <- Log.noLog ghcWorker - compVer <- inWorker w $ do - workerSession SessionGhc globalDb [] - df <- getSessionDynFlags - return $ System.formatBuildPath "{compiler}-{version}" (System.buildInfo df) - putStrLn $ $cabalVersion ++ " " ++ compVer - joinWorker w - | otherwise = putStrLn $cabalVersion -runServerCommand (Start sopts) = do -#if mingw32_HOST_OS - let - args = "run" : serverOptsArgs sopts - myExe <- getExecutablePath - curDir <- getCurrentDirectory - let - -- one escape for start-process and other for callable process - -- seems, that start-process just concats arguments into one string - -- start-process foo 'bar baz' ⇒ foo bar baz -- not expected - -- start-process foo '"bar baz"' ⇒ foo "bar baz" -- ok - biescape = escape quote . escape quoteDouble - script = "try {{ start-process {process} {args} -WindowStyle Hidden -WorkingDirectory {dir} }} catch {{ $_.Exception, $_.InvocationInfo.Line }}" - ~~ ("process" ~% escape quote myExe) - ~~ ("args" ~% intercalate ", " (map biescape args)) - ~~ ("dir" ~% escape quote curDir) - _ <- runTool_ "powershell" [ - "-NoProfile", - "-Command", - script] - putStrLn $ "Server started at port {}" ~~ serverPort sopts -#else - let - forkError :: SomeException -> IO () - forkError e = putStrLn $ "Failed to start server: {}" ~~ show e - - proxy :: IO () - proxy = do - _ <- createSession - _ <- forkProcess serverAction - exitImmediately ExitSuccess - - serverAction :: IO () - serverAction = do - mapM_ closeFd [stdInput, stdOutput, stdError] - nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags - mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] - closeFd nullFd - runServerCommand (Run sopts) - - handle forkError $ do - _ <- forkProcess proxy - putStrLn $ "Server started at port {}" ~~ serverPort sopts -#endif -runServerCommand (Run sopts) = runServer sopts $ bracket_ (setupServer sopts) (shutdownServer sopts) $ return () -runServerCommand (Stop copts) = runServerCommand (Remote copts False Exit) -runServerCommand (Connect copts) = do - curDir <- getCurrentDirectory - s <- makeSocket $ clientPort copts - sockAddr':_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just $ show $ clientPort copts) - Net.connect s (addrAddress sockAddr') - bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do - input' <- hGetLineBS stdin - case decodeMsg input' of - Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError $ OtherError "invalid command") em - Right m -> do - L.hPutStrLn h $ encodeMessage $ set msg (Message (Just $ show i) $ Request (view msg m) curDir True (clientTimeout copts) False) m - waitResp h - where - waitResp h = do - resp <- hGetLineBS h - parseResp h resp - - parseResp h str = case decodeMessage str of - Left em -> putStrLn $ "Can't decode response: {}" ~~ view msg em - Right m -> do - Response r' <- unMmap $ view (msg . message) m - putStrLn $ "{id}: {response}" - ~~ ("id" ~% fromMaybe "_" (view (msg . messageId) m)) - ~~ ("response" ~% fromUtf8 (encodeMsg $ set msg (Response r') m)) - case unResponse (view (msg . message) m) of - Left _ -> waitResp h - _ -> return () -runServerCommand (Remote copts noFile c@(Listen _)) = sendCommand copts noFile c printLog >>= noResult where - printLog :: Notification -> IO () - printLog (Notification v) = case fromJSON v of - A.Error _ -> putStrLn "incorrect notification" - A.Success m -> coloredLine . Log.text $ m - noResult :: Result -> IO () - noResult _ = return () -runServerCommand (Remote copts noFile c) = sendCommand copts noFile c printValue >>= printResult where - printValue :: ToJSON a => a -> IO () - printValue = L.putStrLn . encodeValue - printResult :: Result -> IO () - printResult (Result r) = printValue r - printResult e = printValue e - encodeValue :: ToJSON a => a -> L.ByteString - encodeValue = if clientPretty copts then encodePretty else encode +{-# LANGUAGE OverloadedStrings, CPP, LambdaCase, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Server.Commands ( + ServerCommand(..), ServerOpts(..), ClientOpts(..), + Request(..), + Msg, isLisp, msg, jsonMsg, lispMsg, encodeMessage, decodeMessage, + sendCommand, runServerCommand, + findPath, + processRequest, processClient, processClientSocket, + module HsDev.Server.Types + ) where + +import Control.Concurrent.Async +import Control.Lens (set, view) +import Control.Monad +import Control.Monad.Catch (bracket, bracket_) +import Data.Aeson hiding (Result, Error) +import qualified Data.Aeson as A +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Maybe +import Network.Socket hiding (connect) +import qualified Network.Socket as Net hiding (send) +import System.Directory +import System.Exit +import System.IO +import qualified System.Log.Simple as Log + +import GHC (getSessionDynFlags) + +import Text.Format ((~~), (~%)) +import Text.Format.Colored (coloredLine) + +import HsDev.Server.Base +import HsDev.Server.Types +import HsDev.Error +import HsDev.Util +import HsDev.Version +import HsDev.PackageDb.Types (globalDb) +import HsDev.Tools.Ghc.Worker +import qualified HsDev.Tools.Ghc.System as System + +#if mingw32_HOST_OS +import Data.List +import HsDev.Tools.Base (runTool_) +import System.Environment +import System.Win32.PowerShell (escape, quote, quoteDouble) +#else +import Control.Exception (SomeException, handle) +import System.Posix.Process +import System.Posix.IO +#endif + +sendCommand :: ClientOpts -> Bool -> Command -> (Notification -> IO a) -> IO Result +sendCommand copts noFile c onNotification = do + asyncAct <- async sendReceive + res <- waitCatch asyncAct + case res of + Left e -> return $ Error $ OtherError (show e) + Right r -> return r + where + sendReceive = do + curDir <- getCurrentDirectory + input <- if clientStdin copts + then Just <$> L.getContents + else return $ toUtf8 <$> Nothing -- arg "data" copts + let + parseData :: L.ByteString -> IO Value + parseData cts = case eitherDecode cts of + Left err -> putStrLn ("Invalid data: " ++ err) >> exitFailure + Right v -> return v + _ <- traverse parseData input -- FIXME: Not used! + + s <- makeSocket (clientPort copts) + sockAddr':_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just $ show $ clientPort copts) + Net.connect s (addrAddress sockAddr') + bracket (socketToHandle s ReadWriteMode) hClose $ \h -> do + L.hPutStrLn h $ encode $ Message Nothing $ Request c curDir noFile (clientTimeout copts) (clientSilent copts) + hFlush h + peekResponse h + + peekResponse h = do + resp <- hGetLineBS h + parseResponse h resp + + parseResponse h str = case eitherDecode str of + Left e -> return $ Error $ ResponseError ("can't parse: {}" ~~ e) (fromUtf8 str) + Right (Message _ r) -> do + Response r' <- unMmap r + case r' of + Left n -> onNotification n >> peekResponse h + Right res -> return res + +runServerCommand :: ServerCommand -> IO () +runServerCommand (Version showCompiler) + | showCompiler = do + w <- Log.noLog ghcWorker + compVer <- inWorker w $ do + workerSession SessionGhc globalDb [] + df <- getSessionDynFlags + return $ System.formatBuildPath "{compiler}-{version}" (System.buildInfo df) + putStrLn $ $cabalVersion ++ " " ++ compVer + joinWorker w + | otherwise = putStrLn $cabalVersion +runServerCommand (Start sopts) = do +#if mingw32_HOST_OS + let + args = "run" : serverOptsArgs sopts + myExe <- getExecutablePath + curDir <- getCurrentDirectory + let + -- one escape for start-process and other for callable process + -- seems, that start-process just concats arguments into one string + -- start-process foo 'bar baz' ⇒ foo bar baz -- not expected + -- start-process foo '"bar baz"' ⇒ foo "bar baz" -- ok + biescape = escape quote . escape quoteDouble + script = "try {{ start-process {process} {args} -WindowStyle Hidden -WorkingDirectory {dir} }} catch {{ $_.Exception, $_.InvocationInfo.Line }}" + ~~ ("process" ~% escape quote myExe) + ~~ ("args" ~% intercalate ", " (map biescape args)) + ~~ ("dir" ~% escape quote curDir) + _ <- runTool_ "powershell" [ + "-NoProfile", + "-Command", + script] + putStrLn $ "Server started at port {}" ~~ serverPort sopts +#else + let + forkError :: SomeException -> IO () + forkError e = putStrLn $ "Failed to start server: {}" ~~ show e + + proxy :: IO () + proxy = do + _ <- createSession + _ <- forkProcess serverAction + exitImmediately ExitSuccess + + serverAction :: IO () + serverAction = do + mapM_ closeFd [stdInput, stdOutput, stdError] + nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags + mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] + closeFd nullFd + runServerCommand (Run sopts) + + handle forkError $ do + _ <- forkProcess proxy + putStrLn $ "Server started at port {}" ~~ serverPort sopts +#endif +runServerCommand (Run sopts) = runServer sopts $ bracket_ (setupServer sopts) (shutdownServer sopts) $ return () +runServerCommand (Stop copts) = runServerCommand (Remote copts False Exit) +runServerCommand (Connect copts) = do + curDir <- getCurrentDirectory + s <- makeSocket $ clientPort copts + sockAddr':_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just $ show $ clientPort copts) + Net.connect s (addrAddress sockAddr') + bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do + input' <- hGetLineBS stdin + case decodeMsg input' of + Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError $ OtherError "invalid command") em + Right m -> do + L.hPutStrLn h $ encodeMessage $ set msg (Message (Just $ show i) $ Request (view msg m) curDir True (clientTimeout copts) False) m + waitResp h + where + waitResp h = do + resp <- hGetLineBS h + parseResp h resp + + parseResp h str = case decodeMessage str of + Left em -> putStrLn $ "Can't decode response: {}" ~~ view msg em + Right m -> do + Response r' <- unMmap $ view (msg . message) m + putStrLn $ "{id}: {response}" + ~~ ("id" ~% fromMaybe "_" (view (msg . messageId) m)) + ~~ ("response" ~% fromUtf8 (encodeMsg $ set msg (Response r') m)) + case unResponse (view (msg . message) m) of + Left _ -> waitResp h + _ -> return () +runServerCommand (Remote copts noFile c@(Listen _)) = sendCommand copts noFile c printLog >>= noResult where + printLog :: Notification -> IO () + printLog (Notification v) = case fromJSON v of + A.Error _ -> putStrLn "incorrect notification" + A.Success m -> coloredLine . Log.text $ m + noResult :: Result -> IO () + noResult _ = return () +runServerCommand (Remote copts noFile c) = sendCommand copts noFile c printValue >>= printResult where + printValue :: ToJSON a => a -> IO () + printValue = L.putStrLn . encodeValue + printResult :: Result -> IO () + printResult (Result r) = printValue r + printResult e = printValue e + encodeValue :: ToJSON a => a -> L.ByteString + encodeValue = if clientPretty copts then encodePretty else encode diff --git a/src/HsDev/Server/Message.hs b/src/HsDev/Server/Message.hs --- a/src/HsDev/Server/Message.hs +++ b/src/HsDev/Server/Message.hs @@ -1,118 +1,118 @@ -{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-} - -module HsDev.Server.Message ( - Message(..), messageId, message, - messagesById, - Notification(..), Result(..), ResultPart(..), - Response(..), isNotification, result, responseError, - groupResponses, - decodeMessage, encodeMessage, - - module HsDev.Server.Message.Lisp - ) where - -import Control.Applicative -import Control.Lens (makeLenses) -import Control.Monad (join) -import Data.Aeson hiding (Error, Result) -import Data.Either (lefts, isRight) -import Data.List (unfoldr) -import Data.ByteString.Lazy.Char8 (ByteString) - -import HsDev.Types -import HsDev.Util ((.::), (.::?), objectUnion) -import HsDev.Server.Message.Lisp - --- | Message with id to link request and response -data Message a = Message { - _messageId :: Maybe String, - _message :: a } - deriving (Eq, Ord, Show, Functor) - -makeLenses ''Message - -instance ToJSON a => ToJSON (Message a) where - toJSON (Message i m) = object ["id" .= i] `objectUnion` toJSON m - -instance FromJSON a => FromJSON (Message a) where - parseJSON = withObject "message" $ \v -> - Message <$> fmap join (v .::? "id") <*> parseJSON (Object v) - -instance Foldable Message where - foldMap f (Message _ m) = f m - -instance Traversable Message where - traverse f (Message i m) = Message i <$> f m - --- | Get messages by id -messagesById :: Maybe String -> [Message a] -> [a] -messagesById i = map _message . filter ((== i) . _messageId) - --- | Notification from server -newtype Notification = Notification Value deriving (Eq, Show) - -instance ToJSON Notification where - toJSON (Notification v) = object ["notify" .= v] - -instance FromJSON Notification where - parseJSON = withObject "notification" $ \v -> Notification <$> v .:: "notify" - --- | Result from server -data Result = - Result Value | - -- ^ Result - Error HsDevError - -- ^ Error - deriving (Show) - -instance ToJSON Result where - toJSON (Result r) = object ["result" .= r] - toJSON (Error e) = toJSON e - -instance FromJSON Result where - parseJSON j = (withObject "result" (\v -> (Result <$> v .:: "result")) j) <|> (Error <$> parseJSON j) - --- | Part of result list, returns via notification -newtype ResultPart = ResultPart Value - -instance ToJSON ResultPart where - toJSON (ResultPart r) = object ["result-part" .= r] - -instance FromJSON ResultPart where - parseJSON = withObject "result-part" $ \v -> ResultPart <$> v .:: "result-part" - -newtype Response = Response { unResponse :: Either Notification Result } deriving (Show) - -isNotification :: Response -> Bool -isNotification = either (const True) (const False) . unResponse - -result :: ToJSON a => a -> Response -result = Response . Right . Result . toJSON - -responseError :: HsDevError -> Response -responseError = Response . Right . Error - -instance ToJSON Response where - toJSON (Response (Left n)) = toJSON n - toJSON (Response (Right r)) = toJSON r - -instance FromJSON Response where - parseJSON v = Response <$> ((Left <$> parseJSON v) <|> (Right <$> parseJSON v)) - -groupResponses :: [Response] -> [([Notification], Result)] -groupResponses = unfoldr break' where - break' :: [Response] -> Maybe (([Notification], Result), [Response]) - break' [] = Nothing - break' cs = Just ((lefts (map unResponse ns), r), drop 1 cs') where - (ns, cs') = break (isRight . unResponse) cs - r = case cs' of - (Response (Right r') : _) -> r' - [] -> Error $ OtherError "groupResponses: no result" - _ -> error "groupResponses: impossible happened" - --- | Decode lisp or json request -decodeMessage :: FromJSON a => ByteString -> Either (Msg String) (Msg (Message a)) -decodeMessage = decodeMsg - -encodeMessage :: ToJSON a => Msg (Message a) -> ByteString -encodeMessage = encodeMsg +{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-} + +module HsDev.Server.Message ( + Message(..), messageId, message, + messagesById, + Notification(..), Result(..), ResultPart(..), + Response(..), isNotification, result, responseError, + groupResponses, + decodeMessage, encodeMessage, + + module HsDev.Server.Message.Lisp + ) where + +import Control.Applicative +import Control.Lens (makeLenses) +import Control.Monad (join) +import Data.Aeson hiding (Error, Result) +import Data.Either (lefts, isRight) +import Data.List (unfoldr) +import Data.ByteString.Lazy.Char8 (ByteString) + +import HsDev.Types +import HsDev.Util ((.::), (.::?), objectUnion) +import HsDev.Server.Message.Lisp + +-- | Message with id to link request and response +data Message a = Message { + _messageId :: Maybe String, + _message :: a } + deriving (Eq, Ord, Show, Functor) + +makeLenses ''Message + +instance ToJSON a => ToJSON (Message a) where + toJSON (Message i m) = object ["id" .= i] `objectUnion` toJSON m + +instance FromJSON a => FromJSON (Message a) where + parseJSON = withObject "message" $ \v -> + Message <$> fmap join (v .::? "id") <*> parseJSON (Object v) + +instance Foldable Message where + foldMap f (Message _ m) = f m + +instance Traversable Message where + traverse f (Message i m) = Message i <$> f m + +-- | Get messages by id +messagesById :: Maybe String -> [Message a] -> [a] +messagesById i = map _message . filter ((== i) . _messageId) + +-- | Notification from server +newtype Notification = Notification Value deriving (Eq, Show) + +instance ToJSON Notification where + toJSON (Notification v) = object ["notify" .= v] + +instance FromJSON Notification where + parseJSON = withObject "notification" $ \v -> Notification <$> v .:: "notify" + +-- | Result from server +data Result = + Result Value | + -- ^ Result + Error HsDevError + -- ^ Error + deriving (Show) + +instance ToJSON Result where + toJSON (Result r) = object ["result" .= r] + toJSON (Error e) = toJSON e + +instance FromJSON Result where + parseJSON j = (withObject "result" (\v -> (Result <$> v .:: "result")) j) <|> (Error <$> parseJSON j) + +-- | Part of result list, returns via notification +newtype ResultPart = ResultPart Value + +instance ToJSON ResultPart where + toJSON (ResultPart r) = object ["result-part" .= r] + +instance FromJSON ResultPart where + parseJSON = withObject "result-part" $ \v -> ResultPart <$> v .:: "result-part" + +newtype Response = Response { unResponse :: Either Notification Result } deriving (Show) + +isNotification :: Response -> Bool +isNotification = either (const True) (const False) . unResponse + +result :: ToJSON a => a -> Response +result = Response . Right . Result . toJSON + +responseError :: HsDevError -> Response +responseError = Response . Right . Error + +instance ToJSON Response where + toJSON (Response (Left n)) = toJSON n + toJSON (Response (Right r)) = toJSON r + +instance FromJSON Response where + parseJSON v = Response <$> ((Left <$> parseJSON v) <|> (Right <$> parseJSON v)) + +groupResponses :: [Response] -> [([Notification], Result)] +groupResponses = unfoldr break' where + break' :: [Response] -> Maybe (([Notification], Result), [Response]) + break' [] = Nothing + break' cs = Just ((lefts (map unResponse ns), r), drop 1 cs') where + (ns, cs') = break (isRight . unResponse) cs + r = case cs' of + (Response (Right r') : _) -> r' + [] -> Error $ OtherError "groupResponses: no result" + _ -> error "groupResponses: impossible happened" + +-- | Decode lisp or json request +decodeMessage :: FromJSON a => ByteString -> Either (Msg String) (Msg (Message a)) +decodeMessage = decodeMsg + +encodeMessage :: ToJSON a => Msg (Message a) -> ByteString +encodeMessage = encodeMsg diff --git a/src/HsDev/Server/Message/Lisp.hs b/src/HsDev/Server/Message/Lisp.hs --- a/src/HsDev/Server/Message/Lisp.hs +++ b/src/HsDev/Server/Message/Lisp.hs @@ -1,47 +1,47 @@ -module HsDev.Server.Message.Lisp ( - Msg, - isLisp, msg, - jsonMsg, lispMsg, - - decodeMsg, encodeMsg - ) where - -import Control.Applicative -import Control.Lens -import Control.Monad -import Data.Aeson -import Data.Maybe -import Data.ByteString.Lazy.Char8 (ByteString) - -import Data.Lisp - -type Msg a = (Bool, a) - -isLisp :: Lens' (Msg a) Bool -isLisp = _1 - -msg :: Lens (Msg a) (Msg b) a b -msg = _2 - -jsonMsg :: a -> Msg a -jsonMsg = (,) False - -lispMsg :: a -> Msg a -lispMsg = (,) True - --- | Decode lisp or json -decodeMsg :: FromJSON a => ByteString -> Either (Msg String) (Msg a) -decodeMsg bstr = over _Left decodeType' decodeMsg' where - decodeType' - | isLisp' = lispMsg - | otherwise = jsonMsg - decodeMsg' = (lispMsg <$> decodeLisp bstr) <|> (jsonMsg <$> eitherDecode bstr) - isLisp' = fromMaybe False $ mplus (try' eitherDecode False) (try' decodeLisp True) - try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool - try' f l = either (const Nothing) (const $ Just l) $ f bstr - --- | Encode lisp or json -encodeMsg :: ToJSON a => Msg a -> ByteString -encodeMsg m - | view isLisp m = encodeLisp $ view msg m - | otherwise = encode $ view msg m +module HsDev.Server.Message.Lisp ( + Msg, + isLisp, msg, + jsonMsg, lispMsg, + + decodeMsg, encodeMsg + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Aeson +import Data.Maybe +import Data.ByteString.Lazy.Char8 (ByteString) + +import Data.Lisp + +type Msg a = (Bool, a) + +isLisp :: Lens' (Msg a) Bool +isLisp = _1 + +msg :: Lens (Msg a) (Msg b) a b +msg = _2 + +jsonMsg :: a -> Msg a +jsonMsg = (,) False + +lispMsg :: a -> Msg a +lispMsg = (,) True + +-- | Decode lisp or json +decodeMsg :: FromJSON a => ByteString -> Either (Msg String) (Msg a) +decodeMsg bstr = over _Left decodeType' decodeMsg' where + decodeType' + | isLisp' = lispMsg + | otherwise = jsonMsg + decodeMsg' = (lispMsg <$> decodeLisp bstr) <|> (jsonMsg <$> eitherDecode bstr) + isLisp' = fromMaybe False $ mplus (try' eitherDecode False) (try' decodeLisp True) + try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool + try' f l = either (const Nothing) (const $ Just l) $ f bstr + +-- | Encode lisp or json +encodeMsg :: ToJSON a => Msg a -> ByteString +encodeMsg m + | view isLisp m = encodeLisp $ view msg m + | otherwise = encode $ view msg m diff --git a/src/HsDev/Server/Types.hs b/src/HsDev/Server/Types.hs --- a/src/HsDev/Server/Types.hs +++ b/src/HsDev/Server/Types.hs @@ -1,924 +1,924 @@ -{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds, TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Server.Types ( - ServerMonadBase, - SessionLog(..), Session(..), SessionMonad(..), askSession, ServerM(..), - CommandOptions(..), CommandMonad(..), askOptions, ClientM(..), - withSession, serverListen, serverSetLogLevel, serverWait, serverWaitClients, - serverSqlDatabase, openSqlConnection, closeSqlConnection, withSqlConnection, withSqlTransaction, serverSetFileContents, - inSessionGhc, inSessionUpdater, postSessionUpdater, serverExit, commandRoot, commandNotify, commandLink, commandHold, - ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..), - - Command(..), - FileSource(..), TargetFilter(..), SearchQuery(..), SearchType(..), - FromCmd(..), - ) where - -import Control.Applicative -import Control.Concurrent.Async (Async) -import qualified Control.Concurrent.FiniteChan as F -import Control.Lens (view, set) -import Control.Monad.Base -import Control.Monad.Catch -import Control.Monad.Except -import Control.Monad.Fail -import Control.Monad.Morph -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Control.Monad.Trans.Control -import Data.Aeson hiding (Result(..), Error) -import qualified Data.Aeson.Types as A -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Default -import Data.Maybe (fromMaybe) -import Data.Foldable (asum) -import Data.Text (Text) -import Data.String (fromString) -import qualified Database.SQLite.Simple as SQL -import qualified Network.HTTP.Client as HTTP -import Options.Applicative -import System.Log.Simple as Log - -import Control.Concurrent.Worker -import Data.LookupTable -import System.Directory.Paths -import Text.Format (Formattable(..), (~~)) - -import HsDev.Error (hsdevError) -import HsDev.Inspect.Types -import HsDev.Server.Message -import HsDev.Watcher.Types (Watcher) -import HsDev.PackageDb.Types -import HsDev.Project.Types -import HsDev.Tools.Ghc.Worker (GhcWorker, GhcM) -import HsDev.Tools.Types (Note, OutputMessage) -import HsDev.Tools.AutoFix (Refact) -import HsDev.Types (HsDevError(..)) -import HsDev.Util - -#if mingw32_HOST_OS -import System.Win32.FileMapping.NamePool (Pool) -#endif - -type ServerMonadBase m = (MonadIO m, MonadFail m, MonadMask m, MonadBaseControl IO m, Alternative m, MonadPlus m) - -data SessionLog = SessionLog { - sessionLogger :: Log, - sessionListenLog :: IO [Log.Message], - sessionLogWait :: IO () } - -data Session = Session { - sessionSqlDatabase :: SQL.Connection, - sessionSqlPath :: String, - sessionLog :: SessionLog, - sessionWatcher :: Maybe Watcher, - sessionFileContents :: Path -> Maybe Text -> IO (), -#if mingw32_HOST_OS - sessionMmapPool :: Maybe Pool, -#endif - sessionGhc :: GhcWorker, - sessionUpdater :: Worker (ServerM IO), - sessionResolveEnvironment :: LookupTable (Maybe Path) (Environment, FixitiesTable), - sessionHTTPManager :: HTTP.Manager, - sessionExit :: IO (), - sessionWait :: IO (), - sessionClients :: F.Chan (IO ()), - sessionDefines :: [(String, String)] } - -class (ServerMonadBase m, MonadLog m) => SessionMonad m where - getSession :: m Session - localSession :: (Session -> Session) -> m a -> m a - -askSession :: SessionMonad m => (Session -> a) -> m a -askSession f = liftM f getSession - -newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a } - deriving (Functor, Applicative, Alternative, Monad, MonadFail, MonadPlus, MonadIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch, MonadMask) - -instance (MonadIO m, MonadMask m) => MonadLog (ServerM m) where - askLog = ServerM $ asks (sessionLogger . sessionLog) - localLog fn = ServerM . local setLog' . runServerM where - setLog' sess = sess { sessionLog = (sessionLog sess) { sessionLogger = fn (sessionLogger (sessionLog sess)) } } - -instance ServerMonadBase m => SessionMonad (ServerM m) where - getSession = ask - localSession = local - -instance MonadBase b m => MonadBase b (ServerM m) where - liftBase = ServerM . liftBase - -instance MonadBaseControl b m => MonadBaseControl b (ServerM m) where - type StM (ServerM m) a = StM (ReaderT Session m) a - liftBaseWith f = ServerM $ liftBaseWith (\f' -> f (f' . runServerM)) - restoreM = ServerM . restoreM - -instance MFunctor ServerM where - hoist fn = ServerM . hoist fn . runServerM - -instance SessionMonad m => SessionMonad (ReaderT r m) where - getSession = lift getSession - localSession = mapReaderT . localSession - -instance (SessionMonad m, Monoid w) => SessionMonad (WriterT w m) where - getSession = lift getSession - localSession = mapWriterT . localSession - -instance SessionMonad m => SessionMonad (StateT s m) where - getSession = lift getSession - localSession = mapStateT . localSession - -data CommandOptions = CommandOptions { - commandOptionsRoot :: FilePath, - commandOptionsNotify :: Notification -> IO (), - commandOptionsLink :: IO (), - commandOptionsHold :: IO () } - -instance Default CommandOptions where - def = CommandOptions "." (const $ return ()) (return ()) (return ()) - -class (SessionMonad m, MonadPlus m) => CommandMonad m where - getOptions :: m CommandOptions - -askOptions :: CommandMonad m => (CommandOptions -> a) -> m a -askOptions f = liftM f getOptions - -newtype ClientM m a = ClientM { runClientM :: ServerM (ReaderT CommandOptions m) a } - deriving (Functor, Applicative, Alternative, Monad, MonadFail, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask) - -instance MonadTrans ClientM where - lift = ClientM . lift . lift - -instance (MonadIO m, MonadMask m) => MonadLog (ClientM m) where - askLog = ClientM askLog - localLog fn = ClientM . localLog fn . runClientM - -instance ServerMonadBase m => SessionMonad (ClientM m) where - getSession = ClientM getSession - localSession fn = ClientM . localSession fn . runClientM - -instance ServerMonadBase m => CommandMonad (ClientM m) where - getOptions = ClientM $ lift ask - -instance MonadBase b m => MonadBase b (ClientM m) where - liftBase = ClientM . liftBase - -instance MonadBaseControl b m => MonadBaseControl b (ClientM m) where - type StM (ClientM m) a = StM (ServerM (ReaderT CommandOptions m)) a - liftBaseWith f = ClientM $ liftBaseWith (\f' -> f (f' . runClientM)) - restoreM = ClientM . restoreM - -instance MFunctor ClientM where - hoist fn = ClientM . hoist (hoist fn) . runClientM - -instance CommandMonad m => CommandMonad (ReaderT r m) where - getOptions = lift getOptions - -instance (CommandMonad m, Monoid w) => CommandMonad (WriterT w m) where - getOptions = lift getOptions - -instance CommandMonad m => CommandMonad (StateT s m) where - getOptions = lift getOptions - --- | Run action on session -withSession :: Session -> ServerM m a -> m a -withSession s act = runReaderT (runServerM act) s - --- | Listen server's log -serverListen :: SessionMonad m => m [Log.Message] -serverListen = join . liftM liftIO $ askSession (sessionListenLog . sessionLog) - --- | Set server's log config -serverSetLogLevel :: SessionMonad m => Level -> m Level -serverSetLogLevel lev = do - l <- askSession (sessionLogger . sessionLog) - cfg <- updateLogConfig l (set (componentCfg "") (Just lev)) - return $ fromMaybe def $ view (componentCfg "") cfg - --- | Wait for server -serverWait :: SessionMonad m => m () -serverWait = join . liftM liftIO $ askSession sessionWait - --- | Wait while clients disconnects -serverWaitClients :: SessionMonad m => m () -serverWaitClients = do - clientChan <- askSession sessionClients - liftIO (F.stopChan clientChan) >>= sequence_ . map liftIO - --- | Get sql connection -serverSqlDatabase :: SessionMonad m => m SQL.Connection -serverSqlDatabase = askSession sessionSqlDatabase - --- | Open new sql connection -openSqlConnection :: SessionMonad m => m SQL.Connection -openSqlConnection = do - p <- askSession sessionSqlPath - -- FIXME: There's `new` function in HsDev's SQLite module - liftIO $ do - conn <- SQL.open p - SQL.execute_ conn "pragma case_sensitive_like = true;" - SQL.execute_ conn "pragma synchronous = off;" - SQL.execute_ conn "pragma journal_mode = memory;" - return conn - --- | Close sql connection -closeSqlConnection :: SessionMonad m => SQL.Connection -> m () -closeSqlConnection = liftIO . SQL.close - --- | Locally opens new connection, updating @Session@ -withSqlConnection :: SessionMonad m => m a -> m a -withSqlConnection act = bracket openSqlConnection closeSqlConnection $ \conn -> - localSession (\sess -> sess { sessionSqlDatabase = conn }) act - --- | With sql transaction -withSqlTransaction :: SessionMonad m => ServerM IO a -> m a -withSqlTransaction fn = do - conn <- serverSqlDatabase - sess <- getSession - liftIO $ SQL.withTransaction conn $ withSession sess fn - --- | Set custom file contents -serverSetFileContents :: SessionMonad m => Path -> Maybe Text -> m () -serverSetFileContents fpath mcts = do - setCts <- askSession sessionFileContents - liftIO $ setCts fpath mcts - --- | In ghc session -inSessionGhc :: SessionMonad m => GhcM a -> m a -inSessionGhc act = do - ghcw <- askSession sessionGhc - inWorkerWith (hsdevError . GhcError . displayException) ghcw act - --- | In updater -inSessionUpdater :: SessionMonad m => ServerM IO a -> m a -inSessionUpdater act = do - uw <- askSession sessionUpdater - inWorkerWith (hsdevError . OtherError . displayException) uw act - --- | Post to updater and return -postSessionUpdater :: SessionMonad m => ServerM IO a -> m (Async a) -postSessionUpdater act = do - uw <- askSession sessionUpdater - liftIO $ sendTask uw act - --- | Exit session -serverExit :: SessionMonad m => m () -serverExit = join . liftM liftIO $ askSession sessionExit - -commandRoot :: CommandMonad m => m FilePath -commandRoot = askOptions commandOptionsRoot - -commandNotify :: CommandMonad m => Notification -> m () -commandNotify n = join . liftM liftIO $ askOptions commandOptionsNotify <*> pure n - -commandLink :: CommandMonad m => m () -commandLink = join . liftM liftIO $ askOptions commandOptionsLink - -commandHold :: CommandMonad m => m () -commandHold = join . liftM liftIO $ askOptions commandOptionsHold - --- | Server control command -data ServerCommand = - Version Bool | - Start ServerOpts | - Run ServerOpts | - Stop ClientOpts | - Connect ClientOpts | - Remote ClientOpts Bool Command - deriving (Show) - -data ConnectionPort = NetworkPort Int | UnixPort String deriving (Eq, Read) - -instance Default ConnectionPort where - def = NetworkPort 4567 - -instance Show ConnectionPort where - show (NetworkPort p) = show p - show (UnixPort s) = "unix " ++ s - -instance Formattable ConnectionPort - --- | Server options -data ServerOpts = ServerOpts { - serverPort :: ConnectionPort, - serverTimeout :: Int, - serverLog :: Maybe FilePath, - serverLogLevel :: String, - serverLogNoColor :: Bool, - serverDbFile :: Maybe FilePath, - serverWatchFS :: Bool, - serverSilent :: Bool } - deriving (Show) - -instance Default ServerOpts where - def = ServerOpts def 0 Nothing "info" False Nothing True False - --- | Silent server with no connection, useful for ghci -silentOpts :: ServerOpts -silentOpts = def { serverSilent = True } - --- | Client options -data ClientOpts = ClientOpts { - clientPort :: ConnectionPort, - clientPretty :: Bool, - clientStdin :: Bool, - clientTimeout :: Int, - clientSilent :: Bool } - deriving (Show) - -instance Default ClientOpts where - def = ClientOpts def False False 0 False - -instance FromCmd ServerCommand where - cmdP = serv <|> remote where - serv = subparser $ mconcat [ - cmd "version" "hsdev version" (Version <$> compilerVersionFlag), - cmd "start" "start remote server" (Start <$> cmdP), - cmd "run" "run server" (Run <$> cmdP), - cmd "stop" "stop remote server" (Stop <$> cmdP), - cmd "connect" "connect to send commands directly" (Connect <$> cmdP)] - remote = Remote <$> cmdP <*> noFileFlag <*> cmdP - -instance FromCmd ServerOpts where - cmdP = ServerOpts <$> - (connectionArg <|> pure (serverPort def)) <*> - (timeoutArg <|> pure (serverTimeout def)) <*> - optional logArg <*> - (logLevelArg <|> pure (serverLogLevel def)) <*> - noColorFlag <*> - optional dbFileArg <*> - (not <$> noWatchFlag) <*> - serverSilentFlag - -instance FromCmd ClientOpts where - cmdP = ClientOpts <$> - (connectionArg <|> pure (clientPort def)) <*> - prettyFlag <*> - stdinFlag <*> - (timeoutArg <|> pure (clientTimeout def)) <*> - silentFlag - -portArg :: Parser ConnectionPort -compilerVersionFlag :: Parser Bool -connectionArg :: Parser ConnectionPort -timeoutArg :: Parser Int -logArg :: Parser FilePath -logLevelArg :: Parser String -noColorFlag :: Parser Bool -noFileFlag :: Parser Bool -prettyFlag :: Parser Bool -serverSilentFlag :: Parser Bool -stdinFlag :: Parser Bool -silentFlag :: Parser Bool -dbFileArg :: Parser FilePath -noWatchFlag :: Parser Bool - -portArg = NetworkPort <$> option auto (long "port" <> metavar "number" <> help "connection port") -compilerVersionFlag = switch (long "compiler" <> short 'c' <> help "show compiler version") -#if mingw32_HOST_OS -connectionArg = portArg -#else -unixArg :: Parser ConnectionPort -unixArg = UnixPort <$> strOption (long "unix" <> metavar "name" <> help "unix connection port") -connectionArg = portArg <|> unixArg -#endif -timeoutArg = option auto (long "timeout" <> metavar "msec" <> help "query timeout") -logArg = strOption (long "log" <> short 'l' <> metavar "file" <> help "log file") -logLevelArg = strOption (long "log-level" <> metavar "level" <> help "log level: trace/debug/info/warning/error/fatal") -noColorFlag = switch (long "no-color" <> help "don't use colorized log output") -noFileFlag = switch (long "no-file" <> help "don't use mmap files") -prettyFlag = switch (long "pretty" <> help "pretty json output") -serverSilentFlag = switch (long "silent" <> help "no stdout/stderr") -stdinFlag = switch (long "stdin" <> help "pass data to stdin") -silentFlag = switch (long "silent" <> help "supress notifications") -dbFileArg = strOption (long "db" <> metavar "path" <> help "path to sql database") -noWatchFlag = switch (long "no-watch" <> help "don't watch filesystem for source changes") - -serverOptsArgs :: ServerOpts -> [String] -serverOptsArgs sopts = concat [ - portArgs (serverPort sopts), - ["--timeout", show $ serverTimeout sopts], - marg "--log" (serverLog sopts), - ["--log-level", serverLogLevel sopts], - marg "--db" (serverDbFile sopts), - ["--silent" | serverSilent sopts]] - where - marg :: String -> Maybe String -> [String] - marg n (Just v) = [n, v] - marg _ _ = [] - portArgs :: ConnectionPort -> [String] - portArgs (NetworkPort n) = ["--port", show n] - portArgs (UnixPort s) = ["--unix", s] - -data Request = Request { - requestCommand :: Command, - requestDirectory :: FilePath, - requestNoFile :: Bool, - requestTimeout :: Int, - requestSilent :: Bool } - deriving (Show) - -instance ToJSON Request where - toJSON (Request c dir f tm s) = object ["current-directory" .= dir, "no-file" .= f, "timeout" .= tm, "silent" .= s] `objectUnion` toJSON c - -instance FromJSON Request where - parseJSON = withObject "request" $ \v -> Request <$> - parseJSON (Object v) <*> - ((v .:: "current-directory") <|> pure ".") <*> - ((v .:: "no-file") <|> pure False) <*> - ((v .:: "timeout") <|> pure 0) <*> - ((v .:: "silent") <|> pure False) - --- | Command from client -data Command = - Ping | - Listen (Maybe String) | - SetLogLevel String | - Scan { - scanProjects :: [Path], - scanCabal :: Bool, - scanSandboxes :: [Path], - scanFiles :: [FileSource], - scanPaths :: [Path], - scanBuildTool :: BuildTool, - scanGhcOpts :: [String], - scanDocs :: Bool, - scanInferTypes :: Bool } | - ScanProject { - scanProjectPath :: Path, - scanProjectBuildTool :: BuildTool, - scanProjectDeps :: Bool } | - ScanFile { - scanFilePath :: Path, - scanFileBuildTool :: BuildTool, - scanFileProject :: Bool, - scanFileDeps :: Bool } | - ScanPackageDbs { - scanPackageDbStack :: PackageDbStack } | - SetFileContents Path (Maybe Text) | - RefineDocs { - docsProjects :: [Path], - docsFiles :: [Path] } | - InferTypes { - inferProjects :: [Path], - inferFiles :: [Path] } | - Remove { - removeProjects :: [Path], - removeCabal :: Bool, - removeSandboxes :: [Path], - removeFiles :: [Path] } | - RemoveAll | - InfoPackages | - InfoProjects | - InfoSandboxes | - InfoSymbol SearchQuery [TargetFilter] Bool Bool | - InfoModule SearchQuery [TargetFilter] Bool Bool | - InfoProject (Either Text Path) | - InfoSandbox Path | - Lookup Text Path | - Whois Text Path | - Whoat Int Int Path | - ResolveScopeModules SearchQuery Path | - ResolveScope SearchQuery Path | - FindUsages Int Int Path | - Complete Text Bool Path | - Hayoo { - hayooQuery :: String, - hayooPage :: Int, - hayooPages :: Int } | - CabalList { cabalListPackages :: [Text] } | - UnresolvedSymbols { - unresolvedFiles :: [Path] } | - Lint { - lintFiles :: [FileSource], - lintHlintOpts :: [String] - } | - Check { - checkFiles :: [FileSource], - checkGhcOpts :: [String], - checkClear :: Bool } | - CheckLint { - checkLintFiles :: [FileSource], - checkLintGhcOpts :: [String], - checkLintOpts :: [String], - checkLinkClear :: Bool } | - Types { - typesFiles :: [FileSource], - typesGhcOpts :: [String], - typesClear :: Bool } | - AutoFix [Note OutputMessage] | - Refactor [Note Refact] [Note Refact] Bool | - Rename Text Text Path | - GhcEval { ghcEvalExpressions :: [String], ghcEvalSource :: Maybe FileSource } | - GhcType { ghcTypeExpressions :: [String], ghcTypeSource :: Maybe FileSource } | - Langs | - Flags | - Link { linkHold :: Bool } | - StopGhc | - Exit - deriving (Show) - -data FileSource = FileSource { fileSource :: Path, fileContents :: Maybe Text } deriving (Show) -data TargetFilter = - TargetProject Text | - TargetFile Path | - TargetModule Text | - TargetPackage Text | - TargetInstalled | - TargetSourced | - TargetStandalone - deriving (Eq, Show) -data SearchQuery = SearchQuery Text SearchType deriving (Show) -data SearchType = SearchExact | SearchPrefix | SearchInfix | SearchSuffix deriving (Show) - -instance Paths Command where - paths f (Scan projs c cs fs ps btool ghcs docs infer) = Scan <$> - traverse (paths f) projs <*> - pure c <*> - traverse (paths f) cs <*> - traverse (paths f) fs <*> - traverse (paths f) ps <*> - pure btool <*> - pure ghcs <*> - pure docs <*> - pure infer - paths f (ScanProject proj tool deps) = ScanProject <$> paths f proj <*> pure tool <*> pure deps - paths f (ScanFile file' tool scanProj deps) = ScanFile <$> paths f file' <*> pure tool <*> pure scanProj <*> pure deps - paths f (ScanPackageDbs pdbs) = ScanPackageDbs <$> paths f pdbs - paths f (SetFileContents p cts) = SetFileContents <$> paths f p <*> pure cts - paths f (RefineDocs projs fs) = RefineDocs <$> traverse (paths f) projs <*> traverse (paths f) fs - paths f (InferTypes projs fs) = InferTypes <$> traverse (paths f) projs <*> traverse (paths f) fs - paths f (Remove projs c cs fs) = Remove <$> traverse (paths f) projs <*> pure c <*> traverse (paths f) cs <*> traverse (paths f) fs - paths _ RemoveAll = pure RemoveAll - paths f (InfoSymbol q t h l) = InfoSymbol <$> pure q <*> traverse (paths f) t <*> pure h <*> pure l - paths f (InfoModule q t h i) = InfoModule <$> pure q <*> traverse (paths f) t <*> pure h <*> pure i - paths f (InfoProject (Right proj)) = InfoProject <$> (Right <$> paths f proj) - paths f (InfoSandbox fpath) = InfoSandbox <$> paths f fpath - paths f (Lookup n fpath) = Lookup <$> pure n <*> paths f fpath - paths f (Whois n fpath) = Whois <$> pure n <*> paths f fpath - paths f (Whoat l c fpath) = Whoat <$> pure l <*> pure c <*> paths f fpath - paths f (ResolveScopeModules q fpath) = ResolveScopeModules q <$> paths f fpath - paths f (ResolveScope q fpath) = ResolveScope q <$> paths f fpath - paths f (FindUsages l c fpath) = FindUsages <$> pure l <*> pure c <*> paths f fpath - paths f (Complete n g fpath) = Complete n g <$> paths f fpath - paths f (UnresolvedSymbols fs) = UnresolvedSymbols <$> traverse (paths f) fs - paths f (Lint fs lints) = Lint <$> traverse (paths f) fs <*> pure lints - paths f (Check fs ghcs c) = Check <$> traverse (paths f) fs <*> pure ghcs <*> pure c - paths f (CheckLint fs ghcs lints c) = CheckLint <$> traverse (paths f) fs <*> pure ghcs <*> pure lints <*> pure c - paths f (Types fs ghcs c) = Types <$> traverse (paths f) fs <*> pure ghcs <*> pure c - paths f (GhcEval e mf) = GhcEval e <$> traverse (paths f) mf - paths f (GhcType e mf) = GhcType e <$> traverse (paths f) mf - paths _ c = pure c - -instance Paths FileSource where - paths f (FileSource fpath mcts) = FileSource <$> paths f fpath <*> pure mcts - -instance Paths TargetFilter where - paths f (TargetFile fpath) = TargetFile <$> paths f fpath - paths _ t = pure t - -instance FromCmd Command where - cmdP = subparser $ mconcat [ - cmd "ping" "ping server" (pure Ping), - cmd "listen" "listen server log" (Listen <$> optional logLevelArg), - cmd "set-log" "set log level" (SetLogLevel <$> strArgument idm), - cmd "scan" "scan sources" ( - subparser (cmd "project" "scan project" (ScanProject <$> textArgument idm <*> toolArg <*> depsArg)) <|> - subparser (cmd "file" "scan file" (ScanFile <$> textArgument idm <*> (toolArg <|> pure CabalTool) <*> depProjArg <*> depsArg)) <|> - subparser (cmd "package-dbs" "scan package-dbs; note, that order of package-dbs matters - dependent package-dbs should go first" (ScanPackageDbs <$> (mkPackageDbStack <$> many packageDbArg))) <|> - (Scan <$> - many projectArg <*> - cabalFlag <*> - many sandboxArg <*> - many cmdP <*> - many (pathArg $ help "path") <*> - (toolArg' <|> pure CabalTool) <*> - ghcOpts <*> - docsFlag <*> - inferFlag)), - cmd "set-file-contents" "set edited file contents, which will be used instead of contents in file until it updated" $ - SetFileContents <$> fileArg <*> optional contentsArg, - cmd "docs" "scan docs" $ RefineDocs <$> many projectArg <*> many fileArg, - cmd "infer" "infer types" $ InferTypes <$> many projectArg <*> many fileArg, - cmd "remove" "remove modules info" $ Remove <$> - many projectArg <*> - cabalFlag <*> - many sandboxArg <*> - many fileArg, - cmd "remove-all" "remove all data" (pure RemoveAll), - cmd "packages" "list packages" (pure InfoPackages), - cmd "projects" "list projects" (pure InfoProjects), - cmd "sandboxes" "list sandboxes" (pure InfoSandboxes), - cmd "symbol" "get symbol info" (InfoSymbol <$> cmdP <*> many cmdP <*> headerFlag <*> localsFlag), - cmd "module" "get module info" (InfoModule <$> cmdP <*> many cmdP <*> headerFlag <*> inspectionFlag), - cmd "project" "get project info" (InfoProject <$> ((Left <$> projectArg) <|> (Right <$> pathArg idm))), - cmd "sandbox" "get sandbox info" (InfoSandbox <$> pathArg (help "locate sandbox in parent of this path")), - cmd "lookup" "lookup for symbol" (Lookup <$> textArgument idm <*> ctx), - cmd "whois" "get info for symbol" (Whois <$> textArgument idm <*> ctx), - cmd "whoat" "get info for symbol under cursor" (Whoat <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx), - cmd "scope" "get declarations accessible from module or within a project" ( - subparser (cmd "modules" "get modules accessible from module or within a project" (ResolveScopeModules <$> cmdP <*> ctx)) <|> - ResolveScope <$> cmdP <*> ctx), - cmd "usages" "find usages of symbol within project/module" (FindUsages <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx), - cmd "complete" "show completions for input" (Complete <$> textArgument idm <*> wideFlag <*> ctx), - cmd "hayoo" "find declarations online via Hayoo" (Hayoo <$> strArgument idm <*> hayooPageArg <*> hayooPagesArg), - cmd "cabal" "cabal commands" (subparser $ cmd "list" "list cabal packages" (CabalList <$> many (textArgument idm))), - cmd "unresolveds" "list unresolved symbols in source file" (UnresolvedSymbols <$> many fileArg), - cmd "lint" "lint source files or file contents" (Lint <$> many cmdP <*> lintOpts), - cmd "check" "check source files or file contents" (Check <$> many cmdP <*> ghcOpts <*> clearFlag), - cmd "check-lint" "check and lint source files or file contents" (CheckLint <$> many cmdP <*> ghcOpts <*> lintOpts <*> clearFlag), - cmd "types" "get types for file expressions" (Types <$> many cmdP <*> ghcOpts <*> clearFlag), - cmd "autofixes" "get autofixes by output messages" (AutoFix <$> option readJSON (long "data" <> metavar "message" <> help "messages to make fixes for")), - cmd "refactor" "apply some refactors and get rest updated" (Refactor <$> - option readJSON (long "data" <> metavar "message" <> help "messages to fix") <*> - option readJSON (long "rest" <> metavar "correction" <> short 'r' <> help "update corrections") <*> - pureFlag), - cmd "rename" "get rename refactors" (Rename <$> textArgument idm <*> textArgument idm <*> ctx), - cmd "ghc" "ghc commands" ( - subparser (cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm) <*> optional cmdP)) <|> - subparser (cmd "type" "expression type" (GhcType <$> many (strArgument idm) <*> optional cmdP))), - cmd "langs" "ghc language options" (pure Langs), - cmd "flags" "ghc flags" (pure Flags), - cmd "link" "link to server" (Link <$> holdFlag), - cmd "stop-ghc" "stop ghc sessions" (pure StopGhc), - cmd "exit" "exit" (pure Exit)] - -instance FromCmd FileSource where - cmdP = option readJSON (long "contents") <|> (FileSource <$> fileArg <*> pure Nothing) - -instance FromCmd TargetFilter where - cmdP = asum [ - TargetProject <$> projectArg, - TargetFile <$> fileArg, - TargetModule <$> moduleArg, - TargetPackage <$> packageArg, - flag' TargetInstalled (long "installed"), - flag' TargetSourced (long "src"), - flag' TargetStandalone (long "stand")] - -instance FromCmd SearchQuery where - cmdP = SearchQuery <$> (textArgument idm <|> pure "") <*> asum [ - flag' SearchExact (long "exact"), - flag' SearchInfix (long "infix"), - flag' SearchSuffix (long "suffix"), - pure SearchPrefix <* switch (long "prefix")] - -readJSON :: FromJSON a => ReadM a -readJSON = str >>= maybe (readerError "Can't parse JSON argument") return . decode . L.pack - -textOption :: Mod OptionFields String -> Parser Text -textOption = fmap fromString . strOption - -textArgument :: Mod ArgumentFields String -> Parser Text -textArgument = fmap fromString . strArgument - -cabalFlag :: Parser Bool -clearFlag :: Parser Bool -contentsArg :: Parser Text -ctx :: Parser Path -depProjArg :: Parser Bool -depsArg :: Parser Bool -docsFlag :: Parser Bool -fileArg :: Parser Path -ghcOpts :: Parser [String] -hayooPageArg :: Parser Int -hayooPagesArg :: Parser Int -headerFlag :: Parser Bool -holdFlag :: Parser Bool -inferFlag :: Parser Bool -inspectionFlag :: Parser Bool -lintOpts :: Parser [String] -localsFlag :: Parser Bool -moduleArg :: Parser Text -packageArg :: Parser Text -packageDbArg :: Parser PackageDb -pathArg :: Mod OptionFields String -> Parser Path -projectArg :: Parser Path -pureFlag :: Parser Bool -sandboxArg :: Parser Path -toolArg :: Parser BuildTool -toolArg' :: Parser BuildTool -wideFlag :: Parser Bool - -cabalFlag = switch (long "cabal") -clearFlag = switch (long "clear" <> short 'c' <> help "clear run, drop previous state") -contentsArg = textOption (long "contents" <> help "text contents") -ctx = fileArg -depProjArg = fmap not $ switch (long "no-project" <> help "don't scan related project") -depsArg = fmap not $ switch (long "no-deps" <> help "don't scan dependent package-dbs") -docsFlag = switch (long "docs" <> help "scan source file docs") -fileArg = textOption (long "file" <> metavar "path" <> short 'f') -ghcOpts = many (strOption (long "ghc" <> metavar "option" <> short 'g' <> help "options to pass to GHC")) -hayooPageArg = option auto (long "page" <> metavar "n" <> short 'p' <> help "page number (0 by default)" <> value 0) -hayooPagesArg = option auto (long "pages" <> metavar "count" <> short 'n' <> help "pages count (1 by default)" <> value 1) -headerFlag = switch (long "header" <> short 'h' <> help "show only header of module") -holdFlag = switch (long "hold" <> short 'h' <> help "don't return any response") -inferFlag = switch (long "infer" <> help "infer types") -inspectionFlag = switch (long "inspection" <> short 'i' <> help "return inspection data") -lintOpts = many (strOption (long "lint" <> metavar "option" <> short 'l' <> help "options for hlint")) -localsFlag = switch (long "locals" <> short 'l' <> help "look in local declarations") -moduleArg = textOption (long "module" <> metavar "name" <> short 'm' <> help "module name") -packageArg = textOption (long "package" <> metavar "name" <> help "module package") -packageDbArg = - flag' GlobalDb (long "global-db" <> help "global package-db") <|> - flag' UserDb (long "user-db" <> help "per-user package-db") <|> - fmap PackageDb (textOption (long "package-db" <> metavar "path" <> help "custom package-db")) -pathArg f = textOption (long "path" <> metavar "path" <> short 'p' <> f) -projectArg = textOption (long "project" <> long "proj" <> metavar "project") -pureFlag = switch (long "pure" <> help "don't modify actual file, just return result") -sandboxArg = textOption (long "sandbox" <> metavar "path" <> help "path to cabal sandbox") -toolArg = - flag' CabalTool (long "cabal" <> help "use cabal as build tool") <|> - flag' StackTool (long "stack" <> help "use stack as build tool") <|> - toolArg' -toolArg' = option readTool (long "tool" <> help "specify build tool, `cabal` or `stack`") where - readTool :: ReadM BuildTool - readTool = do - s <- str @String - msum [ - guard (s == "cabal") >> return CabalTool, - guard (s == "stack") >> return StackTool, - readerError ("unknown build tool: {}" ~~ s)] - -wideFlag = switch (long "wide" <> short 'w' <> help "wide mode - complete as if there were no import lists") - -instance ToJSON Command where - toJSON Ping = cmdJson "ping" [] - toJSON (Listen lev) = cmdJson "listen" ["level" .= lev] - toJSON (SetLogLevel lev) = cmdJson "set-log" ["level" .= lev] - toJSON (Scan projs cabal sboxes fs ps btool ghcs docs' infer') = cmdJson "scan" [ - "projects" .= projs, - "cabal" .= cabal, - "sandboxes" .= sboxes, - "files" .= fs, - "paths" .= ps, - "build-tool" .= btool, - "ghc-opts" .= ghcs, - "docs" .= docs', - "infer" .= infer'] - toJSON (ScanProject proj tool deps) = cmdJson "scan project" [ - "project" .= proj, - "build-tool" .= tool, - "scan-deps" .= deps] - toJSON (ScanFile file' tool scanProj deps) = cmdJson "scan file" [ - "file" .= file', - "build-tool" .= tool, - "scan-project" .= scanProj, - "scan-deps" .= deps] - toJSON (ScanPackageDbs pdbs) = cmdJson "scan package-dbs" [ - "package-db-stack" .= pdbs] - toJSON (SetFileContents f cts) = cmdJson "set-file-contents" ["file" .= f, "contents" .= cts] - toJSON (RefineDocs projs fs) = cmdJson "docs" ["projects" .= projs, "files" .= fs] - toJSON (InferTypes projs fs) = cmdJson "infer" ["projects" .= projs, "files" .= fs] - toJSON (Remove projs cabal sboxes fs) = cmdJson "remove" ["projects" .= projs, "cabal" .= cabal, "sandboxes" .= sboxes, "files" .= fs] - toJSON RemoveAll = cmdJson "remove-all" [] - toJSON InfoPackages = cmdJson "packages" [] - toJSON InfoProjects = cmdJson "projects" [] - toJSON InfoSandboxes = cmdJson "sandboxes" [] - toJSON (InfoSymbol q tf h l) = cmdJson "symbol" ["query" .= q, "filters" .= tf, "header" .= h, "locals" .= l] - toJSON (InfoModule q tf h i) = cmdJson "module" ["query" .= q, "filters" .= tf, "header" .= h, "inspection" .= i] - toJSON (InfoProject p) = cmdJson "project" $ either (\pname -> ["name" .= pname]) (\ppath -> ["path" .= ppath]) p - toJSON (InfoSandbox p) = cmdJson "sandbox" ["path" .= p] - toJSON (Lookup n f) = cmdJson "lookup" ["name" .= n, "file" .= f] - toJSON (Whois n f) = cmdJson "whois" ["name" .= n, "file" .= f] - toJSON (Whoat l c f) = cmdJson "whoat" ["line" .= l, "column" .= c, "file" .= f] - toJSON (ResolveScopeModules q f) = cmdJson "scope modules" ["query" .= q, "file" .= f] - toJSON (ResolveScope q f) = cmdJson "scope" ["query" .= q, "file" .= f] - toJSON (FindUsages l c f) = cmdJson "usages" ["line" .= l, "column" .= c, "file" .= f] - toJSON (Complete q w f) = cmdJson "complete" ["prefix" .= q, "wide" .= w, "file" .= f] - toJSON (Hayoo q p ps) = cmdJson "hayoo" ["query" .= q, "page" .= p, "pages" .= ps] - toJSON (CabalList ps) = cmdJson "cabal list" ["packages" .= ps] - toJSON (UnresolvedSymbols fs) = cmdJson "unresolveds" ["files" .= fs] - toJSON (Lint fs lints) = cmdJson "lint" ["files" .= fs, "lint-opts" .= lints] - toJSON (Check fs ghcs c) = cmdJson "check" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c] - toJSON (CheckLint fs ghcs lints c) = cmdJson "check-lint" ["files" .= fs, "ghc-opts" .= ghcs, "lint-opts" .= lints, "clear" .= c] - toJSON (Types fs ghcs c) = cmdJson "types" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c] - toJSON (AutoFix ns) = cmdJson "autofixes" ["messages" .= ns] - toJSON (Refactor ns rests pure') = cmdJson "refactor" ["messages" .= ns, "rest" .= rests, "pure" .= pure'] - toJSON (Rename n n' f) = cmdJson "rename" ["name" .= n, "new-name" .= n', "file" .= f] - toJSON (GhcEval exprs f) = cmdJson "ghc eval" ["exprs" .= exprs, "file" .= f] - toJSON (GhcType exprs f) = cmdJson "ghc type" ["exprs" .= exprs, "file" .= f] - toJSON Langs = cmdJson "langs" [] - toJSON Flags = cmdJson "flags" [] - toJSON (Link h) = cmdJson "link" ["hold" .= h] - toJSON StopGhc = cmdJson "stop-ghc" [] - toJSON Exit = cmdJson "exit" [] - -instance FromJSON Command where - parseJSON = withObject "command" $ \v -> asum [ - guardCmd "ping" v *> pure Ping, - guardCmd "listen" v *> (Listen <$> v .::? "level"), - guardCmd "set-log" v *> (SetLogLevel <$> v .:: "level"), - guardCmd "scan" v *> (Scan <$> - v .::?! "projects" <*> - (v .:: "cabal" <|> pure False) <*> - v .::?! "sandboxes" <*> - v .::?! "files" <*> - v .::?! "paths" <*> - (v .:: "build-tool" <|> pure CabalTool) <*> - v .::?! "ghc-opts" <*> - (v .:: "docs" <|> pure False) <*> - (v .:: "infer" <|> pure False)), - guardCmd "scan project" v *> (ScanProject <$> - v .:: "project" <*> - v .:: "build-tool" <*> - (v .:: "scan-deps" <|> pure True)), - guardCmd "scan file" v *> (ScanFile <$> - v .:: "file" <*> - (v .:: "build-tool" <|> pure CabalTool) <*> - (v .:: "scan-project" <|> pure True) <*> - (v .:: "scan-deps" <|> pure True)), - guardCmd "scan package-dbs" v *> (ScanPackageDbs <$> v .:: "package-db-stack"), - guardCmd "set-file-contents" v *> (SetFileContents <$> v .:: "file" <*> v .:: "contents"), - guardCmd "docs" v *> (RefineDocs <$> v .::?! "projects" <*> v .::?! "files"), - guardCmd "infer" v *> (InferTypes <$> v .::?! "projects" <*> v .::?! "files"), - guardCmd "remove" v *> (Remove <$> - v .::?! "projects" <*> - (v .:: "cabal" <|> pure False) <*> - v .::?! "sandboxes" <*> - v .::?! "files"), - guardCmd "remove-all" v *> pure RemoveAll, - guardCmd "packages" v *> pure InfoPackages, - guardCmd "projects" v *> pure InfoProjects, - guardCmd "sandboxes" v *> pure InfoSandboxes, - guardCmd "symbol" v *> (InfoSymbol <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> (v .:: "locals" <|> pure False)), - guardCmd "module" v *> (InfoModule <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> v .:: "inspection"), - guardCmd "project" v *> (InfoProject <$> asum [Left <$> v .:: "name", Right <$> v .:: "path"]), - guardCmd "sandbox" v *> (InfoSandbox <$> v .:: "path"), - guardCmd "lookup" v *> (Lookup <$> v .:: "name" <*> v .:: "file"), - guardCmd "whois" v *> (Whois <$> v .:: "name" <*> v .:: "file"), - guardCmd "whoat" v *> (Whoat <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"), - guardCmd "scope modules" v *> (ResolveScopeModules <$> v .:: "query" <*> v .:: "file"), - guardCmd "scope" v *> (ResolveScope <$> v .:: "query" <*> v .:: "file"), - guardCmd "usages" v *> (FindUsages <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"), - guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> (v .:: "wide" <|> pure False) <*> v .:: "file"), - guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> (v .:: "page" <|> pure 0) <*> (v .:: "pages" <|> pure 1)), - guardCmd "cabal list" v *> (CabalList <$> v .::?! "packages"), - guardCmd "unresolveds" v *> (UnresolvedSymbols <$> v .::?! "files"), - guardCmd "lint" v *> (Lint <$> v .::?! "files" <*> v .::?! "lint-opts"), - guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)), - guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> v .::?! "lint-opts" <*> (v .:: "clear" <|> pure False)), - guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)), - guardCmd "autofixes" v *> (AutoFix <$> v .:: "messages"), - guardCmd "refactor" v *> (Refactor <$> v .:: "messages" <*> v .::?! "rest" <*> (v .:: "pure" <|> pure True)), - guardCmd "rename" v *> (Rename <$> v .:: "name" <*> v .:: "new-name" <*> v .:: "file"), - guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs" <*> v .::? "file"), - guardCmd "ghc type" v *> (GhcType <$> v .::?! "exprs" <*> v .::? "file"), - guardCmd "langs" v *> pure Langs, - guardCmd "flags" v *> pure Flags, - guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)), - guardCmd "stop-ghc" v *> pure StopGhc, - guardCmd "exit" v *> pure Exit] - -instance ToJSON FileSource where - toJSON (FileSource fpath mcts) = object ["file" .= fpath, "contents" .= mcts] - -instance FromJSON FileSource where - parseJSON = withObject "file-contents" $ \v -> FileSource <$> v .:: "file" <*> v .::? "contents" - -instance ToJSON TargetFilter where - toJSON (TargetProject pname) = object ["project" .= pname] - toJSON (TargetFile fpath) = object ["file" .= fpath] - toJSON (TargetModule mname) = object ["module" .= mname] - toJSON (TargetPackage pkg) = object ["package" .= pkg] - toJSON TargetInstalled = toJSON ("installed" :: String) - toJSON TargetSourced = toJSON ("sourced" :: String) - toJSON TargetStandalone = toJSON ("standalone" :: String) - -instance FromJSON TargetFilter where - parseJSON j = obj j <|> str' where - obj = withObject "target-filter" $ \v -> asum [ - TargetProject <$> v .:: "project", - TargetFile <$> v .:: "file", - TargetModule <$> v .:: "module", - TargetPackage <$> v .:: "package"] - str' = do - s <- parseJSON j :: A.Parser String - case s of - "installed" -> return TargetInstalled - "sourced" -> return TargetSourced - "standalone" -> return TargetStandalone - _ -> empty - -instance ToJSON SearchQuery where - toJSON (SearchQuery q st) = object ["input" .= q, "type" .= st] - -instance FromJSON SearchQuery where - parseJSON = withObject "search-query" $ \v -> SearchQuery <$> (v .:: "input" <|> pure "") <*> (v .:: "type" <|> pure SearchPrefix) - -instance ToJSON SearchType where - toJSON SearchExact = toJSON ("exact" :: String) - toJSON SearchPrefix = toJSON ("prefix" :: String) - toJSON SearchInfix = toJSON ("infix" :: String) - toJSON SearchSuffix = toJSON ("suffix" :: String) - -instance FromJSON SearchType where - parseJSON v = do - str' <- parseJSON v :: A.Parser String - case str' of - "exact" -> return SearchExact - "prefix" -> return SearchPrefix - "infix" -> return SearchInfix - "suffix" -> return SearchInfix - _ -> empty +{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds, TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Server.Types ( + ServerMonadBase, + SessionLog(..), Session(..), SessionMonad(..), askSession, ServerM(..), + CommandOptions(..), CommandMonad(..), askOptions, ClientM(..), + withSession, serverListen, serverSetLogLevel, serverWait, serverWaitClients, + serverSqlDatabase, openSqlConnection, closeSqlConnection, withSqlConnection, withSqlTransaction, serverSetFileContents, + inSessionGhc, inSessionUpdater, postSessionUpdater, serverExit, commandRoot, commandNotify, commandLink, commandHold, + ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..), + + Command(..), + FileSource(..), TargetFilter(..), SearchQuery(..), SearchType(..), + FromCmd(..), + ) where + +import Control.Applicative +import Control.Concurrent.Async (Async) +import qualified Control.Concurrent.FiniteChan as F +import Control.Lens (view, set) +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Fail +import Control.Monad.Morph +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Control.Monad.Trans.Control +import Data.Aeson hiding (Result(..), Error) +import qualified Data.Aeson.Types as A +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Default +import Data.Maybe (fromMaybe) +import Data.Foldable (asum) +import Data.Text (Text) +import Data.String (fromString) +import qualified Database.SQLite.Simple as SQL +import qualified Network.HTTP.Client as HTTP +import Options.Applicative +import System.Log.Simple as Log + +import Control.Concurrent.Worker +import Data.LookupTable +import System.Directory.Paths +import Text.Format (Formattable(..), (~~)) + +import HsDev.Error (hsdevError) +import HsDev.Inspect.Types +import HsDev.Server.Message +import HsDev.Watcher.Types (Watcher) +import HsDev.PackageDb.Types +import HsDev.Project.Types +import HsDev.Tools.Ghc.Worker (GhcWorker, GhcM) +import HsDev.Tools.Types (Note, OutputMessage) +import HsDev.Tools.AutoFix (Refact) +import HsDev.Types (HsDevError(..)) +import HsDev.Util + +#if mingw32_HOST_OS +import System.Win32.FileMapping.NamePool (Pool) +#endif + +type ServerMonadBase m = (MonadIO m, MonadFail m, MonadMask m, MonadBaseControl IO m, Alternative m, MonadPlus m) + +data SessionLog = SessionLog { + sessionLogger :: Log, + sessionListenLog :: IO [Log.Message], + sessionLogWait :: IO () } + +data Session = Session { + sessionSqlDatabase :: SQL.Connection, + sessionSqlPath :: String, + sessionLog :: SessionLog, + sessionWatcher :: Maybe Watcher, + sessionFileContents :: Path -> Maybe Text -> IO (), +#if mingw32_HOST_OS + sessionMmapPool :: Maybe Pool, +#endif + sessionGhc :: GhcWorker, + sessionUpdater :: Worker (ServerM IO), + sessionResolveEnvironment :: LookupTable (Maybe Path) (Environment, FixitiesTable), + sessionHTTPManager :: HTTP.Manager, + sessionExit :: IO (), + sessionWait :: IO (), + sessionClients :: F.Chan (IO ()), + sessionDefines :: [(String, String)] } + +class (ServerMonadBase m, MonadLog m) => SessionMonad m where + getSession :: m Session + localSession :: (Session -> Session) -> m a -> m a + +askSession :: SessionMonad m => (Session -> a) -> m a +askSession f = liftM f getSession + +newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a } + deriving (Functor, Applicative, Alternative, Monad, MonadFail, MonadPlus, MonadIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch, MonadMask) + +instance (MonadIO m, MonadMask m) => MonadLog (ServerM m) where + askLog = ServerM $ asks (sessionLogger . sessionLog) + localLog fn = ServerM . local setLog' . runServerM where + setLog' sess = sess { sessionLog = (sessionLog sess) { sessionLogger = fn (sessionLogger (sessionLog sess)) } } + +instance ServerMonadBase m => SessionMonad (ServerM m) where + getSession = ask + localSession = local + +instance MonadBase b m => MonadBase b (ServerM m) where + liftBase = ServerM . liftBase + +instance MonadBaseControl b m => MonadBaseControl b (ServerM m) where + type StM (ServerM m) a = StM (ReaderT Session m) a + liftBaseWith f = ServerM $ liftBaseWith (\f' -> f (f' . runServerM)) + restoreM = ServerM . restoreM + +instance MFunctor ServerM where + hoist fn = ServerM . hoist fn . runServerM + +instance SessionMonad m => SessionMonad (ReaderT r m) where + getSession = lift getSession + localSession = mapReaderT . localSession + +instance (SessionMonad m, Monoid w) => SessionMonad (WriterT w m) where + getSession = lift getSession + localSession = mapWriterT . localSession + +instance SessionMonad m => SessionMonad (StateT s m) where + getSession = lift getSession + localSession = mapStateT . localSession + +data CommandOptions = CommandOptions { + commandOptionsRoot :: FilePath, + commandOptionsNotify :: Notification -> IO (), + commandOptionsLink :: IO (), + commandOptionsHold :: IO () } + +instance Default CommandOptions where + def = CommandOptions "." (const $ return ()) (return ()) (return ()) + +class (SessionMonad m, MonadPlus m) => CommandMonad m where + getOptions :: m CommandOptions + +askOptions :: CommandMonad m => (CommandOptions -> a) -> m a +askOptions f = liftM f getOptions + +newtype ClientM m a = ClientM { runClientM :: ServerM (ReaderT CommandOptions m) a } + deriving (Functor, Applicative, Alternative, Monad, MonadFail, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask) + +instance MonadTrans ClientM where + lift = ClientM . lift . lift + +instance (MonadIO m, MonadMask m) => MonadLog (ClientM m) where + askLog = ClientM askLog + localLog fn = ClientM . localLog fn . runClientM + +instance ServerMonadBase m => SessionMonad (ClientM m) where + getSession = ClientM getSession + localSession fn = ClientM . localSession fn . runClientM + +instance ServerMonadBase m => CommandMonad (ClientM m) where + getOptions = ClientM $ lift ask + +instance MonadBase b m => MonadBase b (ClientM m) where + liftBase = ClientM . liftBase + +instance MonadBaseControl b m => MonadBaseControl b (ClientM m) where + type StM (ClientM m) a = StM (ServerM (ReaderT CommandOptions m)) a + liftBaseWith f = ClientM $ liftBaseWith (\f' -> f (f' . runClientM)) + restoreM = ClientM . restoreM + +instance MFunctor ClientM where + hoist fn = ClientM . hoist (hoist fn) . runClientM + +instance CommandMonad m => CommandMonad (ReaderT r m) where + getOptions = lift getOptions + +instance (CommandMonad m, Monoid w) => CommandMonad (WriterT w m) where + getOptions = lift getOptions + +instance CommandMonad m => CommandMonad (StateT s m) where + getOptions = lift getOptions + +-- | Run action on session +withSession :: Session -> ServerM m a -> m a +withSession s act = runReaderT (runServerM act) s + +-- | Listen server's log +serverListen :: SessionMonad m => m [Log.Message] +serverListen = join . liftM liftIO $ askSession (sessionListenLog . sessionLog) + +-- | Set server's log config +serverSetLogLevel :: SessionMonad m => Level -> m Level +serverSetLogLevel lev = do + l <- askSession (sessionLogger . sessionLog) + cfg <- updateLogConfig l (set (componentCfg "") (Just lev)) + return $ fromMaybe def $ view (componentCfg "") cfg + +-- | Wait for server +serverWait :: SessionMonad m => m () +serverWait = join . liftM liftIO $ askSession sessionWait + +-- | Wait while clients disconnects +serverWaitClients :: SessionMonad m => m () +serverWaitClients = do + clientChan <- askSession sessionClients + liftIO (F.stopChan clientChan) >>= sequence_ . map liftIO + +-- | Get sql connection +serverSqlDatabase :: SessionMonad m => m SQL.Connection +serverSqlDatabase = askSession sessionSqlDatabase + +-- | Open new sql connection +openSqlConnection :: SessionMonad m => m SQL.Connection +openSqlConnection = do + p <- askSession sessionSqlPath + -- FIXME: There's `new` function in HsDev's SQLite module + liftIO $ do + conn <- SQL.open p + SQL.execute_ conn "pragma case_sensitive_like = true;" + SQL.execute_ conn "pragma synchronous = off;" + SQL.execute_ conn "pragma journal_mode = memory;" + return conn + +-- | Close sql connection +closeSqlConnection :: SessionMonad m => SQL.Connection -> m () +closeSqlConnection = liftIO . SQL.close + +-- | Locally opens new connection, updating @Session@ +withSqlConnection :: SessionMonad m => m a -> m a +withSqlConnection act = bracket openSqlConnection closeSqlConnection $ \conn -> + localSession (\sess -> sess { sessionSqlDatabase = conn }) act + +-- | With sql transaction +withSqlTransaction :: SessionMonad m => ServerM IO a -> m a +withSqlTransaction fn = do + conn <- serverSqlDatabase + sess <- getSession + liftIO $ SQL.withTransaction conn $ withSession sess fn + +-- | Set custom file contents +serverSetFileContents :: SessionMonad m => Path -> Maybe Text -> m () +serverSetFileContents fpath mcts = do + setCts <- askSession sessionFileContents + liftIO $ setCts fpath mcts + +-- | In ghc session +inSessionGhc :: SessionMonad m => GhcM a -> m a +inSessionGhc act = do + ghcw <- askSession sessionGhc + inWorkerWith (hsdevError . GhcError . displayException) ghcw act + +-- | In updater +inSessionUpdater :: SessionMonad m => ServerM IO a -> m a +inSessionUpdater act = do + uw <- askSession sessionUpdater + inWorkerWith (hsdevError . OtherError . displayException) uw act + +-- | Post to updater and return +postSessionUpdater :: SessionMonad m => ServerM IO a -> m (Async a) +postSessionUpdater act = do + uw <- askSession sessionUpdater + liftIO $ sendTask uw act + +-- | Exit session +serverExit :: SessionMonad m => m () +serverExit = join . liftM liftIO $ askSession sessionExit + +commandRoot :: CommandMonad m => m FilePath +commandRoot = askOptions commandOptionsRoot + +commandNotify :: CommandMonad m => Notification -> m () +commandNotify n = join . liftM liftIO $ askOptions commandOptionsNotify <*> pure n + +commandLink :: CommandMonad m => m () +commandLink = join . liftM liftIO $ askOptions commandOptionsLink + +commandHold :: CommandMonad m => m () +commandHold = join . liftM liftIO $ askOptions commandOptionsHold + +-- | Server control command +data ServerCommand = + Version Bool | + Start ServerOpts | + Run ServerOpts | + Stop ClientOpts | + Connect ClientOpts | + Remote ClientOpts Bool Command + deriving (Show) + +data ConnectionPort = NetworkPort Int | UnixPort String deriving (Eq, Read) + +instance Default ConnectionPort where + def = NetworkPort 4567 + +instance Show ConnectionPort where + show (NetworkPort p) = show p + show (UnixPort s) = "unix " ++ s + +instance Formattable ConnectionPort + +-- | Server options +data ServerOpts = ServerOpts { + serverPort :: ConnectionPort, + serverTimeout :: Int, + serverLog :: Maybe FilePath, + serverLogLevel :: String, + serverLogNoColor :: Bool, + serverDbFile :: Maybe FilePath, + serverWatchFS :: Bool, + serverSilent :: Bool } + deriving (Show) + +instance Default ServerOpts where + def = ServerOpts def 0 Nothing "info" False Nothing True False + +-- | Silent server with no connection, useful for ghci +silentOpts :: ServerOpts +silentOpts = def { serverSilent = True } + +-- | Client options +data ClientOpts = ClientOpts { + clientPort :: ConnectionPort, + clientPretty :: Bool, + clientStdin :: Bool, + clientTimeout :: Int, + clientSilent :: Bool } + deriving (Show) + +instance Default ClientOpts where + def = ClientOpts def False False 0 False + +instance FromCmd ServerCommand where + cmdP = serv <|> remote where + serv = subparser $ mconcat [ + cmd "version" "hsdev version" (Version <$> compilerVersionFlag), + cmd "start" "start remote server" (Start <$> cmdP), + cmd "run" "run server" (Run <$> cmdP), + cmd "stop" "stop remote server" (Stop <$> cmdP), + cmd "connect" "connect to send commands directly" (Connect <$> cmdP)] + remote = Remote <$> cmdP <*> noFileFlag <*> cmdP + +instance FromCmd ServerOpts where + cmdP = ServerOpts <$> + (connectionArg <|> pure (serverPort def)) <*> + (timeoutArg <|> pure (serverTimeout def)) <*> + optional logArg <*> + (logLevelArg <|> pure (serverLogLevel def)) <*> + noColorFlag <*> + optional dbFileArg <*> + (not <$> noWatchFlag) <*> + serverSilentFlag + +instance FromCmd ClientOpts where + cmdP = ClientOpts <$> + (connectionArg <|> pure (clientPort def)) <*> + prettyFlag <*> + stdinFlag <*> + (timeoutArg <|> pure (clientTimeout def)) <*> + silentFlag + +portArg :: Parser ConnectionPort +compilerVersionFlag :: Parser Bool +connectionArg :: Parser ConnectionPort +timeoutArg :: Parser Int +logArg :: Parser FilePath +logLevelArg :: Parser String +noColorFlag :: Parser Bool +noFileFlag :: Parser Bool +prettyFlag :: Parser Bool +serverSilentFlag :: Parser Bool +stdinFlag :: Parser Bool +silentFlag :: Parser Bool +dbFileArg :: Parser FilePath +noWatchFlag :: Parser Bool + +portArg = NetworkPort <$> option auto (long "port" <> metavar "number" <> help "connection port") +compilerVersionFlag = switch (long "compiler" <> short 'c' <> help "show compiler version") +#if mingw32_HOST_OS +connectionArg = portArg +#else +unixArg :: Parser ConnectionPort +unixArg = UnixPort <$> strOption (long "unix" <> metavar "name" <> help "unix connection port") +connectionArg = portArg <|> unixArg +#endif +timeoutArg = option auto (long "timeout" <> metavar "msec" <> help "query timeout") +logArg = strOption (long "log" <> short 'l' <> metavar "file" <> help "log file") +logLevelArg = strOption (long "log-level" <> metavar "level" <> help "log level: trace/debug/info/warning/error/fatal") +noColorFlag = switch (long "no-color" <> help "don't use colorized log output") +noFileFlag = switch (long "no-file" <> help "don't use mmap files") +prettyFlag = switch (long "pretty" <> help "pretty json output") +serverSilentFlag = switch (long "silent" <> help "no stdout/stderr") +stdinFlag = switch (long "stdin" <> help "pass data to stdin") +silentFlag = switch (long "silent" <> help "supress notifications") +dbFileArg = strOption (long "db" <> metavar "path" <> help "path to sql database") +noWatchFlag = switch (long "no-watch" <> help "don't watch filesystem for source changes") + +serverOptsArgs :: ServerOpts -> [String] +serverOptsArgs sopts = concat [ + portArgs (serverPort sopts), + ["--timeout", show $ serverTimeout sopts], + marg "--log" (serverLog sopts), + ["--log-level", serverLogLevel sopts], + marg "--db" (serverDbFile sopts), + ["--silent" | serverSilent sopts]] + where + marg :: String -> Maybe String -> [String] + marg n (Just v) = [n, v] + marg _ _ = [] + portArgs :: ConnectionPort -> [String] + portArgs (NetworkPort n) = ["--port", show n] + portArgs (UnixPort s) = ["--unix", s] + +data Request = Request { + requestCommand :: Command, + requestDirectory :: FilePath, + requestNoFile :: Bool, + requestTimeout :: Int, + requestSilent :: Bool } + deriving (Show) + +instance ToJSON Request where + toJSON (Request c dir f tm s) = object ["current-directory" .= dir, "no-file" .= f, "timeout" .= tm, "silent" .= s] `objectUnion` toJSON c + +instance FromJSON Request where + parseJSON = withObject "request" $ \v -> Request <$> + parseJSON (Object v) <*> + ((v .:: "current-directory") <|> pure ".") <*> + ((v .:: "no-file") <|> pure False) <*> + ((v .:: "timeout") <|> pure 0) <*> + ((v .:: "silent") <|> pure False) + +-- | Command from client +data Command = + Ping | + Listen (Maybe String) | + SetLogLevel String | + Scan { + scanProjects :: [Path], + scanCabal :: Bool, + scanSandboxes :: [Path], + scanFiles :: [FileSource], + scanPaths :: [Path], + scanBuildTool :: BuildTool, + scanGhcOpts :: [String], + scanDocs :: Bool, + scanInferTypes :: Bool } | + ScanProject { + scanProjectPath :: Path, + scanProjectBuildTool :: BuildTool, + scanProjectDeps :: Bool } | + ScanFile { + scanFilePath :: Path, + scanFileBuildTool :: BuildTool, + scanFileProject :: Bool, + scanFileDeps :: Bool } | + ScanPackageDbs { + scanPackageDbStack :: PackageDbStack } | + SetFileContents Path (Maybe Text) | + RefineDocs { + docsProjects :: [Path], + docsFiles :: [Path] } | + InferTypes { + inferProjects :: [Path], + inferFiles :: [Path] } | + Remove { + removeProjects :: [Path], + removeCabal :: Bool, + removeSandboxes :: [Path], + removeFiles :: [Path] } | + RemoveAll | + InfoPackages | + InfoProjects | + InfoSandboxes | + InfoSymbol SearchQuery [TargetFilter] Bool Bool | + InfoModule SearchQuery [TargetFilter] Bool Bool | + InfoProject (Either Text Path) | + InfoSandbox Path | + Lookup Text Path | + Whois Text Path | + Whoat Int Int Path | + ResolveScopeModules SearchQuery Path | + ResolveScope SearchQuery Path | + FindUsages Int Int Path | + Complete Text Bool Path | + Hayoo { + hayooQuery :: String, + hayooPage :: Int, + hayooPages :: Int } | + CabalList { cabalListPackages :: [Text] } | + UnresolvedSymbols { + unresolvedFiles :: [Path] } | + Lint { + lintFiles :: [FileSource], + lintHlintOpts :: [String] + } | + Check { + checkFiles :: [FileSource], + checkGhcOpts :: [String], + checkClear :: Bool } | + CheckLint { + checkLintFiles :: [FileSource], + checkLintGhcOpts :: [String], + checkLintOpts :: [String], + checkLinkClear :: Bool } | + Types { + typesFiles :: [FileSource], + typesGhcOpts :: [String], + typesClear :: Bool } | + AutoFix [Note OutputMessage] | + Refactor [Note Refact] [Note Refact] Bool | + Rename Text Text Path | + GhcEval { ghcEvalExpressions :: [String], ghcEvalSource :: Maybe FileSource } | + GhcType { ghcTypeExpressions :: [String], ghcTypeSource :: Maybe FileSource } | + Langs | + Flags | + Link { linkHold :: Bool } | + StopGhc | + Exit + deriving (Show) + +data FileSource = FileSource { fileSource :: Path, fileContents :: Maybe Text } deriving (Show) +data TargetFilter = + TargetProject Text | + TargetFile Path | + TargetModule Text | + TargetPackage Text | + TargetInstalled | + TargetSourced | + TargetStandalone + deriving (Eq, Show) +data SearchQuery = SearchQuery Text SearchType deriving (Show) +data SearchType = SearchExact | SearchPrefix | SearchInfix | SearchSuffix deriving (Show) + +instance Paths Command where + paths f (Scan projs c cs fs ps btool ghcs docs infer) = Scan <$> + traverse (paths f) projs <*> + pure c <*> + traverse (paths f) cs <*> + traverse (paths f) fs <*> + traverse (paths f) ps <*> + pure btool <*> + pure ghcs <*> + pure docs <*> + pure infer + paths f (ScanProject proj tool deps) = ScanProject <$> paths f proj <*> pure tool <*> pure deps + paths f (ScanFile file' tool scanProj deps) = ScanFile <$> paths f file' <*> pure tool <*> pure scanProj <*> pure deps + paths f (ScanPackageDbs pdbs) = ScanPackageDbs <$> paths f pdbs + paths f (SetFileContents p cts) = SetFileContents <$> paths f p <*> pure cts + paths f (RefineDocs projs fs) = RefineDocs <$> traverse (paths f) projs <*> traverse (paths f) fs + paths f (InferTypes projs fs) = InferTypes <$> traverse (paths f) projs <*> traverse (paths f) fs + paths f (Remove projs c cs fs) = Remove <$> traverse (paths f) projs <*> pure c <*> traverse (paths f) cs <*> traverse (paths f) fs + paths _ RemoveAll = pure RemoveAll + paths f (InfoSymbol q t h l) = InfoSymbol <$> pure q <*> traverse (paths f) t <*> pure h <*> pure l + paths f (InfoModule q t h i) = InfoModule <$> pure q <*> traverse (paths f) t <*> pure h <*> pure i + paths f (InfoProject (Right proj)) = InfoProject <$> (Right <$> paths f proj) + paths f (InfoSandbox fpath) = InfoSandbox <$> paths f fpath + paths f (Lookup n fpath) = Lookup <$> pure n <*> paths f fpath + paths f (Whois n fpath) = Whois <$> pure n <*> paths f fpath + paths f (Whoat l c fpath) = Whoat <$> pure l <*> pure c <*> paths f fpath + paths f (ResolveScopeModules q fpath) = ResolveScopeModules q <$> paths f fpath + paths f (ResolveScope q fpath) = ResolveScope q <$> paths f fpath + paths f (FindUsages l c fpath) = FindUsages <$> pure l <*> pure c <*> paths f fpath + paths f (Complete n g fpath) = Complete n g <$> paths f fpath + paths f (UnresolvedSymbols fs) = UnresolvedSymbols <$> traverse (paths f) fs + paths f (Lint fs lints) = Lint <$> traverse (paths f) fs <*> pure lints + paths f (Check fs ghcs c) = Check <$> traverse (paths f) fs <*> pure ghcs <*> pure c + paths f (CheckLint fs ghcs lints c) = CheckLint <$> traverse (paths f) fs <*> pure ghcs <*> pure lints <*> pure c + paths f (Types fs ghcs c) = Types <$> traverse (paths f) fs <*> pure ghcs <*> pure c + paths f (GhcEval e mf) = GhcEval e <$> traverse (paths f) mf + paths f (GhcType e mf) = GhcType e <$> traverse (paths f) mf + paths _ c = pure c + +instance Paths FileSource where + paths f (FileSource fpath mcts) = FileSource <$> paths f fpath <*> pure mcts + +instance Paths TargetFilter where + paths f (TargetFile fpath) = TargetFile <$> paths f fpath + paths _ t = pure t + +instance FromCmd Command where + cmdP = subparser $ mconcat [ + cmd "ping" "ping server" (pure Ping), + cmd "listen" "listen server log" (Listen <$> optional logLevelArg), + cmd "set-log" "set log level" (SetLogLevel <$> strArgument idm), + cmd "scan" "scan sources" ( + subparser (cmd "project" "scan project" (ScanProject <$> textArgument idm <*> toolArg <*> depsArg)) <|> + subparser (cmd "file" "scan file" (ScanFile <$> textArgument idm <*> (toolArg <|> pure CabalTool) <*> depProjArg <*> depsArg)) <|> + subparser (cmd "package-dbs" "scan package-dbs; note, that order of package-dbs matters - dependent package-dbs should go first" (ScanPackageDbs <$> (mkPackageDbStack <$> many packageDbArg))) <|> + (Scan <$> + many projectArg <*> + cabalFlag <*> + many sandboxArg <*> + many cmdP <*> + many (pathArg $ help "path") <*> + (toolArg' <|> pure CabalTool) <*> + ghcOpts <*> + docsFlag <*> + inferFlag)), + cmd "set-file-contents" "set edited file contents, which will be used instead of contents in file until it updated" $ + SetFileContents <$> fileArg <*> optional contentsArg, + cmd "docs" "scan docs" $ RefineDocs <$> many projectArg <*> many fileArg, + cmd "infer" "infer types" $ InferTypes <$> many projectArg <*> many fileArg, + cmd "remove" "remove modules info" $ Remove <$> + many projectArg <*> + cabalFlag <*> + many sandboxArg <*> + many fileArg, + cmd "remove-all" "remove all data" (pure RemoveAll), + cmd "packages" "list packages" (pure InfoPackages), + cmd "projects" "list projects" (pure InfoProjects), + cmd "sandboxes" "list sandboxes" (pure InfoSandboxes), + cmd "symbol" "get symbol info" (InfoSymbol <$> cmdP <*> many cmdP <*> headerFlag <*> localsFlag), + cmd "module" "get module info" (InfoModule <$> cmdP <*> many cmdP <*> headerFlag <*> inspectionFlag), + cmd "project" "get project info" (InfoProject <$> ((Left <$> projectArg) <|> (Right <$> pathArg idm))), + cmd "sandbox" "get sandbox info" (InfoSandbox <$> pathArg (help "locate sandbox in parent of this path")), + cmd "lookup" "lookup for symbol" (Lookup <$> textArgument idm <*> ctx), + cmd "whois" "get info for symbol" (Whois <$> textArgument idm <*> ctx), + cmd "whoat" "get info for symbol under cursor" (Whoat <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx), + cmd "scope" "get declarations accessible from module or within a project" ( + subparser (cmd "modules" "get modules accessible from module or within a project" (ResolveScopeModules <$> cmdP <*> ctx)) <|> + ResolveScope <$> cmdP <*> ctx), + cmd "usages" "find usages of symbol within project/module" (FindUsages <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx), + cmd "complete" "show completions for input" (Complete <$> textArgument idm <*> wideFlag <*> ctx), + cmd "hayoo" "find declarations online via Hayoo" (Hayoo <$> strArgument idm <*> hayooPageArg <*> hayooPagesArg), + cmd "cabal" "cabal commands" (subparser $ cmd "list" "list cabal packages" (CabalList <$> many (textArgument idm))), + cmd "unresolveds" "list unresolved symbols in source file" (UnresolvedSymbols <$> many fileArg), + cmd "lint" "lint source files or file contents" (Lint <$> many cmdP <*> lintOpts), + cmd "check" "check source files or file contents" (Check <$> many cmdP <*> ghcOpts <*> clearFlag), + cmd "check-lint" "check and lint source files or file contents" (CheckLint <$> many cmdP <*> ghcOpts <*> lintOpts <*> clearFlag), + cmd "types" "get types for file expressions" (Types <$> many cmdP <*> ghcOpts <*> clearFlag), + cmd "autofixes" "get autofixes by output messages" (AutoFix <$> option readJSON (long "data" <> metavar "message" <> help "messages to make fixes for")), + cmd "refactor" "apply some refactors and get rest updated" (Refactor <$> + option readJSON (long "data" <> metavar "message" <> help "messages to fix") <*> + option readJSON (long "rest" <> metavar "correction" <> short 'r' <> help "update corrections") <*> + pureFlag), + cmd "rename" "get rename refactors" (Rename <$> textArgument idm <*> textArgument idm <*> ctx), + cmd "ghc" "ghc commands" ( + subparser (cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm) <*> optional cmdP)) <|> + subparser (cmd "type" "expression type" (GhcType <$> many (strArgument idm) <*> optional cmdP))), + cmd "langs" "ghc language options" (pure Langs), + cmd "flags" "ghc flags" (pure Flags), + cmd "link" "link to server" (Link <$> holdFlag), + cmd "stop-ghc" "stop ghc sessions" (pure StopGhc), + cmd "exit" "exit" (pure Exit)] + +instance FromCmd FileSource where + cmdP = option readJSON (long "contents") <|> (FileSource <$> fileArg <*> pure Nothing) + +instance FromCmd TargetFilter where + cmdP = asum [ + TargetProject <$> projectArg, + TargetFile <$> fileArg, + TargetModule <$> moduleArg, + TargetPackage <$> packageArg, + flag' TargetInstalled (long "installed"), + flag' TargetSourced (long "src"), + flag' TargetStandalone (long "stand")] + +instance FromCmd SearchQuery where + cmdP = SearchQuery <$> (textArgument idm <|> pure "") <*> asum [ + flag' SearchExact (long "exact"), + flag' SearchInfix (long "infix"), + flag' SearchSuffix (long "suffix"), + pure SearchPrefix <* switch (long "prefix")] + +readJSON :: FromJSON a => ReadM a +readJSON = str >>= maybe (readerError "Can't parse JSON argument") return . decode . L.pack + +textOption :: Mod OptionFields String -> Parser Text +textOption = fmap fromString . strOption + +textArgument :: Mod ArgumentFields String -> Parser Text +textArgument = fmap fromString . strArgument + +cabalFlag :: Parser Bool +clearFlag :: Parser Bool +contentsArg :: Parser Text +ctx :: Parser Path +depProjArg :: Parser Bool +depsArg :: Parser Bool +docsFlag :: Parser Bool +fileArg :: Parser Path +ghcOpts :: Parser [String] +hayooPageArg :: Parser Int +hayooPagesArg :: Parser Int +headerFlag :: Parser Bool +holdFlag :: Parser Bool +inferFlag :: Parser Bool +inspectionFlag :: Parser Bool +lintOpts :: Parser [String] +localsFlag :: Parser Bool +moduleArg :: Parser Text +packageArg :: Parser Text +packageDbArg :: Parser PackageDb +pathArg :: Mod OptionFields String -> Parser Path +projectArg :: Parser Path +pureFlag :: Parser Bool +sandboxArg :: Parser Path +toolArg :: Parser BuildTool +toolArg' :: Parser BuildTool +wideFlag :: Parser Bool + +cabalFlag = switch (long "cabal") +clearFlag = switch (long "clear" <> short 'c' <> help "clear run, drop previous state") +contentsArg = textOption (long "contents" <> help "text contents") +ctx = fileArg +depProjArg = fmap not $ switch (long "no-project" <> help "don't scan related project") +depsArg = fmap not $ switch (long "no-deps" <> help "don't scan dependent package-dbs") +docsFlag = switch (long "docs" <> help "scan source file docs") +fileArg = textOption (long "file" <> metavar "path" <> short 'f') +ghcOpts = many (strOption (long "ghc" <> metavar "option" <> short 'g' <> help "options to pass to GHC")) +hayooPageArg = option auto (long "page" <> metavar "n" <> short 'p' <> help "page number (0 by default)" <> value 0) +hayooPagesArg = option auto (long "pages" <> metavar "count" <> short 'n' <> help "pages count (1 by default)" <> value 1) +headerFlag = switch (long "header" <> short 'h' <> help "show only header of module") +holdFlag = switch (long "hold" <> short 'h' <> help "don't return any response") +inferFlag = switch (long "infer" <> help "infer types") +inspectionFlag = switch (long "inspection" <> short 'i' <> help "return inspection data") +lintOpts = many (strOption (long "lint" <> metavar "option" <> short 'l' <> help "options for hlint")) +localsFlag = switch (long "locals" <> short 'l' <> help "look in local declarations") +moduleArg = textOption (long "module" <> metavar "name" <> short 'm' <> help "module name") +packageArg = textOption (long "package" <> metavar "name" <> help "module package") +packageDbArg = + flag' GlobalDb (long "global-db" <> help "global package-db") <|> + flag' UserDb (long "user-db" <> help "per-user package-db") <|> + fmap PackageDb (textOption (long "package-db" <> metavar "path" <> help "custom package-db")) +pathArg f = textOption (long "path" <> metavar "path" <> short 'p' <> f) +projectArg = textOption (long "project" <> long "proj" <> metavar "project") +pureFlag = switch (long "pure" <> help "don't modify actual file, just return result") +sandboxArg = textOption (long "sandbox" <> metavar "path" <> help "path to cabal sandbox") +toolArg = + flag' CabalTool (long "cabal" <> help "use cabal as build tool") <|> + flag' StackTool (long "stack" <> help "use stack as build tool") <|> + toolArg' +toolArg' = option readTool (long "tool" <> help "specify build tool, `cabal` or `stack`") where + readTool :: ReadM BuildTool + readTool = do + s <- str @String + msum [ + guard (s == "cabal") >> return CabalTool, + guard (s == "stack") >> return StackTool, + readerError ("unknown build tool: {}" ~~ s)] + +wideFlag = switch (long "wide" <> short 'w' <> help "wide mode - complete as if there were no import lists") + +instance ToJSON Command where + toJSON Ping = cmdJson "ping" [] + toJSON (Listen lev) = cmdJson "listen" ["level" .= lev] + toJSON (SetLogLevel lev) = cmdJson "set-log" ["level" .= lev] + toJSON (Scan projs cabal sboxes fs ps btool ghcs docs' infer') = cmdJson "scan" [ + "projects" .= projs, + "cabal" .= cabal, + "sandboxes" .= sboxes, + "files" .= fs, + "paths" .= ps, + "build-tool" .= btool, + "ghc-opts" .= ghcs, + "docs" .= docs', + "infer" .= infer'] + toJSON (ScanProject proj tool deps) = cmdJson "scan project" [ + "project" .= proj, + "build-tool" .= tool, + "scan-deps" .= deps] + toJSON (ScanFile file' tool scanProj deps) = cmdJson "scan file" [ + "file" .= file', + "build-tool" .= tool, + "scan-project" .= scanProj, + "scan-deps" .= deps] + toJSON (ScanPackageDbs pdbs) = cmdJson "scan package-dbs" [ + "package-db-stack" .= pdbs] + toJSON (SetFileContents f cts) = cmdJson "set-file-contents" ["file" .= f, "contents" .= cts] + toJSON (RefineDocs projs fs) = cmdJson "docs" ["projects" .= projs, "files" .= fs] + toJSON (InferTypes projs fs) = cmdJson "infer" ["projects" .= projs, "files" .= fs] + toJSON (Remove projs cabal sboxes fs) = cmdJson "remove" ["projects" .= projs, "cabal" .= cabal, "sandboxes" .= sboxes, "files" .= fs] + toJSON RemoveAll = cmdJson "remove-all" [] + toJSON InfoPackages = cmdJson "packages" [] + toJSON InfoProjects = cmdJson "projects" [] + toJSON InfoSandboxes = cmdJson "sandboxes" [] + toJSON (InfoSymbol q tf h l) = cmdJson "symbol" ["query" .= q, "filters" .= tf, "header" .= h, "locals" .= l] + toJSON (InfoModule q tf h i) = cmdJson "module" ["query" .= q, "filters" .= tf, "header" .= h, "inspection" .= i] + toJSON (InfoProject p) = cmdJson "project" $ either (\pname -> ["name" .= pname]) (\ppath -> ["path" .= ppath]) p + toJSON (InfoSandbox p) = cmdJson "sandbox" ["path" .= p] + toJSON (Lookup n f) = cmdJson "lookup" ["name" .= n, "file" .= f] + toJSON (Whois n f) = cmdJson "whois" ["name" .= n, "file" .= f] + toJSON (Whoat l c f) = cmdJson "whoat" ["line" .= l, "column" .= c, "file" .= f] + toJSON (ResolveScopeModules q f) = cmdJson "scope modules" ["query" .= q, "file" .= f] + toJSON (ResolveScope q f) = cmdJson "scope" ["query" .= q, "file" .= f] + toJSON (FindUsages l c f) = cmdJson "usages" ["line" .= l, "column" .= c, "file" .= f] + toJSON (Complete q w f) = cmdJson "complete" ["prefix" .= q, "wide" .= w, "file" .= f] + toJSON (Hayoo q p ps) = cmdJson "hayoo" ["query" .= q, "page" .= p, "pages" .= ps] + toJSON (CabalList ps) = cmdJson "cabal list" ["packages" .= ps] + toJSON (UnresolvedSymbols fs) = cmdJson "unresolveds" ["files" .= fs] + toJSON (Lint fs lints) = cmdJson "lint" ["files" .= fs, "lint-opts" .= lints] + toJSON (Check fs ghcs c) = cmdJson "check" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c] + toJSON (CheckLint fs ghcs lints c) = cmdJson "check-lint" ["files" .= fs, "ghc-opts" .= ghcs, "lint-opts" .= lints, "clear" .= c] + toJSON (Types fs ghcs c) = cmdJson "types" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c] + toJSON (AutoFix ns) = cmdJson "autofixes" ["messages" .= ns] + toJSON (Refactor ns rests pure') = cmdJson "refactor" ["messages" .= ns, "rest" .= rests, "pure" .= pure'] + toJSON (Rename n n' f) = cmdJson "rename" ["name" .= n, "new-name" .= n', "file" .= f] + toJSON (GhcEval exprs f) = cmdJson "ghc eval" ["exprs" .= exprs, "file" .= f] + toJSON (GhcType exprs f) = cmdJson "ghc type" ["exprs" .= exprs, "file" .= f] + toJSON Langs = cmdJson "langs" [] + toJSON Flags = cmdJson "flags" [] + toJSON (Link h) = cmdJson "link" ["hold" .= h] + toJSON StopGhc = cmdJson "stop-ghc" [] + toJSON Exit = cmdJson "exit" [] + +instance FromJSON Command where + parseJSON = withObject "command" $ \v -> asum [ + guardCmd "ping" v *> pure Ping, + guardCmd "listen" v *> (Listen <$> v .::? "level"), + guardCmd "set-log" v *> (SetLogLevel <$> v .:: "level"), + guardCmd "scan" v *> (Scan <$> + v .::?! "projects" <*> + (v .:: "cabal" <|> pure False) <*> + v .::?! "sandboxes" <*> + v .::?! "files" <*> + v .::?! "paths" <*> + (v .:: "build-tool" <|> pure CabalTool) <*> + v .::?! "ghc-opts" <*> + (v .:: "docs" <|> pure False) <*> + (v .:: "infer" <|> pure False)), + guardCmd "scan project" v *> (ScanProject <$> + v .:: "project" <*> + v .:: "build-tool" <*> + (v .:: "scan-deps" <|> pure True)), + guardCmd "scan file" v *> (ScanFile <$> + v .:: "file" <*> + (v .:: "build-tool" <|> pure CabalTool) <*> + (v .:: "scan-project" <|> pure True) <*> + (v .:: "scan-deps" <|> pure True)), + guardCmd "scan package-dbs" v *> (ScanPackageDbs <$> v .:: "package-db-stack"), + guardCmd "set-file-contents" v *> (SetFileContents <$> v .:: "file" <*> v .:: "contents"), + guardCmd "docs" v *> (RefineDocs <$> v .::?! "projects" <*> v .::?! "files"), + guardCmd "infer" v *> (InferTypes <$> v .::?! "projects" <*> v .::?! "files"), + guardCmd "remove" v *> (Remove <$> + v .::?! "projects" <*> + (v .:: "cabal" <|> pure False) <*> + v .::?! "sandboxes" <*> + v .::?! "files"), + guardCmd "remove-all" v *> pure RemoveAll, + guardCmd "packages" v *> pure InfoPackages, + guardCmd "projects" v *> pure InfoProjects, + guardCmd "sandboxes" v *> pure InfoSandboxes, + guardCmd "symbol" v *> (InfoSymbol <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> (v .:: "locals" <|> pure False)), + guardCmd "module" v *> (InfoModule <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> v .:: "inspection"), + guardCmd "project" v *> (InfoProject <$> asum [Left <$> v .:: "name", Right <$> v .:: "path"]), + guardCmd "sandbox" v *> (InfoSandbox <$> v .:: "path"), + guardCmd "lookup" v *> (Lookup <$> v .:: "name" <*> v .:: "file"), + guardCmd "whois" v *> (Whois <$> v .:: "name" <*> v .:: "file"), + guardCmd "whoat" v *> (Whoat <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"), + guardCmd "scope modules" v *> (ResolveScopeModules <$> v .:: "query" <*> v .:: "file"), + guardCmd "scope" v *> (ResolveScope <$> v .:: "query" <*> v .:: "file"), + guardCmd "usages" v *> (FindUsages <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"), + guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> (v .:: "wide" <|> pure False) <*> v .:: "file"), + guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> (v .:: "page" <|> pure 0) <*> (v .:: "pages" <|> pure 1)), + guardCmd "cabal list" v *> (CabalList <$> v .::?! "packages"), + guardCmd "unresolveds" v *> (UnresolvedSymbols <$> v .::?! "files"), + guardCmd "lint" v *> (Lint <$> v .::?! "files" <*> v .::?! "lint-opts"), + guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)), + guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> v .::?! "lint-opts" <*> (v .:: "clear" <|> pure False)), + guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)), + guardCmd "autofixes" v *> (AutoFix <$> v .:: "messages"), + guardCmd "refactor" v *> (Refactor <$> v .:: "messages" <*> v .::?! "rest" <*> (v .:: "pure" <|> pure True)), + guardCmd "rename" v *> (Rename <$> v .:: "name" <*> v .:: "new-name" <*> v .:: "file"), + guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs" <*> v .::? "file"), + guardCmd "ghc type" v *> (GhcType <$> v .::?! "exprs" <*> v .::? "file"), + guardCmd "langs" v *> pure Langs, + guardCmd "flags" v *> pure Flags, + guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)), + guardCmd "stop-ghc" v *> pure StopGhc, + guardCmd "exit" v *> pure Exit] + +instance ToJSON FileSource where + toJSON (FileSource fpath mcts) = object ["file" .= fpath, "contents" .= mcts] + +instance FromJSON FileSource where + parseJSON = withObject "file-contents" $ \v -> FileSource <$> v .:: "file" <*> v .::? "contents" + +instance ToJSON TargetFilter where + toJSON (TargetProject pname) = object ["project" .= pname] + toJSON (TargetFile fpath) = object ["file" .= fpath] + toJSON (TargetModule mname) = object ["module" .= mname] + toJSON (TargetPackage pkg) = object ["package" .= pkg] + toJSON TargetInstalled = toJSON ("installed" :: String) + toJSON TargetSourced = toJSON ("sourced" :: String) + toJSON TargetStandalone = toJSON ("standalone" :: String) + +instance FromJSON TargetFilter where + parseJSON j = obj j <|> str' where + obj = withObject "target-filter" $ \v -> asum [ + TargetProject <$> v .:: "project", + TargetFile <$> v .:: "file", + TargetModule <$> v .:: "module", + TargetPackage <$> v .:: "package"] + str' = do + s <- parseJSON j :: A.Parser String + case s of + "installed" -> return TargetInstalled + "sourced" -> return TargetSourced + "standalone" -> return TargetStandalone + _ -> empty + +instance ToJSON SearchQuery where + toJSON (SearchQuery q st) = object ["input" .= q, "type" .= st] + +instance FromJSON SearchQuery where + parseJSON = withObject "search-query" $ \v -> SearchQuery <$> (v .:: "input" <|> pure "") <*> (v .:: "type" <|> pure SearchPrefix) + +instance ToJSON SearchType where + toJSON SearchExact = toJSON ("exact" :: String) + toJSON SearchPrefix = toJSON ("prefix" :: String) + toJSON SearchInfix = toJSON ("infix" :: String) + toJSON SearchSuffix = toJSON ("suffix" :: String) + +instance FromJSON SearchType where + parseJSON v = do + str' <- parseJSON v :: A.Parser String + case str' of + "exact" -> return SearchExact + "prefix" -> return SearchPrefix + "infix" -> return SearchInfix + "suffix" -> return SearchInfix + _ -> empty diff --git a/src/HsDev/Stack.hs b/src/HsDev/Stack.hs --- a/src/HsDev/Stack.hs +++ b/src/HsDev/Stack.hs @@ -1,136 +1,136 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes #-} - -module HsDev.Stack ( - stack, yaml, - path, pathOf, - build, buildDeps, - StackEnv(..), stackRoot, stackProject, stackConfig, stackGhc, stackSnapshot, stackLocal, - getStackEnv, projectEnv, - stackPackageDbStack, - - stackCompiler, stackArch, - - MaybeT(..) - ) where - -import Control.Arrow -import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.)) -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.IO.Class -import Data.Char -import Data.Maybe -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Distribution.Compiler -import Distribution.System -import qualified Distribution.Text as T (display) -import System.Directory -import System.Environment -import System.FilePath -import qualified System.Log.Simple as Log -import Text.Format (formats, (~%)) - -import qualified GHC -import qualified Packages as GHC - -import HsDev.Error -import HsDev.PackageDb -import HsDev.Tools.Ghc.Worker (GhcM, tmpSession) -import qualified HsDev.Tools.Ghc.Compat as Compat -import HsDev.Util as Util -import HsDev.Tools.Base (runTool_) -import qualified System.Directory.Paths as P - --- | Get compiler version -stackCompiler :: GhcM String -stackCompiler = do - tmpSession globalDb ["-no-user-package-db"] - df <- GHC.getSessionDynFlags - let - res = - map (GHC.packageNameString &&& GHC.packageVersion) . - fromMaybe [] . - Compat.pkgDatabase $ df - compiler = T.display buildCompilerFlavor - CompilerId _ version' = buildCompilerId - ver = maybe (T.display version') T.display $ lookup compiler res - return $ compiler ++ "-" ++ ver - --- | Get arch for stack -stackArch :: String -stackArch = T.display buildArch - --- | Invoke stack command, we are trying to get actual stack near current hsdev executable -stack :: [String] -> GhcM String -stack cmd' = hsdevLiftIO $ do - curExe <- liftIO getExecutablePath - stackExe <- Util.withCurrentDirectory (takeDirectory curExe) $ - liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return - comp <- stackCompiler - let - args' = ["--compiler", comp, "--arch", stackArch] ++ cmd' - Log.sendLog Log.Trace $ formats "invoking stack: {exe} {args}" [ - "exe" ~% stackExe, - "args" ~% unwords args'] - liftIO $ runTool_ stackExe args' - --- | Make yaml opts -yaml :: Maybe FilePath -> [String] -yaml Nothing = [] -yaml (Just y) = ["--stack-yaml", y] - -type PathsConf = Map String FilePath - --- | Stack path -path :: Maybe FilePath -> GhcM PathsConf -path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where - breakPath :: String -> (String, FilePath) - breakPath = second (dropWhile isSpace . drop 1) . break (== ':') - --- | Get path for -pathOf :: String -> Lens' PathsConf (Maybe FilePath) -pathOf = at - --- | Build stack project -build :: [String] -> Maybe FilePath -> GhcM () -build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg) - --- | Build only dependencies -buildDeps :: Maybe FilePath -> GhcM () -buildDeps = build ["--only-dependencies"] - -data StackEnv = StackEnv { - _stackRoot :: FilePath, - _stackProject :: FilePath, - _stackConfig :: FilePath, - _stackGhc :: FilePath, - _stackSnapshot :: FilePath, - _stackLocal :: FilePath } - -makeLenses ''StackEnv - -getStackEnv :: PathsConf -> Maybe StackEnv -getStackEnv p = StackEnv <$> - (p ^. pathOf "stack-root") <*> - (p ^. pathOf "project-root") <*> - (p ^. pathOf "config-location") <*> - (p ^. pathOf "ghc-paths") <*> - (p ^. pathOf "snapshot-pkg-db") <*> - (p ^. pathOf "local-pkg-db") - --- | Projects paths -projectEnv :: FilePath -> GhcM StackEnv -projectEnv p = hsdevLiftIO $ Util.withCurrentDirectory p $ do - paths' <- path Nothing - maybe (hsdevError $ ToolError "stack" ("can't get paths for " ++ p)) return $ getStackEnv paths' - --- | Get package-db stack for stack environment -stackPackageDbStack :: Lens' StackEnv PackageDbStack -stackPackageDbStack = lens g s where - g :: StackEnv -> PackageDbStack - g env' = PackageDbStack $ map (PackageDb . P.fromFilePath) [_stackLocal env', _stackSnapshot env'] - s :: StackEnv -> PackageDbStack -> StackEnv - s env' pdbs = env' { - _stackSnapshot = fromMaybe (_stackSnapshot env') $ pdbs ^? packageDbStack . ix 1 . packageDb . P.path, - _stackLocal = fromMaybe (_stackLocal env') $ pdbs ^? packageDbStack . ix 0 . packageDb . P.path } +{-# LANGUAGE TemplateHaskell, RankNTypes #-} + +module HsDev.Stack ( + stack, yaml, + path, pathOf, + build, buildDeps, + StackEnv(..), stackRoot, stackProject, stackConfig, stackGhc, stackSnapshot, stackLocal, + getStackEnv, projectEnv, + stackPackageDbStack, + + stackCompiler, stackArch, + + MaybeT(..) + ) where + +import Control.Arrow +import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.)) +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Data.Char +import Data.Maybe +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Distribution.Compiler +import Distribution.System +import qualified Distribution.Text as T (display) +import System.Directory +import System.Environment +import System.FilePath +import qualified System.Log.Simple as Log +import Text.Format (formats, (~%)) + +import qualified GHC +import qualified Packages as GHC + +import HsDev.Error +import HsDev.PackageDb +import HsDev.Tools.Ghc.Worker (GhcM, tmpSession) +import qualified HsDev.Tools.Ghc.Compat as Compat +import HsDev.Util as Util +import HsDev.Tools.Base (runTool_) +import qualified System.Directory.Paths as P + +-- | Get compiler version +stackCompiler :: GhcM String +stackCompiler = do + tmpSession globalDb ["-no-user-package-db"] + df <- GHC.getSessionDynFlags + let + res = + map (GHC.packageNameString &&& GHC.packageVersion) . + fromMaybe [] . + Compat.pkgDatabase $ df + compiler = T.display buildCompilerFlavor + CompilerId _ version' = buildCompilerId + ver = maybe (T.display version') T.display $ lookup compiler res + return $ compiler ++ "-" ++ ver + +-- | Get arch for stack +stackArch :: String +stackArch = T.display buildArch + +-- | Invoke stack command, we are trying to get actual stack near current hsdev executable +stack :: [String] -> GhcM String +stack cmd' = hsdevLiftIO $ do + curExe <- liftIO getExecutablePath + stackExe <- Util.withCurrentDirectory (takeDirectory curExe) $ + liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return + comp <- stackCompiler + let + args' = ["--compiler", comp, "--arch", stackArch] ++ cmd' + Log.sendLog Log.Trace $ formats "invoking stack: {exe} {args}" [ + "exe" ~% stackExe, + "args" ~% unwords args'] + liftIO $ runTool_ stackExe args' + +-- | Make yaml opts +yaml :: Maybe FilePath -> [String] +yaml Nothing = [] +yaml (Just y) = ["--stack-yaml", y] + +type PathsConf = Map String FilePath + +-- | Stack path +path :: Maybe FilePath -> GhcM PathsConf +path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where + breakPath :: String -> (String, FilePath) + breakPath = second (dropWhile isSpace . drop 1) . break (== ':') + +-- | Get path for +pathOf :: String -> Lens' PathsConf (Maybe FilePath) +pathOf = at + +-- | Build stack project +build :: [String] -> Maybe FilePath -> GhcM () +build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg) + +-- | Build only dependencies +buildDeps :: Maybe FilePath -> GhcM () +buildDeps = build ["--only-dependencies"] + +data StackEnv = StackEnv { + _stackRoot :: FilePath, + _stackProject :: FilePath, + _stackConfig :: FilePath, + _stackGhc :: FilePath, + _stackSnapshot :: FilePath, + _stackLocal :: FilePath } + +makeLenses ''StackEnv + +getStackEnv :: PathsConf -> Maybe StackEnv +getStackEnv p = StackEnv <$> + (p ^. pathOf "stack-root") <*> + (p ^. pathOf "project-root") <*> + (p ^. pathOf "config-location") <*> + (p ^. pathOf "ghc-paths") <*> + (p ^. pathOf "snapshot-pkg-db") <*> + (p ^. pathOf "local-pkg-db") + +-- | Projects paths +projectEnv :: FilePath -> GhcM StackEnv +projectEnv p = hsdevLiftIO $ Util.withCurrentDirectory p $ do + paths' <- path Nothing + maybe (hsdevError $ ToolError "stack" ("can't get paths for " ++ p)) return $ getStackEnv paths' + +-- | Get package-db stack for stack environment +stackPackageDbStack :: Lens' StackEnv PackageDbStack +stackPackageDbStack = lens g s where + g :: StackEnv -> PackageDbStack + g env' = PackageDbStack $ map (PackageDb . P.fromFilePath) [_stackLocal env', _stackSnapshot env'] + s :: StackEnv -> PackageDbStack -> StackEnv + s env' pdbs = env' { + _stackSnapshot = fromMaybe (_stackSnapshot env') $ pdbs ^? packageDbStack . ix 1 . packageDb . P.path, + _stackLocal = fromMaybe (_stackLocal env') $ pdbs ^? packageDbStack . ix 0 . packageDb . P.path } diff --git a/src/HsDev/Symbols.hs b/src/HsDev/Symbols.hs --- a/src/HsDev/Symbols.hs +++ b/src/HsDev/Symbols.hs @@ -1,137 +1,137 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Symbols ( - -- * Utility - locateProject, searchProject, - locateSourceDir, - standaloneInfo, - moduleOpts, projectTargetOpts, - - -- * Tags - setTag, hasTag, removeTag, dropTags, - inspectTag, inspectUntag, - - -- * Reexportss - module HsDev.Symbols.Types, - module HsDev.Symbols.Class, - module HsDev.Symbols.Documented, - module HsDev.Symbols.HaskellNames - ) where - -import Control.Applicative -import Control.Lens -import Control.Monad.Trans.Maybe -import Control.Monad.Except -import Control.Monad.State -import Data.List -import Data.Maybe (fromMaybe, listToMaybe, catMaybes) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import System.Directory -import System.FilePath - -import HsDev.Symbols.Types -import HsDev.Symbols.Class -import HsDev.Symbols.Documented (Documented(..)) -import HsDev.Symbols.HaskellNames -import HsDev.Util (searchPath, uniqueBy, directoryContents) -import System.Directory.Paths - --- | Find project file is related to -locateProject :: FilePath -> IO (Maybe Project) -locateProject file = do - file' <- canonicalizePath file - isDir <- doesDirectoryExist file' - if isDir then locateHere file' else locateParent (takeDirectory file') - where - locateHere p = do - cts <- filter (not . null . takeBaseName) <$> directoryContents p - return $ fmap (project . (p )) $ find ((== ".cabal") . takeExtension) cts - locateParent dir = do - cts <- filter (not . null . takeBaseName) <$> directoryContents dir - case find ((== ".cabal") . takeExtension) cts of - Nothing -> if isDrive dir then return Nothing else locateParent (takeDirectory dir) - Just cabalf -> return $ Just $ project (dir cabalf) - --- | Search project up -searchProject :: FilePath -> IO (Maybe Project) -searchProject file = runMaybeT $ searchPath file (MaybeT . locateProject) <|> mzero - --- | Locate source dir of file -locateSourceDir :: FilePath -> IO (Maybe (Extensions Path)) -locateSourceDir f = runMaybeT $ do - file <- liftIO $ canonicalizePath f - p <- MaybeT $ locateProject file - proj <- lift $ loadProject p - MaybeT $ return $ findSourceDir proj (fromFilePath file) - --- | Make `Info` for standalone `Module` -standaloneInfo :: [PackageConfig] -> Module -> Info -standaloneInfo pkgs m = mempty { _infoDepends = pkgDeps ^.. each . package . packageName } where - pkgDeps = catMaybes [M.lookup mdep pkgMap >>= listToMaybe | mdep <- "Prelude" : imps] - pkgMap = M.unionsWith mergePkgs [M.singleton m' [p] | p <- pkgs, m' <- view packageModules p] - mergePkgs ls rs = if null es then hs else es where - (es, hs) = partition (view packageExposed) $ uniqueBy (view package) (ls ++ rs) - imps = delete (view (moduleId . moduleName) m) (m ^.. moduleImports . each . importName) - --- | Options for GHC of module and project -moduleOpts :: [PackageConfig] -> Module -> [String] -moduleOpts pkgs m = case view (moduleId . moduleLocation) m of - FileModule file proj -> concat [ - hidePackages, - targetOpts absInfo] - where - infos' = maybe [standaloneInfo pkgs m] (`fileTargets` file) proj - info' = over infoDepends (filter validDep) (mconcat $ selfInfo : infos') - absInfo = maybe id (absolutise . view projectPath) proj info' - selfInfo - | proj ^? _Just . projectName `elem` map Just (infos' ^.. each . infoDepends . each) = fromMaybe mempty $ - proj ^? _Just . projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo - | otherwise = mempty - -- filter out unavailable packages such as unix under windows - validDep d = d `elem` pkgs' - pkgs' = pkgs ^.. each . package . packageName - hidePackages - | null (info' ^. infoDepends) = [] - | otherwise = ["-hide-all-packages"] - _ -> [] - --- | Options for GHC of project -projectTargetOpts :: [PackageConfig] -> Project -> Info -> [String] -projectTargetOpts pkgs proj info = concat [hidePackages, targetOpts absInfo] where - info' = over infoDepends (filter validDep) (selfInfo `mappend` info) - absInfo = absolutise (view projectPath proj) info' - selfInfo - | proj ^. projectName `elem` (info ^.. infoDepends . each) = fromMaybe mempty $ - proj ^? projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo - | otherwise = mempty - validDep d = d `elem` pkgs' - pkgs' = pkgs ^.. each . package . packageName - hidePackages - | null (info' ^. infoDepends) = [] - | otherwise = ["-hide-all-packages"] - --- | Set tag to `Inspected` -setTag :: Ord t => t -> Inspected i t a -> Inspected i t a -setTag tag' = over inspectionTags (S.insert tag') - --- | Check whether `Inspected` has tag -hasTag :: Ord t => t -> Inspected i t a -> Bool -hasTag tag' = has (inspectionTags . ix tag') - --- | Drop tag from `Inspected` -removeTag :: Ord t => t -> Inspected i t a -> Inspected i t a -removeTag tag' = over inspectionTags (S.delete tag') - --- | Drop all tags -dropTags :: Inspected i t a -> Inspected i t a -dropTags = set inspectionTags S.empty - --- | Set inspection tag -inspectTag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a -inspectTag tag' act = act <* modify (over _2 (S.insert tag')) - --- | Unser inspection tag -inspectUntag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a -inspectUntag tag' act = act <* modify (over _2 (S.delete tag')) +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Symbols ( + -- * Utility + locateProject, searchProject, + locateSourceDir, + standaloneInfo, + moduleOpts, projectTargetOpts, + + -- * Tags + setTag, hasTag, removeTag, dropTags, + inspectTag, inspectUntag, + + -- * Reexportss + module HsDev.Symbols.Types, + module HsDev.Symbols.Class, + module HsDev.Symbols.Documented, + module HsDev.Symbols.HaskellNames + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Control.Monad.State +import Data.List +import Data.Maybe (fromMaybe, listToMaybe, catMaybes) +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import System.Directory +import System.FilePath + +import HsDev.Symbols.Types +import HsDev.Symbols.Class +import HsDev.Symbols.Documented (Documented(..)) +import HsDev.Symbols.HaskellNames +import HsDev.Util (searchPath, uniqueBy, directoryContents) +import System.Directory.Paths + +-- | Find project file is related to +locateProject :: FilePath -> IO (Maybe Project) +locateProject file = do + file' <- canonicalizePath file + isDir <- doesDirectoryExist file' + if isDir then locateHere file' else locateParent (takeDirectory file') + where + locateHere p = do + cts <- filter (not . null . takeBaseName) <$> directoryContents p + return $ fmap (project . (p )) $ find ((== ".cabal") . takeExtension) cts + locateParent dir = do + cts <- filter (not . null . takeBaseName) <$> directoryContents dir + case find ((== ".cabal") . takeExtension) cts of + Nothing -> if isDrive dir then return Nothing else locateParent (takeDirectory dir) + Just cabalf -> return $ Just $ project (dir cabalf) + +-- | Search project up +searchProject :: FilePath -> IO (Maybe Project) +searchProject file = runMaybeT $ searchPath file (MaybeT . locateProject) <|> mzero + +-- | Locate source dir of file +locateSourceDir :: FilePath -> IO (Maybe (Extensions Path)) +locateSourceDir f = runMaybeT $ do + file <- liftIO $ canonicalizePath f + p <- MaybeT $ locateProject file + proj <- lift $ loadProject p + MaybeT $ return $ findSourceDir proj (fromFilePath file) + +-- | Make `Info` for standalone `Module` +standaloneInfo :: [PackageConfig] -> Module -> Info +standaloneInfo pkgs m = mempty { _infoDepends = pkgDeps ^.. each . package . packageName } where + pkgDeps = catMaybes [M.lookup mdep pkgMap >>= listToMaybe | mdep <- "Prelude" : imps] + pkgMap = M.unionsWith mergePkgs [M.singleton m' [p] | p <- pkgs, m' <- view packageModules p] + mergePkgs ls rs = if null es then hs else es where + (es, hs) = partition (view packageExposed) $ uniqueBy (view package) (ls ++ rs) + imps = delete (view (moduleId . moduleName) m) (m ^.. moduleImports . each . importName) + +-- | Options for GHC of module and project +moduleOpts :: [PackageConfig] -> Module -> [String] +moduleOpts pkgs m = case view (moduleId . moduleLocation) m of + FileModule file proj -> concat [ + hidePackages, + targetOpts absInfo] + where + infos' = maybe [standaloneInfo pkgs m] (`fileTargets` file) proj + info' = over infoDepends (filter validDep) (mconcat $ selfInfo : infos') + absInfo = maybe id (absolutise . view projectPath) proj info' + selfInfo + | proj ^? _Just . projectName `elem` map Just (infos' ^.. each . infoDepends . each) = fromMaybe mempty $ + proj ^? _Just . projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo + | otherwise = mempty + -- filter out unavailable packages such as unix under windows + validDep d = d `elem` pkgs' + pkgs' = pkgs ^.. each . package . packageName + hidePackages + | null (info' ^. infoDepends) = [] + | otherwise = ["-hide-all-packages"] + _ -> [] + +-- | Options for GHC of project +projectTargetOpts :: [PackageConfig] -> Project -> Info -> [String] +projectTargetOpts pkgs proj info = concat [hidePackages, targetOpts absInfo] where + info' = over infoDepends (filter validDep) (selfInfo `mappend` info) + absInfo = absolutise (view projectPath proj) info' + selfInfo + | proj ^. projectName `elem` (info ^.. infoDepends . each) = fromMaybe mempty $ + proj ^? projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo + | otherwise = mempty + validDep d = d `elem` pkgs' + pkgs' = pkgs ^.. each . package . packageName + hidePackages + | null (info' ^. infoDepends) = [] + | otherwise = ["-hide-all-packages"] + +-- | Set tag to `Inspected` +setTag :: Ord t => t -> Inspected i t a -> Inspected i t a +setTag tag' = over inspectionTags (S.insert tag') + +-- | Check whether `Inspected` has tag +hasTag :: Ord t => t -> Inspected i t a -> Bool +hasTag tag' = has (inspectionTags . ix tag') + +-- | Drop tag from `Inspected` +removeTag :: Ord t => t -> Inspected i t a -> Inspected i t a +removeTag tag' = over inspectionTags (S.delete tag') + +-- | Drop all tags +dropTags :: Inspected i t a -> Inspected i t a +dropTags = set inspectionTags S.empty + +-- | Set inspection tag +inspectTag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a +inspectTag tag' act = act <* modify (over _2 (S.insert tag')) + +-- | Unser inspection tag +inspectUntag :: (Monad m, Ord t) => t -> InspectM k t m a -> InspectM k t m a +inspectUntag tag' act = act <* modify (over _2 (S.delete tag')) diff --git a/src/HsDev/Symbols/Class.hs b/src/HsDev/Symbols/Class.hs --- a/src/HsDev/Symbols/Class.hs +++ b/src/HsDev/Symbols/Class.hs @@ -1,30 +1,30 @@ -module HsDev.Symbols.Class ( - Sourced(..), - sourcedModuleName, - - module HsDev.Symbols.Location - ) where - -import Control.Lens (Lens', Traversal') -import Data.Text (Text) - -import HsDev.Symbols.Location - -class Sourced a where - sourcedName :: Lens' a Text - sourcedDocs :: Traversal' a Text - sourcedModule :: Lens' a ModuleId - sourcedLocation :: Traversal' a Position - sourcedDocs _ = pure - sourcedLocation _ = pure - -instance Sourced ModuleId where - sourcedName = moduleName - sourcedModule = id - -instance Sourced SymbolId where - sourcedName = symbolName - sourcedModule = symbolModule - -sourcedModuleName :: Sourced a => Lens' a Text -sourcedModuleName = sourcedModule . sourcedName +module HsDev.Symbols.Class ( + Sourced(..), + sourcedModuleName, + + module HsDev.Symbols.Location + ) where + +import Control.Lens (Lens', Traversal') +import Data.Text (Text) + +import HsDev.Symbols.Location + +class Sourced a where + sourcedName :: Lens' a Text + sourcedDocs :: Traversal' a Text + sourcedModule :: Lens' a ModuleId + sourcedLocation :: Traversal' a Position + sourcedDocs _ = pure + sourcedLocation _ = pure + +instance Sourced ModuleId where + sourcedName = moduleName + sourcedModule = id + +instance Sourced SymbolId where + sourcedName = symbolName + sourcedModule = symbolModule + +sourcedModuleName :: Sourced a => Lens' a Text +sourcedModuleName = sourcedModule . sourcedName diff --git a/src/HsDev/Symbols/Documented.hs b/src/HsDev/Symbols/Documented.hs --- a/src/HsDev/Symbols/Documented.hs +++ b/src/HsDev/Symbols/Documented.hs @@ -1,62 +1,62 @@ -{-# LANGUAGE DefaultSignatures, OverloadedStrings #-} - -module HsDev.Symbols.Documented ( - Documented(..), - defaultDetailed - ) where - -import Control.Lens (view, (^..), (^?)) -import Data.Maybe (maybeToList) -import Data.Text (Text, pack) -import qualified Data.Text as T - -import Text.Format -import HsDev.Symbols.Class -import HsDev.Project.Types - --- | Documented symbol -class Documented a where - brief :: a -> Text - detailed :: a -> Text - default detailed :: Sourced a => a -> Text - detailed = T.unlines . defaultDetailed - --- | Default detailed docs -defaultDetailed :: (Sourced a, Documented a) => a -> [Text] -defaultDetailed s = concat [header, docs, loc] where - header = [brief s, ""] - docs = s ^.. sourcedDocs - loc = maybe [] (\l -> ["Defined at " `T.append` pack (show l)]) (s ^? sourcedLocation) - -instance Documented ModulePackage where - brief = pack . show - detailed = brief - -instance Documented ModuleLocation where - brief (FileModule f _) = f - brief (InstalledModule _ pkg n _) = format "{} from {}" ~~ n ~~ brief pkg - brief (OtherLocation src) = src - brief NoLocation = "" - detailed (FileModule f mproj) = case mproj of - Nothing -> f - Just proj -> format "{} in project {}" ~~ f ~~ brief proj - detailed (InstalledModule pdb pkg n _) = format "{} from {} ({})" ~~ n ~~ brief pkg ~~ show pdb - detailed l = brief l - -instance Documented Project where - brief p = format "{} ({})" ~~ view projectName p ~~ view projectPath p - detailed p = T.unlines (brief p : desc) where - desc = concat [ - do - d <- mdescr - _ <- maybeToList $ view projectLibrary d - return "\tlibrary", - do - d <- mdescr - exe <- view projectExecutables d - return $ format "\texecutable: {}" ~~ view executableName exe, - do - d <- mdescr - test <- view projectTests d - return $ format "\ttest: {}" ~~ view testName test] - mdescr = maybeToList $ view projectDescription p +{-# LANGUAGE DefaultSignatures, OverloadedStrings #-} + +module HsDev.Symbols.Documented ( + Documented(..), + defaultDetailed + ) where + +import Control.Lens (view, (^..), (^?)) +import Data.Maybe (maybeToList) +import Data.Text (Text, pack) +import qualified Data.Text as T + +import Text.Format +import HsDev.Symbols.Class +import HsDev.Project.Types + +-- | Documented symbol +class Documented a where + brief :: a -> Text + detailed :: a -> Text + default detailed :: Sourced a => a -> Text + detailed = T.unlines . defaultDetailed + +-- | Default detailed docs +defaultDetailed :: (Sourced a, Documented a) => a -> [Text] +defaultDetailed s = concat [header, docs, loc] where + header = [brief s, ""] + docs = s ^.. sourcedDocs + loc = maybe [] (\l -> ["Defined at " `T.append` pack (show l)]) (s ^? sourcedLocation) + +instance Documented ModulePackage where + brief = pack . show + detailed = brief + +instance Documented ModuleLocation where + brief (FileModule f _) = f + brief (InstalledModule _ pkg n _) = format "{} from {}" ~~ n ~~ brief pkg + brief (OtherLocation src) = src + brief NoLocation = "" + detailed (FileModule f mproj) = case mproj of + Nothing -> f + Just proj -> format "{} in project {}" ~~ f ~~ brief proj + detailed (InstalledModule pdb pkg n _) = format "{} from {} ({})" ~~ n ~~ brief pkg ~~ show pdb + detailed l = brief l + +instance Documented Project where + brief p = format "{} ({})" ~~ view projectName p ~~ view projectPath p + detailed p = T.unlines (brief p : desc) where + desc = concat [ + do + d <- mdescr + _ <- maybeToList $ view projectLibrary d + return "\tlibrary", + do + d <- mdescr + exe <- view projectExecutables d + return $ format "\texecutable: {}" ~~ view executableName exe, + do + d <- mdescr + test <- view projectTests d + return $ format "\ttest: {}" ~~ view testName test] + mdescr = maybeToList $ view projectDescription p diff --git a/src/HsDev/Symbols/HaskellNames.hs b/src/HsDev/Symbols/HaskellNames.hs --- a/src/HsDev/Symbols/HaskellNames.hs +++ b/src/HsDev/Symbols/HaskellNames.hs @@ -1,61 +1,61 @@ -{-# LANGUAGE FlexibleInstances #-} - -module HsDev.Symbols.HaskellNames ( - ToEnvironment(..), - fromSymbol, toSymbol - ) where - -import Control.Lens (view) -import Data.String -import qualified Data.Map.Strict as M -import qualified Data.Text as T (unpack) -import qualified Language.Haskell.Exts as H -import qualified Language.Haskell.Names as N - -import HsDev.Symbols.Types - -class ToEnvironment a where - environment :: a -> N.Environment - -instance ToEnvironment Module where - environment m = M.singleton (H.ModuleName () (T.unpack $ view sourcedName m)) (map toSymbol $ view moduleExports m) - -instance ToEnvironment [Module] where - environment = M.unions . map environment - -fromSymbol :: N.Symbol -> Symbol -fromSymbol s = Symbol sid Nothing Nothing info where - sid = SymbolId (fromName_ $ N.symbolName s) mid - mid = case N.symbolModule s of - H.ModuleName _ m -> ModuleId (fromString m) NoLocation - info = case s of - N.Value _ _ -> Function mempty - N.Method _ _ p -> Method mempty (fromName_ p) - N.Selector _ _ p cs -> Selector mempty (fromName_ p) (map fromName_ cs) - N.Constructor _ _ p -> Constructor mempty (fromName_ p) - N.Type _ _ -> Type mempty mempty - N.NewType _ _ -> NewType mempty mempty - N.Data _ _ -> Data mempty mempty - N.Class _ _ -> Class mempty mempty - N.TypeFam _ _ a -> TypeFam mempty mempty (fmap fromName_ a) - N.DataFam _ _ a -> DataFam mempty mempty (fmap fromName_ a) - N.PatternConstructor _ _ p -> PatConstructor mempty (fmap fromName_ p) - N.PatternSelector _ _ p c -> PatSelector mempty (fmap fromName_ p) (fromName_ c) - -toSymbol :: Symbol -> N.Symbol -toSymbol s = case view symbolInfo s of - Function _ -> N.Value m n - Method _ p -> N.Method m n (toName_ p) - Selector _ p cs -> N.Selector m n (toName_ p) (map toName_ cs) - Constructor _ p -> N.Constructor m n (toName_ p) - Type _ _ -> N.Type m n - NewType _ _ -> N.NewType m n - Data _ _ -> N.Data m n - Class _ _ -> N.Class m n - TypeFam _ _ a -> N.TypeFam m n (fmap toName_ a) - DataFam _ _ a -> N.DataFam m n (fmap toName_ a) - PatConstructor _ p -> N.PatternConstructor m n (fmap toName_ p) - PatSelector _ p c -> N.PatternSelector m n (fmap toName_ p) (toName_ c) - where - m = toModuleName_ $ view sourcedModuleName s - n = toName_ $ view sourcedName s +{-# LANGUAGE FlexibleInstances #-} + +module HsDev.Symbols.HaskellNames ( + ToEnvironment(..), + fromSymbol, toSymbol + ) where + +import Control.Lens (view) +import Data.String +import qualified Data.Map.Strict as M +import qualified Data.Text as T (unpack) +import qualified Language.Haskell.Exts as H +import qualified Language.Haskell.Names as N + +import HsDev.Symbols.Types + +class ToEnvironment a where + environment :: a -> N.Environment + +instance ToEnvironment Module where + environment m = M.singleton (H.ModuleName () (T.unpack $ view sourcedName m)) (map toSymbol $ view moduleExports m) + +instance ToEnvironment [Module] where + environment = M.unions . map environment + +fromSymbol :: N.Symbol -> Symbol +fromSymbol s = Symbol sid Nothing Nothing info where + sid = SymbolId (fromName_ $ N.symbolName s) mid + mid = case N.symbolModule s of + H.ModuleName _ m -> ModuleId (fromString m) NoLocation + info = case s of + N.Value _ _ -> Function mempty + N.Method _ _ p -> Method mempty (fromName_ p) + N.Selector _ _ p cs -> Selector mempty (fromName_ p) (map fromName_ cs) + N.Constructor _ _ p -> Constructor mempty (fromName_ p) + N.Type _ _ -> Type mempty mempty + N.NewType _ _ -> NewType mempty mempty + N.Data _ _ -> Data mempty mempty + N.Class _ _ -> Class mempty mempty + N.TypeFam _ _ a -> TypeFam mempty mempty (fmap fromName_ a) + N.DataFam _ _ a -> DataFam mempty mempty (fmap fromName_ a) + N.PatternConstructor _ _ p -> PatConstructor mempty (fmap fromName_ p) + N.PatternSelector _ _ p c -> PatSelector mempty (fmap fromName_ p) (fromName_ c) + +toSymbol :: Symbol -> N.Symbol +toSymbol s = case view symbolInfo s of + Function _ -> N.Value m n + Method _ p -> N.Method m n (toName_ p) + Selector _ p cs -> N.Selector m n (toName_ p) (map toName_ cs) + Constructor _ p -> N.Constructor m n (toName_ p) + Type _ _ -> N.Type m n + NewType _ _ -> N.NewType m n + Data _ _ -> N.Data m n + Class _ _ -> N.Class m n + TypeFam _ _ a -> N.TypeFam m n (fmap toName_ a) + DataFam _ _ a -> N.DataFam m n (fmap toName_ a) + PatConstructor _ p -> N.PatternConstructor m n (fmap toName_ p) + PatSelector _ p c -> N.PatternSelector m n (fmap toName_ p) (toName_ c) + where + m = toModuleName_ $ view sourcedModuleName s + n = toName_ $ view sourcedName s diff --git a/src/HsDev/Symbols/Location.hs b/src/HsDev/Symbols/Location.hs --- a/src/HsDev/Symbols/Location.hs +++ b/src/HsDev/Symbols/Location.hs @@ -1,367 +1,367 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} - -module HsDev.Symbols.Location ( - ModulePackage(..), mkPackage, PackageConfig(..), - ModuleLocation(..), locationId, noLocation, - ModuleId(..), moduleName, moduleLocation, - SymbolId(..), symbolName, symbolModule, - Position(..), Region(..), region, regionAt, regionLines, regionStr, - Location(..), - - packageName, packageVersion, - package, packageModules, packageExposed, - moduleFile, moduleProject, moduleInstallDirs, modulePackage, installedModuleName, installedModuleExposed, otherLocationName, - positionLine, positionColumn, - regionFrom, regionTo, - locationModule, locationPosition, - - sourceModuleRoot, - importPath, - sourceRoot, sourceRoot_, - RecalcTabs(..), - - module HsDev.PackageDb.Types - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(..)) -import Control.Lens (makeLenses, view, preview, over) -import Data.Aeson -import Data.Char (isSpace, isDigit) -import Data.List (findIndex) -import Data.Maybe -import Data.Text (Text, pack, unpack) -import Data.Text.Lens (unpacked) -import qualified Data.Text as T -import System.FilePath -import Text.Read (readMaybe) -import Text.Format - -import System.Directory.Paths -import HsDev.Display -import HsDev.PackageDb.Types -import HsDev.Project.Types -import HsDev.Util ((.::), (.::?), (.::?!), objectUnion, noNulls) - --- | Just package name and version without its location -data ModulePackage = ModulePackage { - _packageName :: Text, - _packageVersion :: Text } - deriving (Eq, Ord) - -makeLenses ''ModulePackage - -mkPackage :: Text -> ModulePackage -mkPackage n = ModulePackage n "" - -instance NFData ModulePackage where - rnf (ModulePackage n v) = rnf n `seq` rnf v - -instance Show ModulePackage where - show (ModulePackage n "") = unpack n - show (ModulePackage n v) = unpack n ++ "-" ++ unpack v - -instance Read ModulePackage where - readsPrec _ str = case pkg of - "" -> [] - _ -> [(ModulePackage (pack n) (pack v), str')] - where - (pkg, str') = break isSpace str - (rv, rn) = span versionChar $ reverse pkg - v = reverse rv - n = reverse $ dropWhile (== '-') rn - - versionChar ch = isDigit ch || ch == '.' - -instance ToJSON ModulePackage where - toJSON (ModulePackage n v) = object [ - "name" .= n, - "version" .= v] - -instance FromJSON ModulePackage where - parseJSON = withObject "module package" $ \v -> - ModulePackage <$> (v .:: "name") <*> (v .:: "version") - -data PackageConfig = PackageConfig { - _package :: ModulePackage, - _packageModules :: [Text], - _packageExposed :: Bool } - deriving (Eq, Ord, Read, Show) - -makeLenses ''PackageConfig - -instance NFData PackageConfig where - rnf (PackageConfig p ms e) = rnf p `seq` rnf ms `seq` rnf e - -instance ToJSON PackageConfig where - toJSON (PackageConfig p ms e) = toJSON p `objectUnion` object ["modules" .= ms, "exposed" .= e] - -instance FromJSON PackageConfig where - parseJSON = withObject "package-config" $ \v -> PackageConfig <$> - parseJSON (Object v) <*> - (v .::?! "modules") <*> - (v .:: "exposed" <|> pure False) - --- | Location of module -data ModuleLocation = - FileModule { _moduleFile :: Path, _moduleProject :: Maybe Project } | - InstalledModule { _moduleInstallDirs :: [Path], _modulePackage :: ModulePackage, _installedModuleName :: Text, _installedModuleExposed :: Bool } | - OtherLocation { _otherLocationName :: Text } | - NoLocation - -instance Eq ModuleLocation where - FileModule lfile _ == FileModule rfile _ = lfile == rfile - InstalledModule ldirs _ lname _ == InstalledModule rdirs _ rname _ = ldirs == rdirs && lname == rname - OtherLocation l == OtherLocation r = l == r - NoLocation == NoLocation = True - _ == _ = False - -instance Ord ModuleLocation where - compare l r = compare (locType l, locNames l) (locType r, locNames r) where - locType :: ModuleLocation -> Int - locType FileModule{} = 0 - locType InstalledModule{} = 1 - locType OtherLocation{} = 2 - locType NoLocation = 3 - locNames (FileModule f _) = [f] - locNames (InstalledModule dirs _ nm _) = nm : dirs -- dirs already includes name of package - locNames (OtherLocation n) = [n] - locNames NoLocation = [] - -makeLenses ''ModuleLocation - -locationId :: ModuleLocation -> Text -locationId (FileModule fpath _) = fpath -locationId (InstalledModule dirs mpack nm _) = T.intercalate ":" (take 1 dirs ++ [pack (show mpack), nm]) -locationId (OtherLocation src) = src -locationId NoLocation = "" - -instance NFData ModuleLocation where - rnf (FileModule f p) = rnf f `seq` rnf p - rnf (InstalledModule d p n e) = rnf d `seq` rnf p `seq` rnf n `seq` rnf e - rnf (OtherLocation s) = rnf s - rnf NoLocation = () - -instance Show ModuleLocation where - show = unpack . locationId - -instance Display ModuleLocation where - display (FileModule f _) = display f - display (InstalledModule _ _ n _) = view unpacked n - display (OtherLocation s) = view unpacked s - display NoLocation = "" - displayType _ = "module" - -instance Formattable ModuleLocation where - formattable = formattable . display - -instance ToJSON ModuleLocation where - toJSON (FileModule f p) = object $ noNulls ["file" .= f, "project" .= fmap (view projectCabal) p] - toJSON (InstalledModule c p n e) = object $ noNulls ["dirs" .= c, "package" .= show p, "name" .= n, "exposed" .= e] - toJSON (OtherLocation s) = object ["source" .= s] - toJSON NoLocation = object [] - -instance FromJSON ModuleLocation where - parseJSON = withObject "module location" $ \v -> - (FileModule <$> v .:: "file" <*> (fmap project <$> (v .::? "project"))) <|> - (InstalledModule <$> v .::?! "dirs" <*> (readPackage =<< (v .:: "package")) <*> v .:: "name" <*> v .:: "exposed") <|> - (OtherLocation <$> v .:: "source") <|> - (pure NoLocation) - where - readPackage s = maybe (fail $ "can't parse package: " ++ s) return . readMaybe $ s - -instance Paths ModuleLocation where - paths f (FileModule fpath p) = FileModule <$> paths f fpath <*> traverse (paths f) p - paths f (InstalledModule c p n e) = InstalledModule <$> traverse (paths f) c <*> pure p <*> pure n <*> pure e - paths _ (OtherLocation s) = pure $ OtherLocation s - paths _ NoLocation = pure NoLocation - -noLocation :: ModuleLocation -noLocation = NoLocation - -data ModuleId = ModuleId { - _moduleName :: Text, - _moduleLocation :: ModuleLocation } - deriving (Eq, Ord) - -makeLenses ''ModuleId - -instance NFData ModuleId where - rnf (ModuleId n l) = rnf n `seq` rnf l - -instance Show ModuleId where - show (ModuleId n l) = show l ++ ":" ++ unpack n - -instance ToJSON ModuleId where - toJSON m = object $ noNulls [ - "name" .= _moduleName m, - "location" .= _moduleLocation m] - -instance FromJSON ModuleId where - parseJSON = withObject "module-id" $ \v -> ModuleId <$> - (fromMaybe "" <$> (v .::? "name")) <*> - (fromMaybe NoLocation <$> (v .::? "location")) - --- | Symbol -data SymbolId = SymbolId { - _symbolName :: Text, - _symbolModule :: ModuleId } - deriving (Eq, Ord) - -makeLenses ''SymbolId - -instance NFData SymbolId where - rnf (SymbolId n m) = rnf n `seq` rnf m - -instance Show SymbolId where - show (SymbolId n m) = show m ++ ":" ++ unpack n - -instance ToJSON SymbolId where - toJSON s = object $ noNulls [ - "name" .= _symbolName s, - "module" .= _symbolModule s] - -instance FromJSON SymbolId where - parseJSON = withObject "symbol-id" $ \v -> SymbolId <$> - (fromMaybe "" <$> (v .::? "name")) <*> - (fromMaybe (ModuleId "" NoLocation) <$> (v .::? "module")) - -data Position = Position { - _positionLine :: Int, - _positionColumn :: Int } - deriving (Eq, Ord, Read) - -makeLenses ''Position - -instance NFData Position where - rnf (Position l c) = rnf l `seq` rnf c - -instance Show Position where - show (Position l c) = show l ++ ":" ++ show c - -instance ToJSON Position where - toJSON (Position l c) = object [ - "line" .= l, - "column" .= c] - -instance FromJSON Position where - parseJSON = withObject "position" $ \v -> Position <$> - v .:: "line" <*> - v .:: "column" - -data Region = Region { - _regionFrom :: Position, - _regionTo :: Position } - deriving (Eq, Ord, Read) - -makeLenses ''Region - -region :: Position -> Position -> Region -region f t = Region (min f t) (max f t) - -regionAt :: Position -> Region -regionAt f = region f f - -regionLines :: Region -> Int -regionLines (Region f t) = succ (view positionLine t - view positionLine f) - --- | Get string at region -regionStr :: Region -> Text -> Text -regionStr r@(Region f t) s = T.intercalate "\n" $ T.drop (pred $ view positionColumn f) fline : tl where - s' = take (regionLines r) $ drop (pred (view positionLine f)) $ T.lines s - (fline:tl) = init s' ++ [T.take (pred $ view positionColumn t) (last s')] - -instance NFData Region where - rnf (Region f t) = rnf f `seq` rnf t - -instance Show Region where - show (Region f t) = show f ++ "-" ++ show t - -instance ToJSON Region where - toJSON (Region f t) = object [ - "from" .= f, - "to" .= t] - -instance FromJSON Region where - parseJSON = withObject "region" $ \v -> Region <$> - v .:: "from" <*> - v .:: "to" - --- | Location of symbol -data Location = Location { - _locationModule :: ModuleLocation, - _locationPosition :: Maybe Position } - deriving (Eq, Ord) - -makeLenses ''Location - -instance NFData Location where - rnf (Location m p) = rnf m `seq` rnf p - -instance Show Location where - show (Location m p) = show m ++ ":" ++ show p - -instance ToJSON Location where - toJSON (Location ml p) = object [ - "module" .= ml, - "pos" .= p] - -instance FromJSON Location where - parseJSON = withObject "location" $ \v -> Location <$> - v .:: "module" <*> - v .::? "pos" - --- | Get source module root directory, i.e. for "...\src\Foo\Bar.hs" with module 'Foo.Bar' will return "...\src" -sourceModuleRoot :: Text -> Path -> Path -sourceModuleRoot mname = over paths $ - normalise . joinPath . - reverse . drop (length $ T.split (== '.') mname) . reverse . - splitDirectories - --- | Path to module source --- >importPath "Quux.Blah" = "Quux/Blah.hs" -importPath :: Text -> Path -importPath = fromFilePath . (`addExtension` "hs") . joinPath . map unpack . T.split (== '.') - --- | Root of sources, package dir or root directory of standalone modules -sourceRoot :: ModuleId -> Maybe Path -sourceRoot m = do - fpath <- preview (moduleLocation . moduleFile) m - mproj <- preview (moduleLocation . moduleProject) m - return $ maybe - (sourceModuleRoot (view moduleName m) fpath) - (view projectPath) - mproj - -sourceRoot_ :: ModuleId -> Path -sourceRoot_ = fromMaybe (error "sourceRoot_: not a source location") . sourceRoot - --- | Recalc positions to interpret '\t' as one symbol instead of N -class RecalcTabs a where - -- | Interpret '\t' as one symbol instead of N - recalcTabs :: Text -> Int -> a -> a - -- | Inverse of `recalcTabs`: interpret '\t' as N symbols instead of 1 - calcTabs :: Text -> Int -> a -> a - -instance RecalcTabs Position where - recalcTabs cts n (Position l c) = Position l c' where - line = listToMaybe $ drop (pred l) $ T.lines cts - c' = case line of - Nothing -> c - Just line' -> let sizes = map charSize (unpack line') in - succ . fromMaybe (length sizes) . - findIndex (>= pred c) . - scanl (+) 0 $ sizes - charSize :: Char -> Int - charSize '\t' = n - charSize _ = 1 - calcTabs cts n (Position l c) = Position l c' where - line = listToMaybe $ drop (pred l) $ T.lines cts - c' = maybe c (succ . sum . map charSize . take (pred c) . unpack) line - charSize :: Char -> Int - charSize '\t' = n - charSize _ = 1 - -instance RecalcTabs Region where - recalcTabs cts n (Region f t) = Region (recalcTabs cts n f) (recalcTabs cts n t) - calcTabs cts n (Region f t) = Region (calcTabs cts n f) (calcTabs cts n t) +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} + +module HsDev.Symbols.Location ( + ModulePackage(..), mkPackage, PackageConfig(..), + ModuleLocation(..), locationId, noLocation, + ModuleId(..), moduleName, moduleLocation, + SymbolId(..), symbolName, symbolModule, + Position(..), Region(..), region, regionAt, regionLines, regionStr, + Location(..), + + packageName, packageVersion, + package, packageModules, packageExposed, + moduleFile, moduleProject, moduleInstallDirs, modulePackage, installedModuleName, installedModuleExposed, otherLocationName, + positionLine, positionColumn, + regionFrom, regionTo, + locationModule, locationPosition, + + sourceModuleRoot, + importPath, + sourceRoot, sourceRoot_, + RecalcTabs(..), + + module HsDev.PackageDb.Types + ) where + +import Control.Applicative +import Control.DeepSeq (NFData(..)) +import Control.Lens (makeLenses, view, preview, over) +import Data.Aeson +import Data.Char (isSpace, isDigit) +import Data.List (findIndex) +import Data.Maybe +import Data.Text (Text, pack, unpack) +import Data.Text.Lens (unpacked) +import qualified Data.Text as T +import System.FilePath +import Text.Read (readMaybe) +import Text.Format + +import System.Directory.Paths +import HsDev.Display +import HsDev.PackageDb.Types +import HsDev.Project.Types +import HsDev.Util ((.::), (.::?), (.::?!), objectUnion, noNulls) + +-- | Just package name and version without its location +data ModulePackage = ModulePackage { + _packageName :: Text, + _packageVersion :: Text } + deriving (Eq, Ord) + +makeLenses ''ModulePackage + +mkPackage :: Text -> ModulePackage +mkPackage n = ModulePackage n "" + +instance NFData ModulePackage where + rnf (ModulePackage n v) = rnf n `seq` rnf v + +instance Show ModulePackage where + show (ModulePackage n "") = unpack n + show (ModulePackage n v) = unpack n ++ "-" ++ unpack v + +instance Read ModulePackage where + readsPrec _ str = case pkg of + "" -> [] + _ -> [(ModulePackage (pack n) (pack v), str')] + where + (pkg, str') = break isSpace str + (rv, rn) = span versionChar $ reverse pkg + v = reverse rv + n = reverse $ dropWhile (== '-') rn + + versionChar ch = isDigit ch || ch == '.' + +instance ToJSON ModulePackage where + toJSON (ModulePackage n v) = object [ + "name" .= n, + "version" .= v] + +instance FromJSON ModulePackage where + parseJSON = withObject "module package" $ \v -> + ModulePackage <$> (v .:: "name") <*> (v .:: "version") + +data PackageConfig = PackageConfig { + _package :: ModulePackage, + _packageModules :: [Text], + _packageExposed :: Bool } + deriving (Eq, Ord, Read, Show) + +makeLenses ''PackageConfig + +instance NFData PackageConfig where + rnf (PackageConfig p ms e) = rnf p `seq` rnf ms `seq` rnf e + +instance ToJSON PackageConfig where + toJSON (PackageConfig p ms e) = toJSON p `objectUnion` object ["modules" .= ms, "exposed" .= e] + +instance FromJSON PackageConfig where + parseJSON = withObject "package-config" $ \v -> PackageConfig <$> + parseJSON (Object v) <*> + (v .::?! "modules") <*> + (v .:: "exposed" <|> pure False) + +-- | Location of module +data ModuleLocation = + FileModule { _moduleFile :: Path, _moduleProject :: Maybe Project } | + InstalledModule { _moduleInstallDirs :: [Path], _modulePackage :: ModulePackage, _installedModuleName :: Text, _installedModuleExposed :: Bool } | + OtherLocation { _otherLocationName :: Text } | + NoLocation + +instance Eq ModuleLocation where + FileModule lfile _ == FileModule rfile _ = lfile == rfile + InstalledModule ldirs _ lname _ == InstalledModule rdirs _ rname _ = ldirs == rdirs && lname == rname + OtherLocation l == OtherLocation r = l == r + NoLocation == NoLocation = True + _ == _ = False + +instance Ord ModuleLocation where + compare l r = compare (locType l, locNames l) (locType r, locNames r) where + locType :: ModuleLocation -> Int + locType FileModule{} = 0 + locType InstalledModule{} = 1 + locType OtherLocation{} = 2 + locType NoLocation = 3 + locNames (FileModule f _) = [f] + locNames (InstalledModule dirs _ nm _) = nm : dirs -- dirs already includes name of package + locNames (OtherLocation n) = [n] + locNames NoLocation = [] + +makeLenses ''ModuleLocation + +locationId :: ModuleLocation -> Text +locationId (FileModule fpath _) = fpath +locationId (InstalledModule dirs mpack nm _) = T.intercalate ":" (take 1 dirs ++ [pack (show mpack), nm]) +locationId (OtherLocation src) = src +locationId NoLocation = "" + +instance NFData ModuleLocation where + rnf (FileModule f p) = rnf f `seq` rnf p + rnf (InstalledModule d p n e) = rnf d `seq` rnf p `seq` rnf n `seq` rnf e + rnf (OtherLocation s) = rnf s + rnf NoLocation = () + +instance Show ModuleLocation where + show = unpack . locationId + +instance Display ModuleLocation where + display (FileModule f _) = display f + display (InstalledModule _ _ n _) = view unpacked n + display (OtherLocation s) = view unpacked s + display NoLocation = "" + displayType _ = "module" + +instance Formattable ModuleLocation where + formattable = formattable . display + +instance ToJSON ModuleLocation where + toJSON (FileModule f p) = object $ noNulls ["file" .= f, "project" .= fmap (view projectCabal) p] + toJSON (InstalledModule c p n e) = object $ noNulls ["dirs" .= c, "package" .= show p, "name" .= n, "exposed" .= e] + toJSON (OtherLocation s) = object ["source" .= s] + toJSON NoLocation = object [] + +instance FromJSON ModuleLocation where + parseJSON = withObject "module location" $ \v -> + (FileModule <$> v .:: "file" <*> (fmap project <$> (v .::? "project"))) <|> + (InstalledModule <$> v .::?! "dirs" <*> (readPackage =<< (v .:: "package")) <*> v .:: "name" <*> v .:: "exposed") <|> + (OtherLocation <$> v .:: "source") <|> + (pure NoLocation) + where + readPackage s = maybe (fail $ "can't parse package: " ++ s) return . readMaybe $ s + +instance Paths ModuleLocation where + paths f (FileModule fpath p) = FileModule <$> paths f fpath <*> traverse (paths f) p + paths f (InstalledModule c p n e) = InstalledModule <$> traverse (paths f) c <*> pure p <*> pure n <*> pure e + paths _ (OtherLocation s) = pure $ OtherLocation s + paths _ NoLocation = pure NoLocation + +noLocation :: ModuleLocation +noLocation = NoLocation + +data ModuleId = ModuleId { + _moduleName :: Text, + _moduleLocation :: ModuleLocation } + deriving (Eq, Ord) + +makeLenses ''ModuleId + +instance NFData ModuleId where + rnf (ModuleId n l) = rnf n `seq` rnf l + +instance Show ModuleId where + show (ModuleId n l) = show l ++ ":" ++ unpack n + +instance ToJSON ModuleId where + toJSON m = object $ noNulls [ + "name" .= _moduleName m, + "location" .= _moduleLocation m] + +instance FromJSON ModuleId where + parseJSON = withObject "module-id" $ \v -> ModuleId <$> + (fromMaybe "" <$> (v .::? "name")) <*> + (fromMaybe NoLocation <$> (v .::? "location")) + +-- | Symbol +data SymbolId = SymbolId { + _symbolName :: Text, + _symbolModule :: ModuleId } + deriving (Eq, Ord) + +makeLenses ''SymbolId + +instance NFData SymbolId where + rnf (SymbolId n m) = rnf n `seq` rnf m + +instance Show SymbolId where + show (SymbolId n m) = show m ++ ":" ++ unpack n + +instance ToJSON SymbolId where + toJSON s = object $ noNulls [ + "name" .= _symbolName s, + "module" .= _symbolModule s] + +instance FromJSON SymbolId where + parseJSON = withObject "symbol-id" $ \v -> SymbolId <$> + (fromMaybe "" <$> (v .::? "name")) <*> + (fromMaybe (ModuleId "" NoLocation) <$> (v .::? "module")) + +data Position = Position { + _positionLine :: Int, + _positionColumn :: Int } + deriving (Eq, Ord, Read) + +makeLenses ''Position + +instance NFData Position where + rnf (Position l c) = rnf l `seq` rnf c + +instance Show Position where + show (Position l c) = show l ++ ":" ++ show c + +instance ToJSON Position where + toJSON (Position l c) = object [ + "line" .= l, + "column" .= c] + +instance FromJSON Position where + parseJSON = withObject "position" $ \v -> Position <$> + v .:: "line" <*> + v .:: "column" + +data Region = Region { + _regionFrom :: Position, + _regionTo :: Position } + deriving (Eq, Ord, Read) + +makeLenses ''Region + +region :: Position -> Position -> Region +region f t = Region (min f t) (max f t) + +regionAt :: Position -> Region +regionAt f = region f f + +regionLines :: Region -> Int +regionLines (Region f t) = succ (view positionLine t - view positionLine f) + +-- | Get string at region +regionStr :: Region -> Text -> Text +regionStr r@(Region f t) s = T.intercalate "\n" $ T.drop (pred $ view positionColumn f) fline : tl where + s' = take (regionLines r) $ drop (pred (view positionLine f)) $ T.lines s + (fline:tl) = init s' ++ [T.take (pred $ view positionColumn t) (last s')] + +instance NFData Region where + rnf (Region f t) = rnf f `seq` rnf t + +instance Show Region where + show (Region f t) = show f ++ "-" ++ show t + +instance ToJSON Region where + toJSON (Region f t) = object [ + "from" .= f, + "to" .= t] + +instance FromJSON Region where + parseJSON = withObject "region" $ \v -> Region <$> + v .:: "from" <*> + v .:: "to" + +-- | Location of symbol +data Location = Location { + _locationModule :: ModuleLocation, + _locationPosition :: Maybe Position } + deriving (Eq, Ord) + +makeLenses ''Location + +instance NFData Location where + rnf (Location m p) = rnf m `seq` rnf p + +instance Show Location where + show (Location m p) = show m ++ ":" ++ show p + +instance ToJSON Location where + toJSON (Location ml p) = object [ + "module" .= ml, + "pos" .= p] + +instance FromJSON Location where + parseJSON = withObject "location" $ \v -> Location <$> + v .:: "module" <*> + v .::? "pos" + +-- | Get source module root directory, i.e. for "...\src\Foo\Bar.hs" with module 'Foo.Bar' will return "...\src" +sourceModuleRoot :: Text -> Path -> Path +sourceModuleRoot mname = over paths $ + normalise . joinPath . + reverse . drop (length $ T.split (== '.') mname) . reverse . + splitDirectories + +-- | Path to module source +-- >importPath "Quux.Blah" = "Quux/Blah.hs" +importPath :: Text -> Path +importPath = fromFilePath . (`addExtension` "hs") . joinPath . map unpack . T.split (== '.') + +-- | Root of sources, package dir or root directory of standalone modules +sourceRoot :: ModuleId -> Maybe Path +sourceRoot m = do + fpath <- preview (moduleLocation . moduleFile) m + mproj <- preview (moduleLocation . moduleProject) m + return $ maybe + (sourceModuleRoot (view moduleName m) fpath) + (view projectPath) + mproj + +sourceRoot_ :: ModuleId -> Path +sourceRoot_ = fromMaybe (error "sourceRoot_: not a source location") . sourceRoot + +-- | Recalc positions to interpret '\t' as one symbol instead of N +class RecalcTabs a where + -- | Interpret '\t' as one symbol instead of N + recalcTabs :: Text -> Int -> a -> a + -- | Inverse of `recalcTabs`: interpret '\t' as N symbols instead of 1 + calcTabs :: Text -> Int -> a -> a + +instance RecalcTabs Position where + recalcTabs cts n (Position l c) = Position l c' where + line = listToMaybe $ drop (pred l) $ T.lines cts + c' = case line of + Nothing -> c + Just line' -> let sizes = map charSize (unpack line') in + succ . fromMaybe (length sizes) . + findIndex (>= pred c) . + scanl (+) 0 $ sizes + charSize :: Char -> Int + charSize '\t' = n + charSize _ = 1 + calcTabs cts n (Position l c) = Position l c' where + line = listToMaybe $ drop (pred l) $ T.lines cts + c' = maybe c (succ . sum . map charSize . take (pred c) . unpack) line + charSize :: Char -> Int + charSize '\t' = n + charSize _ = 1 + +instance RecalcTabs Region where + recalcTabs cts n (Region f t) = Region (recalcTabs cts n f) (recalcTabs cts n t) + calcTabs cts n (Region f t) = Region (calcTabs cts n f) (calcTabs cts n t) diff --git a/src/HsDev/Symbols/Name.hs b/src/HsDev/Symbols/Name.hs --- a/src/HsDev/Symbols/Name.hs +++ b/src/HsDev/Symbols/Name.hs @@ -1,90 +1,90 @@ -{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns, OverloadedStrings #-} - -module HsDev.Symbols.Name ( - Name, qualName, unqualName, nameModule, nameIdent, pattern Name, fromName_, toName_, toModuleName_, fromModuleName_, fromName, toName, - name_, moduleName_ - ) where - -import Control.Arrow -import Control.Lens -import Data.Char (isAlpha, isAlphaNum) -import Data.Text (Text) -import Data.String (fromString) -import qualified Data.Text as T -import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..)) -import qualified Language.Haskell.Exts as Exts (Name(..)) - --- | Qualified name -type Name = QName () - -qualName :: String -> String -> Name -qualName m = Qual () (ModuleName () m) . toName_ . fromString - -unqualName :: String -> Name -unqualName = UnQual () . toName_ . fromString - -nameModule :: Name -> Maybe Text -nameModule (Qual _ (ModuleName _ m) _) = Just $ fromString m -nameModule _ = Nothing - -nameIdent :: Name -> Text -nameIdent (Qual _ _ n) = fromName_ n -nameIdent (UnQual _ n) = fromName_ n -nameIdent s = fromName s - -pattern Name :: Maybe Text -> Text -> Name -pattern Name m n <- ((nameModule &&& nameIdent) -> (m, n)) where - Name Nothing n = UnQual () (Exts.Ident () (T.unpack n)) - Name (Just m) n = Qual () (ModuleName () (T.unpack m)) (Exts.Ident () (T.unpack n)) - -fromName_ :: Exts.Name () -> Text -fromName_ (Exts.Ident _ s') = fromString s' -fromName_ (Exts.Symbol _ s') = fromString s' - -toName_ :: Text -> Exts.Name () -toName_ txt - | T.null txt = Exts.Ident () "" - | isAlpha (T.head txt) && (T.all validChar $ T.tail txt) = Exts.Ident () . T.unpack $ txt - | otherwise = Exts.Symbol () . T.unpack $ txt - where - validChar ch = isAlphaNum ch || ch == '_' - -toModuleName_ :: Text -> ModuleName () -toModuleName_ = ModuleName () . T.unpack - -fromModuleName_ :: ModuleName () -> Text -fromModuleName_ (ModuleName () m) = T.pack m - -toName :: Text -> Name -toName "()" = Special () (UnitCon ()) -toName "[]" = Special () (ListCon ()) -toName "->" = Special () (FunCon ()) -toName "(:)" = Special () (Cons ()) -toName "(# #)" = Special () (UnboxedSingleCon ()) -toName tup - | T.all (== ',') noBraces = Special () (TupleCon () Boxed (succ $ T.length noBraces)) - where - noBraces = T.dropAround (`elem` ['(', ')']) tup -toName n = case T.split (== '.') n of - [n'] -> UnQual () (Exts.Ident () $ T.unpack n') - ns -> Qual () (ModuleName () (T.unpack $ T.intercalate "." $ init ns)) (toName_ $ last ns) - -fromName :: Name -> Text -fromName (Qual _ (ModuleName _ m) n) = T.concat [fromString m, ".", fromName_ n] -fromName (UnQual _ n) = fromName_ n -fromName (Special _ c) = case c of - UnitCon _ -> "()" - ListCon _ -> "[]" - FunCon _ -> "->" - TupleCon _ _ i -> fromString $ "(" ++ replicate (pred i) ',' ++ ")" - Cons _ -> "(:)" - UnboxedSingleCon _ -> "(# #)" -#if MIN_VERSION_haskell_src_exts(1,20,0) - ExprHole _ -> "_" -#endif - -name_ :: Iso' (Exts.Name ()) Text -name_ = iso fromName_ toName_ - -moduleName_ :: Iso' (ModuleName ()) Text -moduleName_ = iso fromModuleName_ toModuleName_ +{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns, OverloadedStrings #-} + +module HsDev.Symbols.Name ( + Name, qualName, unqualName, nameModule, nameIdent, pattern Name, fromName_, toName_, toModuleName_, fromModuleName_, fromName, toName, + name_, moduleName_ + ) where + +import Control.Arrow +import Control.Lens +import Data.Char (isAlpha, isAlphaNum) +import Data.Text (Text) +import Data.String (fromString) +import qualified Data.Text as T +import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..)) +import qualified Language.Haskell.Exts as Exts (Name(..)) + +-- | Qualified name +type Name = QName () + +qualName :: String -> String -> Name +qualName m = Qual () (ModuleName () m) . toName_ . fromString + +unqualName :: String -> Name +unqualName = UnQual () . toName_ . fromString + +nameModule :: Name -> Maybe Text +nameModule (Qual _ (ModuleName _ m) _) = Just $ fromString m +nameModule _ = Nothing + +nameIdent :: Name -> Text +nameIdent (Qual _ _ n) = fromName_ n +nameIdent (UnQual _ n) = fromName_ n +nameIdent s = fromName s + +pattern Name :: Maybe Text -> Text -> Name +pattern Name m n <- ((nameModule &&& nameIdent) -> (m, n)) where + Name Nothing n = UnQual () (Exts.Ident () (T.unpack n)) + Name (Just m) n = Qual () (ModuleName () (T.unpack m)) (Exts.Ident () (T.unpack n)) + +fromName_ :: Exts.Name () -> Text +fromName_ (Exts.Ident _ s') = fromString s' +fromName_ (Exts.Symbol _ s') = fromString s' + +toName_ :: Text -> Exts.Name () +toName_ txt + | T.null txt = Exts.Ident () "" + | isAlpha (T.head txt) && (T.all validChar $ T.tail txt) = Exts.Ident () . T.unpack $ txt + | otherwise = Exts.Symbol () . T.unpack $ txt + where + validChar ch = isAlphaNum ch || ch == '_' + +toModuleName_ :: Text -> ModuleName () +toModuleName_ = ModuleName () . T.unpack + +fromModuleName_ :: ModuleName () -> Text +fromModuleName_ (ModuleName () m) = T.pack m + +toName :: Text -> Name +toName "()" = Special () (UnitCon ()) +toName "[]" = Special () (ListCon ()) +toName "->" = Special () (FunCon ()) +toName "(:)" = Special () (Cons ()) +toName "(# #)" = Special () (UnboxedSingleCon ()) +toName tup + | T.all (== ',') noBraces = Special () (TupleCon () Boxed (succ $ T.length noBraces)) + where + noBraces = T.dropAround (`elem` ['(', ')']) tup +toName n = case T.split (== '.') n of + [n'] -> UnQual () (Exts.Ident () $ T.unpack n') + ns -> Qual () (ModuleName () (T.unpack $ T.intercalate "." $ init ns)) (toName_ $ last ns) + +fromName :: Name -> Text +fromName (Qual _ (ModuleName _ m) n) = T.concat [fromString m, ".", fromName_ n] +fromName (UnQual _ n) = fromName_ n +fromName (Special _ c) = case c of + UnitCon _ -> "()" + ListCon _ -> "[]" + FunCon _ -> "->" + TupleCon _ _ i -> fromString $ "(" ++ replicate (pred i) ',' ++ ")" + Cons _ -> "(:)" + UnboxedSingleCon _ -> "(# #)" +#if MIN_VERSION_haskell_src_exts(1,20,0) + ExprHole _ -> "_" +#endif + +name_ :: Iso' (Exts.Name ()) Text +name_ = iso fromName_ toName_ + +moduleName_ :: Iso' (ModuleName ()) Text +moduleName_ = iso fromModuleName_ toModuleName_ diff --git a/src/HsDev/Symbols/Parsed.hs b/src/HsDev/Symbols/Parsed.hs --- a/src/HsDev/Symbols/Parsed.hs +++ b/src/HsDev/Symbols/Parsed.hs @@ -1,197 +1,197 @@ -{-# LANGUAGE RankNTypes #-} - -module HsDev.Symbols.Parsed ( - Ann, Parsed, - qnames, names, binders, locals, globals, references, unresolveds, - usages, named, imports, declarations, moduleNames, - - annL, symbolL, file, pos, defPos, resolvedName, - isBinder, isLocal, isGlobal, isReference, isUnresolved, resolveError, - refsTo, refsToName, - nameInfoL, positionL, regionL, fileL, - symbolNameL, - - prettyPrint - ) where - -import Control.Lens -import Data.Data -import Data.Data.Lens -import Data.Maybe (isJust) -import Data.Text (Text) -import Language.Haskell.Exts hiding (Name(..)) -import qualified Language.Haskell.Exts as E (Name(..)) -import Language.Haskell.Names - -import HsDev.Symbols.Name -import HsDev.Symbols.Location (Position(..), positionLine, positionColumn, Region(..), region) - --- | Annotation of parsed and resolved nodes -type Ann = Scoped SrcSpanInfo - --- | Parsed and resolved module -type Parsed = Module Ann - --- | Get all qualified names -qnames :: Data (ast Ann) => Traversal' (ast Ann) (QName Ann) -qnames = biplate - --- | Get all names -names :: Data (ast Ann) => Traversal' (ast Ann) (E.Name Ann) -names = biplate - --- | Get all binders -binders :: Annotated ast => Traversal' (ast Ann) (ast Ann) -binders = filtered isBinder - --- | Get all names locally defined -locals :: Annotated ast => Traversal' (ast Ann) (ast Ann) -locals = filtered isLocal - --- | Get all names, references global symbol -globals :: Annotated ast => Traversal' (ast Ann) (ast Ann) -globals = filtered isGlobal - --- | Get all resolved references -references :: Annotated ast => Traversal' (ast Ann) (ast Ann) -references = filtered isReference - --- | Get all names with not in scope error -unresolveds :: Annotated ast => Traversal' (ast Ann) (ast Ann) -unresolveds = filtered isUnresolved - --- | Get all usages of symbol -usages :: Annotated ast => Name -> Traversal' (ast Ann) (ast Ann) -usages = filtered . refsTo - --- | Get usages of symbols with unqualified name -named :: Annotated ast => Text -> Traversal' (ast Ann) (ast Ann) -named = filtered . refsToName - --- | Get imports -imports :: Data (ast Ann) => Traversal' (ast Ann) (ImportDecl Ann) -imports = biplate - --- | Get declarations -declarations :: Data (ast Ann) => Traversal' (ast Ann) (Decl Ann) -declarations = biplate - --- | Get module names -moduleNames :: Data (ast Ann) => Traversal' (ast Ann) (ModuleName Ann) -moduleNames = biplate - --- | Get annotation -annL :: Annotated ast => Lens' (ast a) a -annL = lens ann (\v a' -> amap (const a') v) - --- | Get haskell-names symbols -symbolL :: Data a => Traversal' a Symbol -symbolL = biplate - --- | Get source file -file :: Annotated ast => Lens' (ast Ann) FilePath -file = annL . fileL - --- | Get source location -pos :: (Annotated ast, SrcInfo isrc, Data isrc) => Lens' (ast isrc) Position -pos = annL . positionL - --- | Definition position, if binder - returns current position -defPos :: Annotated ast => Traversal' (ast Ann) Position -defPos = annL . defLoc' where - defLoc' :: Traversal' Ann Position - defLoc' f (Scoped (LocalValue s) i) = Scoped <$> (LocalValue <$> positionL f s) <*> pure i - defLoc' f (Scoped (TypeVar s) i) = Scoped <$> (TypeVar <$> positionL f s) <*> pure i - defLoc' f (Scoped ValueBinder i) = Scoped ValueBinder <$> positionL f i - defLoc' f (Scoped TypeBinder i) = Scoped TypeBinder <$> positionL f i - defLoc' _ s = pure s - --- | Resolved global name -resolvedName :: Annotated ast => Traversal' (ast Ann) Name -resolvedName = annL . nameInfoL . symbolL . symbolNameL - --- | Does ast node binds something -isBinder :: Annotated ast => ast Ann -> Bool -isBinder e = (e ^. annL . nameInfoL) `elem` [TypeBinder, ValueBinder] - --- | Does ast node locally defined -isLocal :: Annotated ast => ast Ann -> Bool -isLocal e = case e ^. annL . nameInfoL of - LocalValue _ -> True - TypeVar _ -> True - _ -> False - --- | Does ast node reference something -isGlobal :: Annotated ast => ast Ann -> Bool -isGlobal e = case e ^. annL . nameInfoL of - GlobalSymbol _ _ -> True - _ -> False - --- | Does ast node reference something -isReference :: Annotated ast => ast Ann -> Bool -isReference e = isLocal e || isGlobal e - --- | Is ast node not resolved -isUnresolved :: Annotated ast => ast Ann -> Bool -isUnresolved = isJust . resolveError - --- | Resolve error -resolveError :: Annotated ast => ast Ann -> Maybe String -resolveError e = case e ^. annL . nameInfoL of - ScopeError err -> Just $ ppError err - _ -> Nothing - --- | Node references to specified symbol -refsTo :: Annotated ast => Name -> ast Ann -> Bool -refsTo n a = Just n == a ^? resolvedName - --- | Node references to specified unqualified name -refsToName :: Annotated ast => Text -> ast Ann -> Bool -refsToName n a = Just n == fmap nameIdent (a ^? resolvedName) - -nameInfoL :: Lens' (Scoped a) (NameInfo a) -nameInfoL = lens g' s' where - g' (Scoped i _) = i - s' (Scoped _ s) i' = Scoped i' s - -positionL :: (SrcInfo isrc, Data isrc) => Lens' isrc Position -positionL = lens g' s' where - g' i = Position l c where - SrcLoc _ l c = getPointLoc i - s' i (Position l c) = over biplate upd i where - Position sl sc = g' i -- Old location - -- main line: set new line and move column - -- other lines: just move line, because altering first line's column doesn't affect other lines - upd :: SrcLoc -> SrcLoc - upd (SrcLoc f' l' c') - | l' == sl = SrcLoc f' l (c' - sc + c) - | otherwise = SrcLoc f' (l' - sl + l) c' - -regionL :: Annotated ast => Lens' (ast Ann) Region -regionL = lens g' s' where - g' i = case ann i of - Scoped _ sinfo -> toPos (srcSpanStart span') `region` toPos (srcSpanEnd span') where - span' = srcInfoSpan sinfo - toPos = uncurry Position - s' i (Region s e) = amap (fmap upd) i where - upd :: SrcSpanInfo -> SrcSpanInfo - upd sinfo = sinfo { - srcInfoSpan = (srcInfoSpan sinfo) { - srcSpanStartLine = s ^. positionLine, - srcSpanStartColumn = s ^. positionColumn, - srcSpanEndLine = e ^. positionLine, - srcSpanEndColumn = e ^. positionColumn }, - srcInfoPoints = [] } - -fileL :: (SrcInfo isrc, Data isrc) => Lens' isrc FilePath -fileL = lens g' s' where - g' = fileName - s' i f = set biplate f i - --- | Get 'Symbol' as 'Name' -symbolNameL :: Lens' Symbol Name -symbolNameL = lens g' s' where - g' sym' = Qual () (symbolModule sym') (symbolName sym') - s' sym' (Qual _ m n) = sym' { symbolModule = m, symbolName = n } - s' sym' (UnQual _ n) = sym' { symbolName = n } - s' sym' _ = sym' +{-# LANGUAGE RankNTypes #-} + +module HsDev.Symbols.Parsed ( + Ann, Parsed, + qnames, names, binders, locals, globals, references, unresolveds, + usages, named, imports, declarations, moduleNames, + + annL, symbolL, file, pos, defPos, resolvedName, + isBinder, isLocal, isGlobal, isReference, isUnresolved, resolveError, + refsTo, refsToName, + nameInfoL, positionL, regionL, fileL, + symbolNameL, + + prettyPrint + ) where + +import Control.Lens +import Data.Data +import Data.Data.Lens +import Data.Maybe (isJust) +import Data.Text (Text) +import Language.Haskell.Exts hiding (Name(..)) +import qualified Language.Haskell.Exts as E (Name(..)) +import Language.Haskell.Names + +import HsDev.Symbols.Name +import HsDev.Symbols.Location (Position(..), positionLine, positionColumn, Region(..), region) + +-- | Annotation of parsed and resolved nodes +type Ann = Scoped SrcSpanInfo + +-- | Parsed and resolved module +type Parsed = Module Ann + +-- | Get all qualified names +qnames :: Data (ast Ann) => Traversal' (ast Ann) (QName Ann) +qnames = biplate + +-- | Get all names +names :: Data (ast Ann) => Traversal' (ast Ann) (E.Name Ann) +names = biplate + +-- | Get all binders +binders :: Annotated ast => Traversal' (ast Ann) (ast Ann) +binders = filtered isBinder + +-- | Get all names locally defined +locals :: Annotated ast => Traversal' (ast Ann) (ast Ann) +locals = filtered isLocal + +-- | Get all names, references global symbol +globals :: Annotated ast => Traversal' (ast Ann) (ast Ann) +globals = filtered isGlobal + +-- | Get all resolved references +references :: Annotated ast => Traversal' (ast Ann) (ast Ann) +references = filtered isReference + +-- | Get all names with not in scope error +unresolveds :: Annotated ast => Traversal' (ast Ann) (ast Ann) +unresolveds = filtered isUnresolved + +-- | Get all usages of symbol +usages :: Annotated ast => Name -> Traversal' (ast Ann) (ast Ann) +usages = filtered . refsTo + +-- | Get usages of symbols with unqualified name +named :: Annotated ast => Text -> Traversal' (ast Ann) (ast Ann) +named = filtered . refsToName + +-- | Get imports +imports :: Data (ast Ann) => Traversal' (ast Ann) (ImportDecl Ann) +imports = biplate + +-- | Get declarations +declarations :: Data (ast Ann) => Traversal' (ast Ann) (Decl Ann) +declarations = biplate + +-- | Get module names +moduleNames :: Data (ast Ann) => Traversal' (ast Ann) (ModuleName Ann) +moduleNames = biplate + +-- | Get annotation +annL :: Annotated ast => Lens' (ast a) a +annL = lens ann (\v a' -> amap (const a') v) + +-- | Get haskell-names symbols +symbolL :: Data a => Traversal' a Symbol +symbolL = biplate + +-- | Get source file +file :: Annotated ast => Lens' (ast Ann) FilePath +file = annL . fileL + +-- | Get source location +pos :: (Annotated ast, SrcInfo isrc, Data isrc) => Lens' (ast isrc) Position +pos = annL . positionL + +-- | Definition position, if binder - returns current position +defPos :: Annotated ast => Traversal' (ast Ann) Position +defPos = annL . defLoc' where + defLoc' :: Traversal' Ann Position + defLoc' f (Scoped (LocalValue s) i) = Scoped <$> (LocalValue <$> positionL f s) <*> pure i + defLoc' f (Scoped (TypeVar s) i) = Scoped <$> (TypeVar <$> positionL f s) <*> pure i + defLoc' f (Scoped ValueBinder i) = Scoped ValueBinder <$> positionL f i + defLoc' f (Scoped TypeBinder i) = Scoped TypeBinder <$> positionL f i + defLoc' _ s = pure s + +-- | Resolved global name +resolvedName :: Annotated ast => Traversal' (ast Ann) Name +resolvedName = annL . nameInfoL . symbolL . symbolNameL + +-- | Does ast node binds something +isBinder :: Annotated ast => ast Ann -> Bool +isBinder e = (e ^. annL . nameInfoL) `elem` [TypeBinder, ValueBinder] + +-- | Does ast node locally defined +isLocal :: Annotated ast => ast Ann -> Bool +isLocal e = case e ^. annL . nameInfoL of + LocalValue _ -> True + TypeVar _ -> True + _ -> False + +-- | Does ast node reference something +isGlobal :: Annotated ast => ast Ann -> Bool +isGlobal e = case e ^. annL . nameInfoL of + GlobalSymbol _ _ -> True + _ -> False + +-- | Does ast node reference something +isReference :: Annotated ast => ast Ann -> Bool +isReference e = isLocal e || isGlobal e + +-- | Is ast node not resolved +isUnresolved :: Annotated ast => ast Ann -> Bool +isUnresolved = isJust . resolveError + +-- | Resolve error +resolveError :: Annotated ast => ast Ann -> Maybe String +resolveError e = case e ^. annL . nameInfoL of + ScopeError err -> Just $ ppError err + _ -> Nothing + +-- | Node references to specified symbol +refsTo :: Annotated ast => Name -> ast Ann -> Bool +refsTo n a = Just n == a ^? resolvedName + +-- | Node references to specified unqualified name +refsToName :: Annotated ast => Text -> ast Ann -> Bool +refsToName n a = Just n == fmap nameIdent (a ^? resolvedName) + +nameInfoL :: Lens' (Scoped a) (NameInfo a) +nameInfoL = lens g' s' where + g' (Scoped i _) = i + s' (Scoped _ s) i' = Scoped i' s + +positionL :: (SrcInfo isrc, Data isrc) => Lens' isrc Position +positionL = lens g' s' where + g' i = Position l c where + SrcLoc _ l c = getPointLoc i + s' i (Position l c) = over biplate upd i where + Position sl sc = g' i -- Old location + -- main line: set new line and move column + -- other lines: just move line, because altering first line's column doesn't affect other lines + upd :: SrcLoc -> SrcLoc + upd (SrcLoc f' l' c') + | l' == sl = SrcLoc f' l (c' - sc + c) + | otherwise = SrcLoc f' (l' - sl + l) c' + +regionL :: Annotated ast => Lens' (ast Ann) Region +regionL = lens g' s' where + g' i = case ann i of + Scoped _ sinfo -> toPos (srcSpanStart span') `region` toPos (srcSpanEnd span') where + span' = srcInfoSpan sinfo + toPos = uncurry Position + s' i (Region s e) = amap (fmap upd) i where + upd :: SrcSpanInfo -> SrcSpanInfo + upd sinfo = sinfo { + srcInfoSpan = (srcInfoSpan sinfo) { + srcSpanStartLine = s ^. positionLine, + srcSpanStartColumn = s ^. positionColumn, + srcSpanEndLine = e ^. positionLine, + srcSpanEndColumn = e ^. positionColumn }, + srcInfoPoints = [] } + +fileL :: (SrcInfo isrc, Data isrc) => Lens' isrc FilePath +fileL = lens g' s' where + g' = fileName + s' i f = set biplate f i + +-- | Get 'Symbol' as 'Name' +symbolNameL :: Lens' Symbol Name +symbolNameL = lens g' s' where + g' sym' = Qual () (symbolModule sym') (symbolName sym') + s' sym' (Qual _ m n) = sym' { symbolModule = m, symbolName = n } + s' sym' (UnQual _ n) = sym' { symbolName = n } + s' sym' _ = sym' diff --git a/src/HsDev/Symbols/Resolve.hs b/src/HsDev/Symbols/Resolve.hs --- a/src/HsDev/Symbols/Resolve.hs +++ b/src/HsDev/Symbols/Resolve.hs @@ -1,27 +1,27 @@ -{-# LANGUAGE RankNTypes #-} - -module HsDev.Symbols.Resolve ( - RefineTable, refineTable, refineSymbol, refineSymbols, - symbolUniqId - ) where - -import Control.Lens -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) - -import HsDev.Symbols - -type RefineTable = M.Map (Text, Text, SymbolInfo) Symbol - -refineTable :: [Symbol] -> RefineTable -refineTable syms = M.fromList [(symbolUniqId s, s) | s <- syms] - -refineSymbol :: RefineTable -> Symbol -> Symbol -refineSymbol tbl s = fromMaybe s $ M.lookup (symbolUniqId s) tbl - -refineSymbols :: RefineTable -> Module -> Module -refineSymbols tbl = over moduleSymbols (refineSymbol tbl) - -symbolUniqId :: Symbol -> (Text, Text, SymbolInfo) -symbolUniqId s = (view (symbolId . symbolName) s, view (symbolId . symbolModule . moduleName) s, nullifyInfo $ view symbolInfo s) +{-# LANGUAGE RankNTypes #-} + +module HsDev.Symbols.Resolve ( + RefineTable, refineTable, refineSymbol, refineSymbols, + symbolUniqId + ) where + +import Control.Lens +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) + +import HsDev.Symbols + +type RefineTable = M.Map (Text, Text, SymbolInfo) Symbol + +refineTable :: [Symbol] -> RefineTable +refineTable syms = M.fromList [(symbolUniqId s, s) | s <- syms] + +refineSymbol :: RefineTable -> Symbol -> Symbol +refineSymbol tbl s = fromMaybe s $ M.lookup (symbolUniqId s) tbl + +refineSymbols :: RefineTable -> Module -> Module +refineSymbols tbl = over moduleSymbols (refineSymbol tbl) + +symbolUniqId :: Symbol -> (Text, Text, SymbolInfo) +symbolUniqId s = (view (symbolId . symbolName) s, view (symbolId . symbolModule . moduleName) s, nullifyInfo $ view symbolInfo s) diff --git a/src/HsDev/Symbols/Types.hs b/src/HsDev/Symbols/Types.hs --- a/src/HsDev/Symbols/Types.hs +++ b/src/HsDev/Symbols/Types.hs @@ -1,648 +1,648 @@ -{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Symbols.Types ( - Import(..), importPosition, importName, importQualified, importAs, - Module(..), moduleSymbols, exportedSymbols, scopeSymbols, fixitiesMap, moduleFixities, moduleId, moduleDocs, moduleImports, moduleExports, moduleScope, moduleSource, - Symbol(..), symbolId, symbolDocs, symbolPosition, symbolInfo, - SymbolInfo(..), functionType, parentClass, parentType, selectorConstructors, typeArgs, typeContext, familyAssociate, symbolInfoType, symbolType, patternType, patternConstructor, - Scoped(..), scopeQualifier, scoped, - SymbolUsage(..), symbolUsed, symbolUsedQualifier, symbolUsedIn, symbolUsedRegion, - ImportedSymbol(..), importedSymbol, importedFrom, - infoOf, nullifyInfo, - Inspection(..), inspectionAt, inspectionOpts, fresh, Inspected(..), inspection, inspectedKey, inspectionTags, inspectionResult, inspected, - InspectM(..), runInspect, continueInspect, inspect, inspect_, withInspection, - inspectedTup, noTags, tag, ModuleTag(..), InspectedModule, notInspected, - - module HsDev.PackageDb.Types, - module HsDev.Project, - module HsDev.Symbols.Name, - module HsDev.Symbols.Class, - module HsDev.Symbols.Location, - module HsDev.Symbols.Documented - ) where - -import Control.Arrow -import Control.Applicative -import Control.Lens hiding ((.=)) -import Control.Monad -import Control.Monad.Morph -import Control.Monad.Catch -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.DeepSeq (NFData(..)) -import Data.Aeson -import Data.Aeson.Types (Pair, Parser) -import Data.List (intercalate) -import Data.Maybe (catMaybes) -import Data.Maybe.JustIf -import Data.Monoid (Any(..)) -import Data.Monoid hiding ((<>)) -import Data.Function -import Data.Ord -import Data.Semigroup -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import Data.Set (Set) -import qualified Data.Set as S -import Data.Time.Clock.POSIX (POSIXTime) -import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..), Fixity(..), Assoc(..)) -import qualified Language.Haskell.Exts as Exts (Name(..)) -import Text.Format - -import Control.Apply.Util (chain) -import HsDev.Display -import HsDev.Error -import HsDev.PackageDb.Types -import HsDev.Project -import HsDev.Symbols.Name -import HsDev.Symbols.Class -import HsDev.Symbols.Location -import HsDev.Symbols.Documented -import HsDev.Symbols.Parsed -import HsDev.Util ((.::), (.::?), (.::?!), noNulls, objectUnion) -import System.Directory.Paths - -instance NFData l => NFData (ModuleName l) where - rnf (ModuleName l n) = rnf l `seq` rnf n - -instance NFData l => NFData (Exts.Name l) where - rnf (Exts.Ident l s) = rnf l `seq` rnf s - rnf (Exts.Symbol l s) = rnf l `seq` rnf s - -instance NFData Boxed where - rnf Boxed = () - rnf Unboxed = () - -instance NFData l => NFData (SpecialCon l) where - rnf (UnitCon l) = rnf l - rnf (ListCon l) = rnf l - rnf (FunCon l) = rnf l - rnf (TupleCon l b i) = rnf l `seq` rnf b `seq` rnf i - rnf (Cons l) = rnf l - rnf (UnboxedSingleCon l) = rnf l -#if MIN_VERSION_haskell_src_exts(1,20,0) - rnf (ExprHole l) = rnf l -#endif - -instance NFData l => NFData (QName l) where - rnf (Qual l m n) = rnf l `seq` rnf m `seq` rnf n - rnf (UnQual l n) = rnf l `seq` rnf n - rnf (Special l s) = rnf l `seq` rnf s - --- | Import -data Import = Import { - _importPosition :: Position, -- source line of import - _importName :: Text, -- imported module name - _importQualified :: Bool, -- is import qualified - _importAs :: Maybe Text } -- alias of import - deriving (Eq, Ord) - -instance NFData Import where - rnf (Import p n q a) = rnf p `seq` rnf n `seq` rnf q `seq` rnf a - -instance Show Import where - show (Import _ n q a) = concat $ catMaybes [ - Just "import", - "qualified" `justIf` q, - Just $ show n, - fmap (("as " ++) . show) a] - -instance ToJSON Import where - toJSON (Import p n q a) = object [ - "pos" .= p, - "name" .= n, - "qualified" .= q, - "as" .= a] - -instance FromJSON Import where - parseJSON = withObject "import" $ \v -> Import <$> - v .:: "pos" <*> - v .:: "name" <*> - v .:: "qualified" <*> - v .:: "as" - --- | Module -data Module = Module { - _moduleId :: ModuleId, - _moduleDocs :: Maybe Text, - _moduleImports :: [Import], -- list of module names imported - _moduleExports :: [Symbol], -- exported module symbols - _moduleFixities :: [Fixity], -- fixities of operators - _moduleScope :: Map Name [Symbol], -- symbols in scope, only for source modules - _moduleSource :: Maybe Parsed } -- source of module - --- | Make each symbol appear only once -moduleSymbols :: Traversal' Module Symbol -moduleSymbols f m = getBack <$> (each . _1) f revList where - revList = M.toList $ M.unionsWith mappend $ concat [ - [M.singleton sym ([], Any True) | sym <- _moduleExports m], - [M.singleton sym ([nm], Any False) | (nm, syms) <- M.toList (_moduleScope m), sym <- syms]] - getBack syms = m { - _moduleExports = [sym' | (sym', (_, Any True)) <- syms], - _moduleScope = M.unionsWith (++) [M.singleton n [sym'] | (sym', (ns, _)) <- syms, n <- ns] } - -exportedSymbols :: Traversal' Module Symbol -exportedSymbols f m = (\e -> m { _moduleExports = e }) <$> traverse f (_moduleExports m) - -scopeSymbols :: Traversal' Module (Symbol, [Name]) -scopeSymbols f m = (\s -> m { _moduleScope = invMap s }) <$> traverse f (M.toList . invMap . M.toList $ _moduleScope m) where - invMap :: Ord b => [(a, [b])] -> Map b [a] - invMap es = M.unionsWith (++) [M.singleton v [k] | (k, vs) <- es, v <- vs] - -fixitiesMap :: Lens' Module (Map Name Fixity) -fixitiesMap = lens g' s' where - g' m = mconcat [M.singleton n f | f@(Fixity _ _ n) <- _moduleFixities m] - s' m m' = m { _moduleFixities = M.elems m' } - -instance ToJSON (Assoc ()) where - toJSON (AssocNone _) = toJSON ("none" :: String) - toJSON (AssocLeft _) = toJSON ("left" :: String) - toJSON (AssocRight _) = toJSON ("right" :: String) - -instance FromJSON (Assoc ()) where - parseJSON = withText "assoc" $ \txt -> msum [ - guard (txt == "none") >> return (AssocNone ()), - guard (txt == "left") >> return (AssocLeft ()), - guard (txt == "right") >> return (AssocRight ())] - -instance ToJSON Fixity where - toJSON (Fixity assoc pr n) = object $ noNulls [ - "assoc" .= assoc, - "prior" .= pr, - "name" .= fromName n] - -instance FromJSON Fixity where - parseJSON = withObject "fixity" $ \v -> Fixity <$> - v .:: "assoc" <*> - v .:: "prior" <*> - (toName <$> v .:: "name") - -instance ToJSON Module where - toJSON m = object $ noNulls [ - "id" .= _moduleId m, - "docs" .= _moduleDocs m, - "imports" .= _moduleImports m, - "exports" .= _moduleExports m, - "fixities" .= _moduleFixities m] - -instance FromJSON Module where - parseJSON = withObject "module" $ \v -> Module <$> - v .:: "id" <*> - v .::? "docs" <*> - v .::?! "imports" <*> - v .::?! "exports" <*> - v .::?! "fixities" <*> - pure mempty <*> - pure Nothing - -instance NFData (Assoc ()) where - rnf (AssocNone _) = () - rnf (AssocLeft _) = () - rnf (AssocRight _) = () - -instance NFData Fixity where - rnf (Fixity assoc pr n) = rnf assoc `seq` rnf pr `seq` rnf n - -instance NFData Module where - rnf (Module i d is e fs s msrc) = msrc `seq` rnf i `seq` rnf d `seq` rnf is `seq` rnf e `seq` rnf fs `seq` rnf s - -instance Eq Module where - l == r = _moduleId l == _moduleId r - -instance Ord Module where - compare l r = compare (_moduleId l) (_moduleId r) - -instance Show Module where - show = show . _moduleId - -data Symbol = Symbol { - _symbolId :: SymbolId, - _symbolDocs :: Maybe Text, - _symbolPosition :: Maybe Position, - _symbolInfo :: SymbolInfo } - -instance Eq Symbol where - l == r = (_symbolId l, symbolType l) == (_symbolId r, symbolType r) - -instance Ord Symbol where - compare l r = compare (_symbolId l, symbolType l) (_symbolId r, symbolType r) - -instance NFData Symbol where - rnf (Symbol i d l info) = rnf i `seq` rnf d `seq` rnf l `seq` rnf info - -instance Show Symbol where - show = show . _symbolId - -instance ToJSON Symbol where - toJSON s = object $ noNulls [ - "id" .= _symbolId s, - "docs" .= _symbolDocs s, - "pos" .= _symbolPosition s, - "info" .= _symbolInfo s] - -instance FromJSON Symbol where - parseJSON = withObject "symbol" $ \v -> Symbol <$> - v .:: "id" <*> - v .::? "docs" <*> - v .::? "pos" <*> - v .:: "info" - -data SymbolInfo = - Function { _functionType :: Maybe Text } | - Method { _functionType :: Maybe Text, _parentClass :: Text } | - Selector { _functionType :: Maybe Text, _parentType :: Text, _selectorConstructors :: [Text] } | - Constructor { _typeArgs :: [Text], _parentType :: Text } | - Type { _typeArgs :: [Text], _typeContext :: [Text] } | - NewType { _typeArgs :: [Text], _typeContext :: [Text] } | - Data { _typeArgs :: [Text], _typeContext :: [Text] } | - Class { _typeArgs :: [Text], _typeContext :: [Text] } | - TypeFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } | - DataFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } | - PatConstructor { _typeArgs :: [Text], _patternType :: Maybe Text } | - PatSelector { _functionType :: Maybe Text, _patternType :: Maybe Text, _patternConstructor :: Text } - deriving (Eq, Ord, Read, Show) - -instance NFData SymbolInfo where - rnf (Function ft) = rnf ft - rnf (Method ft cls) = rnf ft `seq` rnf cls - rnf (Selector ft t cs) = rnf ft `seq` rnf t `seq` rnf cs - rnf (Constructor as t) = rnf as `seq` rnf t - rnf (Type as ctx) = rnf as `seq` rnf ctx - rnf (NewType as ctx) = rnf as `seq` rnf ctx - rnf (Data as ctx) = rnf as `seq` rnf ctx - rnf (Class as ctx) = rnf as `seq` rnf ctx - rnf (TypeFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a - rnf (DataFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a - rnf (PatConstructor as t) = rnf as `seq` rnf t - rnf (PatSelector ft t c) = rnf ft `seq` rnf t `seq` rnf c - -instance ToJSON SymbolInfo where - toJSON (Function ft) = object [what "function", "type" .= ft] - toJSON (Method ft cls) = object [what "method", "type" .= ft, "class" .= cls] - toJSON (Selector ft t cs) = object [what "selector", "type" .= ft, "parent" .= t, "constructors" .= cs] - toJSON (Constructor as t) = object [what "ctor", "args" .= as, "type" .= t] - toJSON (Type as ctx) = object [what "type", "args" .= as, "ctx" .= ctx] - toJSON (NewType as ctx) = object [what "newtype", "args" .= as, "ctx" .= ctx] - toJSON (Data as ctx) = object [what "data", "args" .= as, "ctx" .= ctx] - toJSON (Class as ctx) = object [what "class", "args" .= as, "ctx" .= ctx] - toJSON (TypeFam as ctx a) = object [what "type-family", "args" .= as, "ctx" .= ctx, "associate" .= a] - toJSON (DataFam as ctx a) = object [what "data-family", "args" .= as, "ctx" .= ctx, "associate" .= a] - toJSON (PatConstructor as t) = object [what "pat-ctor", "args" .= as, "pat-type" .= t] - toJSON (PatSelector ft t c) = object [what "pat-selector", "type" .= ft, "pat-type" .= t, "constructor" .= c] - -class EmptySymbolInfo a where - infoOf :: a -> SymbolInfo - -instance EmptySymbolInfo SymbolInfo where - infoOf = id - -instance (Monoid a, EmptySymbolInfo r) => EmptySymbolInfo (a -> r) where - infoOf f = infoOf $ f mempty - -symbolInfoType :: SymbolInfo -> String -symbolInfoType (Function{}) = "function" -symbolInfoType (Method{}) = "method" -symbolInfoType (Selector{}) = "selector" -symbolInfoType (Constructor{}) = "ctor" -symbolInfoType (Type{}) = "type" -symbolInfoType (NewType{}) = "newtype" -symbolInfoType (Data{}) = "data" -symbolInfoType (Class{}) = "class" -symbolInfoType (TypeFam{}) = "type-family" -symbolInfoType (DataFam{}) = "data-family" -symbolInfoType (PatConstructor{}) = "pat-ctor" -symbolInfoType (PatSelector{}) = "pat-selector" - -symbolType :: Symbol -> String -symbolType = symbolInfoType . _symbolInfo - -what :: String -> Pair -what n = "what" .= n - -instance FromJSON SymbolInfo where - parseJSON = withObject "symbol info" $ \v -> msum [ - gwhat "function" v >> (Function <$> v .::? "type"), - gwhat "method" v >> (Method <$> v .::? "type" <*> v .:: "class"), - gwhat "selector" v >> (Selector <$> v .::? "type" <*> v .:: "parent" <*> v .::?! "constructors"), - gwhat "ctor" v >> (Constructor <$> v .::?! "args" <*> v .:: "type"), - gwhat "type" v >> (Type <$> v .::?! "args" <*> v .::?! "ctx"), - gwhat "newtype" v >> (NewType <$> v .::?! "args" <*> v .::?! "ctx"), - gwhat "data" v >> (Data <$> v .::?! "args" <*> v .::?! "ctx"), - gwhat "class" v >> (Class <$> v .::?! "args" <*> v .::?! "ctx"), - gwhat "type-family" v >> (TypeFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"), - gwhat "data-family" v >> (DataFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"), - gwhat "pat-ctor" v >> (PatConstructor <$> v .::?! "args" <*> v .::? "pat-type"), - gwhat "pat-selector" v >> (PatSelector <$> v .::? "type" <*> v .::? "pat-type" <*> v .:: "constructor")] - -gwhat :: String -> Object -> Parser () -gwhat n v = do - s <- v .:: "what" - guard (s == n) - --- | Scoped entity with qualifier -data Scoped a = Scoped { - _scopeQualifier :: Maybe Text, - _scoped :: a } - deriving (Eq, Ord) - -instance Show a => Show (Scoped a) where - show (Scoped q s) = maybe "" (\q' -> T.unpack q' ++ ".") q ++ show s - -instance ToJSON a => ToJSON (Scoped a) where - toJSON (Scoped q s) = toJSON s `objectUnion` object (noNulls ["qualifier" .= q]) - -instance FromJSON a => FromJSON (Scoped a) where - parseJSON = withObject "scope-symbol" $ \v -> Scoped <$> - (v .::? "qualifier") <*> - parseJSON (Object v) - --- | Symbol usage -data SymbolUsage = SymbolUsage { - _symbolUsed :: Symbol, - _symbolUsedQualifier :: Maybe Text, - _symbolUsedIn :: ModuleId, - _symbolUsedRegion :: Region } - deriving (Eq, Ord) - -instance Show SymbolUsage where - show (SymbolUsage s _ m p) = show s ++ " at " ++ show m ++ ":" ++ show p - -instance ToJSON SymbolUsage where - toJSON (SymbolUsage s q m p) = object $ noNulls ["symbol" .= s, "qualifier" .= q, "in" .= m, "at" .= p] - -instance FromJSON SymbolUsage where - parseJSON = withObject "symbol-usage" $ \v -> SymbolUsage <$> - v .:: "symbol" <*> - v .::? "qualifier" <*> - v .:: "in" <*> - v .:: "at" - --- | Symbol with module it's exported from -data ImportedSymbol = ImportedSymbol { - _importedSymbol :: Symbol, - _importedFrom :: ModuleId } - deriving (Eq, Ord) - -instance Show ImportedSymbol where - show (ImportedSymbol s m) = show s ++ " imported from " ++ show m - -instance ToJSON ImportedSymbol where - toJSON (ImportedSymbol s m) = objectUnion (toJSON s) $ object [ - "imported" .= m] - -instance FromJSON ImportedSymbol where - parseJSON = withObject "imported-symbol" $ \v -> ImportedSymbol <$> - parseJSON (Object v) <*> - v .:: "imported" - --- | Inspection data -data Inspection = - -- | No inspection - InspectionNone | - -- | Time and flags of inspection - InspectionAt { - _inspectionAt :: POSIXTime, - _inspectionOpts :: [Text] } - deriving (Eq, Ord) - -instance NFData Inspection where - rnf InspectionNone = () - rnf (InspectionAt t fs) = rnf t `seq` rnf fs - -instance Show Inspection where - show InspectionNone = "none" - show (InspectionAt tm fs) = "mtime " ++ show tm ++ ", flags [" ++ intercalate ", " (map T.unpack fs) ++ "]" - -instance Read POSIXTime where - readsPrec i = map (first (fromIntegral :: Integer -> POSIXTime)) . readsPrec i - -instance Semigroup Inspection where - InspectionNone <> r = r - l <> InspectionNone = l - InspectionAt ltm lopts <> InspectionAt rtm ropts - | ltm >= rtm = InspectionAt ltm lopts - | otherwise = InspectionAt rtm ropts - -instance Monoid Inspection where - mempty = InspectionNone - mappend l r = l <> r - -instance ToJSON Inspection where - toJSON InspectionNone = object ["inspected" .= False] - toJSON (InspectionAt tm fs) = object [ - "mtime" .= (fromRational (toRational tm) :: Double), - "flags" .= fs] - -instance FromJSON Inspection where - parseJSON = withObject "inspection" $ \v -> - ((const InspectionNone :: Bool -> Inspection) <$> v .:: "inspected") <|> - (InspectionAt <$> ((fromRational . (toRational :: Double -> Rational)) <$> v .:: "mtime") <*> (v .:: "flags")) - --- | Is left @Inspection@ fresh comparing to right one -fresh :: Inspection -> Inspection -> Bool -fresh InspectionNone InspectionNone = True -fresh InspectionNone _ = False -fresh _ InspectionNone = True -fresh (InspectionAt tm _) (InspectionAt tm' _) = tm' - tm < 0.01 - --- | Inspected entity -data Inspected k t a = Inspected { - _inspection :: Inspection, - _inspectedKey :: k, - _inspectionTags :: Set t, - _inspectionResult :: Either HsDevError a } - -inspectedTup :: Inspected k t a -> (Inspection, k, Set t, Maybe a) -inspectedTup (Inspected insp i tags res) = (insp, i, tags, either (const Nothing) Just res) - -instance (Eq k, Eq t, Eq a) => Eq (Inspected k t a) where - (==) = (==) `on` inspectedTup - -instance (Ord k, Ord t, Ord a) => Ord (Inspected k t a) where - compare = comparing inspectedTup - -instance Functor (Inspected k t) where - fmap f insp = insp { - _inspectionResult = fmap f (_inspectionResult insp) } - -instance Foldable (Inspected k t) where - foldMap f = either mempty f . _inspectionResult - -instance Traversable (Inspected k t) where - traverse f (Inspected insp i ts r) = Inspected insp i ts <$> either (pure . Left) (liftA Right . f) r - -instance (NFData k, NFData t, NFData a) => NFData (Inspected k t a) where - rnf (Inspected t i ts r) = rnf t `seq` rnf i `seq` rnf ts `seq` rnf r - -instance (ToJSON k, ToJSON t, ToJSON a) => ToJSON (Inspected k t a) where - toJSON im = object [ - "inspection" .= _inspection im, - "location" .= _inspectedKey im, - "tags" .= S.toList (_inspectionTags im), - either ("error" .=) ("result" .=) (_inspectionResult im)] - -instance (FromJSON k, Ord t, FromJSON t, FromJSON a) => FromJSON (Inspected k t a) where - parseJSON = withObject "inspected" $ \v -> Inspected <$> - v .:: "inspection" <*> - v .:: "location" <*> - (S.fromList <$> (v .::?! "tags")) <*> - ((Left <$> v .:: "error") <|> (Right <$> v .:: "result")) - -newtype InspectM k t m a = InspectM { runInspectM :: ReaderT k (ExceptT HsDevError (StateT (Inspection, S.Set t) m)) a } - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadReader k, MonadError HsDevError, MonadState (Inspection, S.Set t)) - -instance MonadTrans (InspectM k t) where - lift = InspectM . lift . lift . lift - -runInspect :: (Monad m, Ord t) => k -> InspectM k t m a -> m (Inspected k t a) -runInspect key act = do - (res, (insp, ts)) <- flip runStateT (InspectionNone, mempty) . runExceptT . flip runReaderT key . runInspectM $ act - return $ Inspected insp key ts res - --- | Continue inspection -continueInspect :: (Monad m, Ord t) => Inspected k t a -> (a -> InspectM k t m b) -> m (Inspected k t b) -continueInspect start act = runInspect (_inspectedKey start) $ do - put (_inspection start, _inspectionTags start) - val <- either throwError return $ _inspectionResult start - act val - -inspect :: MonadCatch m => m Inspection -> (k -> m a) -> InspectM k t m a -inspect insp act = withInspection insp $ do - key <- ask - lift (hsdevCatch (hsdevLiftIO $ act key)) >>= either throwError return - -withInspection :: MonadCatch m => m Inspection -> InspectM k t m a -> InspectM k t m a -withInspection insp inner = do - insp' <- lift insp - let - setInsp = modify (set _1 insp') - catchError (inner <* setInsp) (\e -> setInsp >> throwError e) - -inspect_ :: MonadCatch m => m Inspection -> m a -> InspectM k t m a -inspect_ insp = inspect insp . const - --- | Empty tags -noTags :: Set t -noTags = S.empty - --- | One tag -tag :: t -> Set t -tag = S.singleton - -data ModuleTag = InferredTypesTag | RefinedDocsTag | OnlyHeaderTag | DirtyTag | ResolvedNamesTag deriving (Eq, Ord, Read, Show, Enum, Bounded) - -instance NFData ModuleTag where - rnf InferredTypesTag = () - rnf RefinedDocsTag = () - rnf OnlyHeaderTag = () - rnf DirtyTag = () - rnf ResolvedNamesTag = () - -instance Display ModuleTag where - display InferredTypesTag = "types" - display RefinedDocsTag = "docs" - display OnlyHeaderTag = "header" - display DirtyTag = "dirty" - display ResolvedNamesTag = "resolved" - displayType _ = "module-tag" - -instance ToJSON ModuleTag where - toJSON InferredTypesTag = toJSON ("types" :: String) - toJSON RefinedDocsTag = toJSON ("docs" :: String) - toJSON OnlyHeaderTag = toJSON ("header" :: String) - toJSON DirtyTag = toJSON ("dirty" :: String) - toJSON ResolvedNamesTag = toJSON ("resolved" :: String) - -instance FromJSON ModuleTag where - parseJSON = withText "module-tag" $ \txt -> msum [ - guard (txt == "types") >> return InferredTypesTag, - guard (txt == "docs") >> return RefinedDocsTag, - guard (txt == "header") >> return OnlyHeaderTag, - guard (txt == "dirty") >> return DirtyTag, - guard (txt == "resolved") >> return ResolvedNamesTag] - --- | Inspected module -type InspectedModule = Inspected ModuleLocation ModuleTag Module - -instance Show InspectedModule where - show (Inspected i mi ts m) = unlines [either showError show m, "\tinspected: " ++ show i, "\ttags: " ++ intercalate ", " (map show $ S.toList ts)] where - showError :: HsDevError -> String - showError e = unlines $ ("\terror: " ++ show e) : case mi of - FileModule f p -> ["file: " ++ f ^. path, "project: " ++ maybe "" (view (projectPath . path)) p] - InstalledModule c p n _ -> ["cabal: " ++ show c, "package: " ++ show p, "name: " ++ T.unpack n] - OtherLocation src -> ["other location: " ++ T.unpack src] - NoLocation -> ["no location"] - -notInspected :: ModuleLocation -> InspectedModule -notInspected mloc = Inspected mempty mloc noTags (Left $ NotInspected mloc) - -instance Documented ModuleId where - brief m = brief $ _moduleLocation m - detailed = brief - -instance Documented SymbolId where - brief s = "{} from {}" ~~ _symbolName s ~~ brief (_symbolModule s) - detailed = brief - -instance Documented Module where - brief = brief . _moduleId - detailed m = T.unlines (brief m : info) where - info = [ - "\texports: {}" ~~ T.intercalate ", " (map brief (_moduleExports m))] - -instance Documented Symbol where - brief = brief . _symbolId - detailed s = T.unlines [brief s, info] where - info = case _symbolInfo s of - Function t -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "function", fmap ("type: {}" ~~) t]) - Method t p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "method", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p]) - Selector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "selector", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p]) - Constructor args p -> "\t" `T.append` T.intercalate ", " ["constructor", "args: {}" ~~ T.unwords args, "parent: {}" ~~ p] - Type args ctx -> "\t" `T.append` T.intercalate ", " ["type", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] - NewType args ctx -> "\t" `T.append` T.intercalate ", " ["newtype", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] - Data args ctx -> "\t" `T.append` T.intercalate ", " ["data", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] - Class args ctx -> "\t" `T.append` T.intercalate ", " ["class", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] - TypeFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["type family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] - DataFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["data family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] - PatConstructor args p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern constructor", Just $ "args: {}" ~~ T.unwords args, fmap ("pat-type: {}" ~~) p]) - PatSelector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern selector", fmap ("type: {}" ~~) t, fmap ("pat-type: {}" ~~) p]) - -makeLenses ''Import -makeLenses ''Module -makeLenses ''Symbol -makeLenses ''SymbolInfo -makeLenses ''Scoped -makeLenses ''SymbolUsage -makeLenses ''ImportedSymbol -makeLenses ''Inspection -makeLenses ''Inspected - -inspected :: Traversal (Inspected k t a) (Inspected k t b) a b -inspected = inspectionResult . _Right - -nullifyInfo :: SymbolInfo -> SymbolInfo -nullifyInfo = chain [ - set functionType mempty, - set parentClass mempty, - set parentType mempty, - set selectorConstructors mempty, - set typeArgs mempty, - set typeContext mempty, - set familyAssociate mempty, - set patternType mempty, - set patternConstructor mempty] - -instance Sourced Module where - sourcedName = moduleId . moduleName - sourcedDocs = moduleDocs . _Just - sourcedModule = moduleId - -instance Sourced Symbol where - sourcedName = symbolId . symbolName - sourcedDocs = symbolDocs . _Just - sourcedModule = symbolId . symbolModule - sourcedLocation = symbolPosition . _Just +{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Symbols.Types ( + Import(..), importPosition, importName, importQualified, importAs, + Module(..), moduleSymbols, exportedSymbols, scopeSymbols, fixitiesMap, moduleFixities, moduleId, moduleDocs, moduleImports, moduleExports, moduleScope, moduleSource, + Symbol(..), symbolId, symbolDocs, symbolPosition, symbolInfo, + SymbolInfo(..), functionType, parentClass, parentType, selectorConstructors, typeArgs, typeContext, familyAssociate, symbolInfoType, symbolType, patternType, patternConstructor, + Scoped(..), scopeQualifier, scoped, + SymbolUsage(..), symbolUsed, symbolUsedQualifier, symbolUsedIn, symbolUsedRegion, + ImportedSymbol(..), importedSymbol, importedFrom, + infoOf, nullifyInfo, + Inspection(..), inspectionAt, inspectionOpts, fresh, Inspected(..), inspection, inspectedKey, inspectionTags, inspectionResult, inspected, + InspectM(..), runInspect, continueInspect, inspect, inspect_, withInspection, + inspectedTup, noTags, tag, ModuleTag(..), InspectedModule, notInspected, + + module HsDev.PackageDb.Types, + module HsDev.Project, + module HsDev.Symbols.Name, + module HsDev.Symbols.Class, + module HsDev.Symbols.Location, + module HsDev.Symbols.Documented + ) where + +import Control.Arrow +import Control.Applicative +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Morph +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Control.DeepSeq (NFData(..)) +import Data.Aeson +import Data.Aeson.Types (Pair, Parser) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Maybe.JustIf +import Data.Monoid (Any(..)) +import Data.Monoid hiding ((<>)) +import Data.Function +import Data.Ord +import Data.Semigroup +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Set (Set) +import qualified Data.Set as S +import Data.Time.Clock.POSIX (POSIXTime) +import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..), Fixity(..), Assoc(..)) +import qualified Language.Haskell.Exts as Exts (Name(..)) +import Text.Format + +import Control.Apply.Util (chain) +import HsDev.Display +import HsDev.Error +import HsDev.PackageDb.Types +import HsDev.Project +import HsDev.Symbols.Name +import HsDev.Symbols.Class +import HsDev.Symbols.Location +import HsDev.Symbols.Documented +import HsDev.Symbols.Parsed +import HsDev.Util ((.::), (.::?), (.::?!), noNulls, objectUnion) +import System.Directory.Paths + +instance NFData l => NFData (ModuleName l) where + rnf (ModuleName l n) = rnf l `seq` rnf n + +instance NFData l => NFData (Exts.Name l) where + rnf (Exts.Ident l s) = rnf l `seq` rnf s + rnf (Exts.Symbol l s) = rnf l `seq` rnf s + +instance NFData Boxed where + rnf Boxed = () + rnf Unboxed = () + +instance NFData l => NFData (SpecialCon l) where + rnf (UnitCon l) = rnf l + rnf (ListCon l) = rnf l + rnf (FunCon l) = rnf l + rnf (TupleCon l b i) = rnf l `seq` rnf b `seq` rnf i + rnf (Cons l) = rnf l + rnf (UnboxedSingleCon l) = rnf l +#if MIN_VERSION_haskell_src_exts(1,20,0) + rnf (ExprHole l) = rnf l +#endif + +instance NFData l => NFData (QName l) where + rnf (Qual l m n) = rnf l `seq` rnf m `seq` rnf n + rnf (UnQual l n) = rnf l `seq` rnf n + rnf (Special l s) = rnf l `seq` rnf s + +-- | Import +data Import = Import { + _importPosition :: Position, -- source line of import + _importName :: Text, -- imported module name + _importQualified :: Bool, -- is import qualified + _importAs :: Maybe Text } -- alias of import + deriving (Eq, Ord) + +instance NFData Import where + rnf (Import p n q a) = rnf p `seq` rnf n `seq` rnf q `seq` rnf a + +instance Show Import where + show (Import _ n q a) = concat $ catMaybes [ + Just "import", + "qualified" `justIf` q, + Just $ show n, + fmap (("as " ++) . show) a] + +instance ToJSON Import where + toJSON (Import p n q a) = object [ + "pos" .= p, + "name" .= n, + "qualified" .= q, + "as" .= a] + +instance FromJSON Import where + parseJSON = withObject "import" $ \v -> Import <$> + v .:: "pos" <*> + v .:: "name" <*> + v .:: "qualified" <*> + v .:: "as" + +-- | Module +data Module = Module { + _moduleId :: ModuleId, + _moduleDocs :: Maybe Text, + _moduleImports :: [Import], -- list of module names imported + _moduleExports :: [Symbol], -- exported module symbols + _moduleFixities :: [Fixity], -- fixities of operators + _moduleScope :: Map Name [Symbol], -- symbols in scope, only for source modules + _moduleSource :: Maybe Parsed } -- source of module + +-- | Make each symbol appear only once +moduleSymbols :: Traversal' Module Symbol +moduleSymbols f m = getBack <$> (each . _1) f revList where + revList = M.toList $ M.unionsWith mappend $ concat [ + [M.singleton sym ([], Any True) | sym <- _moduleExports m], + [M.singleton sym ([nm], Any False) | (nm, syms) <- M.toList (_moduleScope m), sym <- syms]] + getBack syms = m { + _moduleExports = [sym' | (sym', (_, Any True)) <- syms], + _moduleScope = M.unionsWith (++) [M.singleton n [sym'] | (sym', (ns, _)) <- syms, n <- ns] } + +exportedSymbols :: Traversal' Module Symbol +exportedSymbols f m = (\e -> m { _moduleExports = e }) <$> traverse f (_moduleExports m) + +scopeSymbols :: Traversal' Module (Symbol, [Name]) +scopeSymbols f m = (\s -> m { _moduleScope = invMap s }) <$> traverse f (M.toList . invMap . M.toList $ _moduleScope m) where + invMap :: Ord b => [(a, [b])] -> Map b [a] + invMap es = M.unionsWith (++) [M.singleton v [k] | (k, vs) <- es, v <- vs] + +fixitiesMap :: Lens' Module (Map Name Fixity) +fixitiesMap = lens g' s' where + g' m = mconcat [M.singleton n f | f@(Fixity _ _ n) <- _moduleFixities m] + s' m m' = m { _moduleFixities = M.elems m' } + +instance ToJSON (Assoc ()) where + toJSON (AssocNone _) = toJSON ("none" :: String) + toJSON (AssocLeft _) = toJSON ("left" :: String) + toJSON (AssocRight _) = toJSON ("right" :: String) + +instance FromJSON (Assoc ()) where + parseJSON = withText "assoc" $ \txt -> msum [ + guard (txt == "none") >> return (AssocNone ()), + guard (txt == "left") >> return (AssocLeft ()), + guard (txt == "right") >> return (AssocRight ())] + +instance ToJSON Fixity where + toJSON (Fixity assoc pr n) = object $ noNulls [ + "assoc" .= assoc, + "prior" .= pr, + "name" .= fromName n] + +instance FromJSON Fixity where + parseJSON = withObject "fixity" $ \v -> Fixity <$> + v .:: "assoc" <*> + v .:: "prior" <*> + (toName <$> v .:: "name") + +instance ToJSON Module where + toJSON m = object $ noNulls [ + "id" .= _moduleId m, + "docs" .= _moduleDocs m, + "imports" .= _moduleImports m, + "exports" .= _moduleExports m, + "fixities" .= _moduleFixities m] + +instance FromJSON Module where + parseJSON = withObject "module" $ \v -> Module <$> + v .:: "id" <*> + v .::? "docs" <*> + v .::?! "imports" <*> + v .::?! "exports" <*> + v .::?! "fixities" <*> + pure mempty <*> + pure Nothing + +instance NFData (Assoc ()) where + rnf (AssocNone _) = () + rnf (AssocLeft _) = () + rnf (AssocRight _) = () + +instance NFData Fixity where + rnf (Fixity assoc pr n) = rnf assoc `seq` rnf pr `seq` rnf n + +instance NFData Module where + rnf (Module i d is e fs s msrc) = msrc `seq` rnf i `seq` rnf d `seq` rnf is `seq` rnf e `seq` rnf fs `seq` rnf s + +instance Eq Module where + l == r = _moduleId l == _moduleId r + +instance Ord Module where + compare l r = compare (_moduleId l) (_moduleId r) + +instance Show Module where + show = show . _moduleId + +data Symbol = Symbol { + _symbolId :: SymbolId, + _symbolDocs :: Maybe Text, + _symbolPosition :: Maybe Position, + _symbolInfo :: SymbolInfo } + +instance Eq Symbol where + l == r = (_symbolId l, symbolType l) == (_symbolId r, symbolType r) + +instance Ord Symbol where + compare l r = compare (_symbolId l, symbolType l) (_symbolId r, symbolType r) + +instance NFData Symbol where + rnf (Symbol i d l info) = rnf i `seq` rnf d `seq` rnf l `seq` rnf info + +instance Show Symbol where + show = show . _symbolId + +instance ToJSON Symbol where + toJSON s = object $ noNulls [ + "id" .= _symbolId s, + "docs" .= _symbolDocs s, + "pos" .= _symbolPosition s, + "info" .= _symbolInfo s] + +instance FromJSON Symbol where + parseJSON = withObject "symbol" $ \v -> Symbol <$> + v .:: "id" <*> + v .::? "docs" <*> + v .::? "pos" <*> + v .:: "info" + +data SymbolInfo = + Function { _functionType :: Maybe Text } | + Method { _functionType :: Maybe Text, _parentClass :: Text } | + Selector { _functionType :: Maybe Text, _parentType :: Text, _selectorConstructors :: [Text] } | + Constructor { _typeArgs :: [Text], _parentType :: Text } | + Type { _typeArgs :: [Text], _typeContext :: [Text] } | + NewType { _typeArgs :: [Text], _typeContext :: [Text] } | + Data { _typeArgs :: [Text], _typeContext :: [Text] } | + Class { _typeArgs :: [Text], _typeContext :: [Text] } | + TypeFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } | + DataFam { _typeArgs :: [Text], _typeContext :: [Text], _familyAssociate :: Maybe Text } | + PatConstructor { _typeArgs :: [Text], _patternType :: Maybe Text } | + PatSelector { _functionType :: Maybe Text, _patternType :: Maybe Text, _patternConstructor :: Text } + deriving (Eq, Ord, Read, Show) + +instance NFData SymbolInfo where + rnf (Function ft) = rnf ft + rnf (Method ft cls) = rnf ft `seq` rnf cls + rnf (Selector ft t cs) = rnf ft `seq` rnf t `seq` rnf cs + rnf (Constructor as t) = rnf as `seq` rnf t + rnf (Type as ctx) = rnf as `seq` rnf ctx + rnf (NewType as ctx) = rnf as `seq` rnf ctx + rnf (Data as ctx) = rnf as `seq` rnf ctx + rnf (Class as ctx) = rnf as `seq` rnf ctx + rnf (TypeFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a + rnf (DataFam as ctx a) = rnf as `seq` rnf ctx `seq` rnf a + rnf (PatConstructor as t) = rnf as `seq` rnf t + rnf (PatSelector ft t c) = rnf ft `seq` rnf t `seq` rnf c + +instance ToJSON SymbolInfo where + toJSON (Function ft) = object [what "function", "type" .= ft] + toJSON (Method ft cls) = object [what "method", "type" .= ft, "class" .= cls] + toJSON (Selector ft t cs) = object [what "selector", "type" .= ft, "parent" .= t, "constructors" .= cs] + toJSON (Constructor as t) = object [what "ctor", "args" .= as, "type" .= t] + toJSON (Type as ctx) = object [what "type", "args" .= as, "ctx" .= ctx] + toJSON (NewType as ctx) = object [what "newtype", "args" .= as, "ctx" .= ctx] + toJSON (Data as ctx) = object [what "data", "args" .= as, "ctx" .= ctx] + toJSON (Class as ctx) = object [what "class", "args" .= as, "ctx" .= ctx] + toJSON (TypeFam as ctx a) = object [what "type-family", "args" .= as, "ctx" .= ctx, "associate" .= a] + toJSON (DataFam as ctx a) = object [what "data-family", "args" .= as, "ctx" .= ctx, "associate" .= a] + toJSON (PatConstructor as t) = object [what "pat-ctor", "args" .= as, "pat-type" .= t] + toJSON (PatSelector ft t c) = object [what "pat-selector", "type" .= ft, "pat-type" .= t, "constructor" .= c] + +class EmptySymbolInfo a where + infoOf :: a -> SymbolInfo + +instance EmptySymbolInfo SymbolInfo where + infoOf = id + +instance (Monoid a, EmptySymbolInfo r) => EmptySymbolInfo (a -> r) where + infoOf f = infoOf $ f mempty + +symbolInfoType :: SymbolInfo -> String +symbolInfoType (Function{}) = "function" +symbolInfoType (Method{}) = "method" +symbolInfoType (Selector{}) = "selector" +symbolInfoType (Constructor{}) = "ctor" +symbolInfoType (Type{}) = "type" +symbolInfoType (NewType{}) = "newtype" +symbolInfoType (Data{}) = "data" +symbolInfoType (Class{}) = "class" +symbolInfoType (TypeFam{}) = "type-family" +symbolInfoType (DataFam{}) = "data-family" +symbolInfoType (PatConstructor{}) = "pat-ctor" +symbolInfoType (PatSelector{}) = "pat-selector" + +symbolType :: Symbol -> String +symbolType = symbolInfoType . _symbolInfo + +what :: String -> Pair +what n = "what" .= n + +instance FromJSON SymbolInfo where + parseJSON = withObject "symbol info" $ \v -> msum [ + gwhat "function" v >> (Function <$> v .::? "type"), + gwhat "method" v >> (Method <$> v .::? "type" <*> v .:: "class"), + gwhat "selector" v >> (Selector <$> v .::? "type" <*> v .:: "parent" <*> v .::?! "constructors"), + gwhat "ctor" v >> (Constructor <$> v .::?! "args" <*> v .:: "type"), + gwhat "type" v >> (Type <$> v .::?! "args" <*> v .::?! "ctx"), + gwhat "newtype" v >> (NewType <$> v .::?! "args" <*> v .::?! "ctx"), + gwhat "data" v >> (Data <$> v .::?! "args" <*> v .::?! "ctx"), + gwhat "class" v >> (Class <$> v .::?! "args" <*> v .::?! "ctx"), + gwhat "type-family" v >> (TypeFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"), + gwhat "data-family" v >> (DataFam <$> v .::?! "args" <*> v .::?! "ctx" <*> v .::? "associate"), + gwhat "pat-ctor" v >> (PatConstructor <$> v .::?! "args" <*> v .::? "pat-type"), + gwhat "pat-selector" v >> (PatSelector <$> v .::? "type" <*> v .::? "pat-type" <*> v .:: "constructor")] + +gwhat :: String -> Object -> Parser () +gwhat n v = do + s <- v .:: "what" + guard (s == n) + +-- | Scoped entity with qualifier +data Scoped a = Scoped { + _scopeQualifier :: Maybe Text, + _scoped :: a } + deriving (Eq, Ord) + +instance Show a => Show (Scoped a) where + show (Scoped q s) = maybe "" (\q' -> T.unpack q' ++ ".") q ++ show s + +instance ToJSON a => ToJSON (Scoped a) where + toJSON (Scoped q s) = toJSON s `objectUnion` object (noNulls ["qualifier" .= q]) + +instance FromJSON a => FromJSON (Scoped a) where + parseJSON = withObject "scope-symbol" $ \v -> Scoped <$> + (v .::? "qualifier") <*> + parseJSON (Object v) + +-- | Symbol usage +data SymbolUsage = SymbolUsage { + _symbolUsed :: Symbol, + _symbolUsedQualifier :: Maybe Text, + _symbolUsedIn :: ModuleId, + _symbolUsedRegion :: Region } + deriving (Eq, Ord) + +instance Show SymbolUsage where + show (SymbolUsage s _ m p) = show s ++ " at " ++ show m ++ ":" ++ show p + +instance ToJSON SymbolUsage where + toJSON (SymbolUsage s q m p) = object $ noNulls ["symbol" .= s, "qualifier" .= q, "in" .= m, "at" .= p] + +instance FromJSON SymbolUsage where + parseJSON = withObject "symbol-usage" $ \v -> SymbolUsage <$> + v .:: "symbol" <*> + v .::? "qualifier" <*> + v .:: "in" <*> + v .:: "at" + +-- | Symbol with module it's exported from +data ImportedSymbol = ImportedSymbol { + _importedSymbol :: Symbol, + _importedFrom :: ModuleId } + deriving (Eq, Ord) + +instance Show ImportedSymbol where + show (ImportedSymbol s m) = show s ++ " imported from " ++ show m + +instance ToJSON ImportedSymbol where + toJSON (ImportedSymbol s m) = objectUnion (toJSON s) $ object [ + "imported" .= m] + +instance FromJSON ImportedSymbol where + parseJSON = withObject "imported-symbol" $ \v -> ImportedSymbol <$> + parseJSON (Object v) <*> + v .:: "imported" + +-- | Inspection data +data Inspection = + -- | No inspection + InspectionNone | + -- | Time and flags of inspection + InspectionAt { + _inspectionAt :: POSIXTime, + _inspectionOpts :: [Text] } + deriving (Eq, Ord) + +instance NFData Inspection where + rnf InspectionNone = () + rnf (InspectionAt t fs) = rnf t `seq` rnf fs + +instance Show Inspection where + show InspectionNone = "none" + show (InspectionAt tm fs) = "mtime " ++ show tm ++ ", flags [" ++ intercalate ", " (map T.unpack fs) ++ "]" + +instance Read POSIXTime where + readsPrec i = map (first (fromIntegral :: Integer -> POSIXTime)) . readsPrec i + +instance Semigroup Inspection where + InspectionNone <> r = r + l <> InspectionNone = l + InspectionAt ltm lopts <> InspectionAt rtm ropts + | ltm >= rtm = InspectionAt ltm lopts + | otherwise = InspectionAt rtm ropts + +instance Monoid Inspection where + mempty = InspectionNone + mappend l r = l <> r + +instance ToJSON Inspection where + toJSON InspectionNone = object ["inspected" .= False] + toJSON (InspectionAt tm fs) = object [ + "mtime" .= (fromRational (toRational tm) :: Double), + "flags" .= fs] + +instance FromJSON Inspection where + parseJSON = withObject "inspection" $ \v -> + ((const InspectionNone :: Bool -> Inspection) <$> v .:: "inspected") <|> + (InspectionAt <$> ((fromRational . (toRational :: Double -> Rational)) <$> v .:: "mtime") <*> (v .:: "flags")) + +-- | Is left @Inspection@ fresh comparing to right one +fresh :: Inspection -> Inspection -> Bool +fresh InspectionNone InspectionNone = True +fresh InspectionNone _ = False +fresh _ InspectionNone = True +fresh (InspectionAt tm _) (InspectionAt tm' _) = tm' - tm < 0.01 + +-- | Inspected entity +data Inspected k t a = Inspected { + _inspection :: Inspection, + _inspectedKey :: k, + _inspectionTags :: Set t, + _inspectionResult :: Either HsDevError a } + +inspectedTup :: Inspected k t a -> (Inspection, k, Set t, Maybe a) +inspectedTup (Inspected insp i tags res) = (insp, i, tags, either (const Nothing) Just res) + +instance (Eq k, Eq t, Eq a) => Eq (Inspected k t a) where + (==) = (==) `on` inspectedTup + +instance (Ord k, Ord t, Ord a) => Ord (Inspected k t a) where + compare = comparing inspectedTup + +instance Functor (Inspected k t) where + fmap f insp = insp { + _inspectionResult = fmap f (_inspectionResult insp) } + +instance Foldable (Inspected k t) where + foldMap f = either mempty f . _inspectionResult + +instance Traversable (Inspected k t) where + traverse f (Inspected insp i ts r) = Inspected insp i ts <$> either (pure . Left) (liftA Right . f) r + +instance (NFData k, NFData t, NFData a) => NFData (Inspected k t a) where + rnf (Inspected t i ts r) = rnf t `seq` rnf i `seq` rnf ts `seq` rnf r + +instance (ToJSON k, ToJSON t, ToJSON a) => ToJSON (Inspected k t a) where + toJSON im = object [ + "inspection" .= _inspection im, + "location" .= _inspectedKey im, + "tags" .= S.toList (_inspectionTags im), + either ("error" .=) ("result" .=) (_inspectionResult im)] + +instance (FromJSON k, Ord t, FromJSON t, FromJSON a) => FromJSON (Inspected k t a) where + parseJSON = withObject "inspected" $ \v -> Inspected <$> + v .:: "inspection" <*> + v .:: "location" <*> + (S.fromList <$> (v .::?! "tags")) <*> + ((Left <$> v .:: "error") <|> (Right <$> v .:: "result")) + +newtype InspectM k t m a = InspectM { runInspectM :: ReaderT k (ExceptT HsDevError (StateT (Inspection, S.Set t) m)) a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadReader k, MonadError HsDevError, MonadState (Inspection, S.Set t)) + +instance MonadTrans (InspectM k t) where + lift = InspectM . lift . lift . lift + +runInspect :: (Monad m, Ord t) => k -> InspectM k t m a -> m (Inspected k t a) +runInspect key act = do + (res, (insp, ts)) <- flip runStateT (InspectionNone, mempty) . runExceptT . flip runReaderT key . runInspectM $ act + return $ Inspected insp key ts res + +-- | Continue inspection +continueInspect :: (Monad m, Ord t) => Inspected k t a -> (a -> InspectM k t m b) -> m (Inspected k t b) +continueInspect start act = runInspect (_inspectedKey start) $ do + put (_inspection start, _inspectionTags start) + val <- either throwError return $ _inspectionResult start + act val + +inspect :: MonadCatch m => m Inspection -> (k -> m a) -> InspectM k t m a +inspect insp act = withInspection insp $ do + key <- ask + lift (hsdevCatch (hsdevLiftIO $ act key)) >>= either throwError return + +withInspection :: MonadCatch m => m Inspection -> InspectM k t m a -> InspectM k t m a +withInspection insp inner = do + insp' <- lift insp + let + setInsp = modify (set _1 insp') + catchError (inner <* setInsp) (\e -> setInsp >> throwError e) + +inspect_ :: MonadCatch m => m Inspection -> m a -> InspectM k t m a +inspect_ insp = inspect insp . const + +-- | Empty tags +noTags :: Set t +noTags = S.empty + +-- | One tag +tag :: t -> Set t +tag = S.singleton + +data ModuleTag = InferredTypesTag | RefinedDocsTag | OnlyHeaderTag | DirtyTag | ResolvedNamesTag deriving (Eq, Ord, Read, Show, Enum, Bounded) + +instance NFData ModuleTag where + rnf InferredTypesTag = () + rnf RefinedDocsTag = () + rnf OnlyHeaderTag = () + rnf DirtyTag = () + rnf ResolvedNamesTag = () + +instance Display ModuleTag where + display InferredTypesTag = "types" + display RefinedDocsTag = "docs" + display OnlyHeaderTag = "header" + display DirtyTag = "dirty" + display ResolvedNamesTag = "resolved" + displayType _ = "module-tag" + +instance ToJSON ModuleTag where + toJSON InferredTypesTag = toJSON ("types" :: String) + toJSON RefinedDocsTag = toJSON ("docs" :: String) + toJSON OnlyHeaderTag = toJSON ("header" :: String) + toJSON DirtyTag = toJSON ("dirty" :: String) + toJSON ResolvedNamesTag = toJSON ("resolved" :: String) + +instance FromJSON ModuleTag where + parseJSON = withText "module-tag" $ \txt -> msum [ + guard (txt == "types") >> return InferredTypesTag, + guard (txt == "docs") >> return RefinedDocsTag, + guard (txt == "header") >> return OnlyHeaderTag, + guard (txt == "dirty") >> return DirtyTag, + guard (txt == "resolved") >> return ResolvedNamesTag] + +-- | Inspected module +type InspectedModule = Inspected ModuleLocation ModuleTag Module + +instance Show InspectedModule where + show (Inspected i mi ts m) = unlines [either showError show m, "\tinspected: " ++ show i, "\ttags: " ++ intercalate ", " (map show $ S.toList ts)] where + showError :: HsDevError -> String + showError e = unlines $ ("\terror: " ++ show e) : case mi of + FileModule f p -> ["file: " ++ f ^. path, "project: " ++ maybe "" (view (projectPath . path)) p] + InstalledModule c p n _ -> ["cabal: " ++ show c, "package: " ++ show p, "name: " ++ T.unpack n] + OtherLocation src -> ["other location: " ++ T.unpack src] + NoLocation -> ["no location"] + +notInspected :: ModuleLocation -> InspectedModule +notInspected mloc = Inspected mempty mloc noTags (Left $ NotInspected mloc) + +instance Documented ModuleId where + brief m = brief $ _moduleLocation m + detailed = brief + +instance Documented SymbolId where + brief s = "{} from {}" ~~ _symbolName s ~~ brief (_symbolModule s) + detailed = brief + +instance Documented Module where + brief = brief . _moduleId + detailed m = T.unlines (brief m : info) where + info = [ + "\texports: {}" ~~ T.intercalate ", " (map brief (_moduleExports m))] + +instance Documented Symbol where + brief = brief . _symbolId + detailed s = T.unlines [brief s, info] where + info = case _symbolInfo s of + Function t -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "function", fmap ("type: {}" ~~) t]) + Method t p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "method", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p]) + Selector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "selector", fmap ("type: {}" ~~) t, Just $ "parent: {}" ~~ p]) + Constructor args p -> "\t" `T.append` T.intercalate ", " ["constructor", "args: {}" ~~ T.unwords args, "parent: {}" ~~ p] + Type args ctx -> "\t" `T.append` T.intercalate ", " ["type", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] + NewType args ctx -> "\t" `T.append` T.intercalate ", " ["newtype", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] + Data args ctx -> "\t" `T.append` T.intercalate ", " ["data", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] + Class args ctx -> "\t" `T.append` T.intercalate ", " ["class", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] + TypeFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["type family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] + DataFam args ctx _ -> "\t" `T.append` T.intercalate ", " ["data family", "args: {}" ~~ T.unwords args, "ctx: {}" ~~ T.unwords ctx] + PatConstructor args p -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern constructor", Just $ "args: {}" ~~ T.unwords args, fmap ("pat-type: {}" ~~) p]) + PatSelector t p _ -> "\t" `T.append` T.intercalate ", " (catMaybes [Just "pattern selector", fmap ("type: {}" ~~) t, fmap ("pat-type: {}" ~~) p]) + +makeLenses ''Import +makeLenses ''Module +makeLenses ''Symbol +makeLenses ''SymbolInfo +makeLenses ''Scoped +makeLenses ''SymbolUsage +makeLenses ''ImportedSymbol +makeLenses ''Inspection +makeLenses ''Inspected + +inspected :: Traversal (Inspected k t a) (Inspected k t b) a b +inspected = inspectionResult . _Right + +nullifyInfo :: SymbolInfo -> SymbolInfo +nullifyInfo = chain [ + set functionType mempty, + set parentClass mempty, + set parentType mempty, + set selectorConstructors mempty, + set typeArgs mempty, + set typeContext mempty, + set familyAssociate mempty, + set patternType mempty, + set patternConstructor mempty] + +instance Sourced Module where + sourcedName = moduleId . moduleName + sourcedDocs = moduleDocs . _Just + sourcedModule = moduleId + +instance Sourced Symbol where + sourcedName = symbolId . symbolName + sourcedDocs = symbolDocs . _Just + sourcedModule = symbolId . symbolModule + sourcedLocation = symbolPosition . _Just diff --git a/src/HsDev/Tools/AutoFix.hs b/src/HsDev/Tools/AutoFix.hs --- a/src/HsDev/Tools/AutoFix.hs +++ b/src/HsDev/Tools/AutoFix.hs @@ -1,67 +1,67 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Tools.AutoFix ( - corrections, - CorrectorMatch, - correctors, - match, - findCorrector, - - module Data.Text.Region, - module HsDev.Tools.Refact, - module HsDev.Tools.Types - ) where - -import Control.Applicative -import Control.Lens hiding ((.=), at) -import Data.Maybe (listToMaybe, mapMaybe) -import Data.String (fromString) -import Data.Text (Text) -import Data.Text.Lens (unpacked) -import Data.Text.Region hiding (Region(..), update) -import qualified Data.Text.Region as R - -import HsDev.Tools.Refact -import HsDev.Tools.Base -import HsDev.Tools.Types - -instance Regioned a => Regioned (Note a) where - regions = note . regions - -corrections :: [Note OutputMessage] -> [Note Refact] -corrections = mapMaybe toRefact where - toRefact :: Note OutputMessage -> Maybe (Note Refact) - toRefact n = useSuggestion <|> findCorrector n where - -- Use existing suggestion - useSuggestion :: Maybe (Note Refact) - useSuggestion = do - sugg <- view (note . messageSuggestion) n - return $ set - note - (Refact - (view (note . message) n) - (replace (fromRegion $ view noteRegion n) sugg)) - n - -type CorrectorMatch = Note OutputMessage -> Maybe (Note Refact) - -correctors :: [CorrectorMatch] -correctors = [ - match "^The (?:qualified )?import of .([\\w\\.]+). is redundant" $ \_ rgn -> Refact -- There are different quotes in Windows/Linux - "Redundant import" - (cut - (expandLines rgn)), - match "^(.*?)\nFound:\n (.*?)\nWhy not:\n (.*?)$" $ \g rgn -> Refact - (g `at` 1) - (replace - ((rgn ^. regionFrom) `regionSize` pt 0 (contentsLength $ g `at` 2)) - (g `at` 3))] - -match :: String -> ((Int -> Maybe Text) -> R.Region -> Refact) -> CorrectorMatch -match pat f n = do - g <- matchRx pat (view (note . message . unpacked) n) - return $ set note (f (fmap fromString . g) (fromRegion $ view noteRegion n)) n - -findCorrector :: Note OutputMessage -> Maybe (Note Refact) -findCorrector n = listToMaybe $ mapMaybe ($ n) correctors +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Tools.AutoFix ( + corrections, + CorrectorMatch, + correctors, + match, + findCorrector, + + module Data.Text.Region, + module HsDev.Tools.Refact, + module HsDev.Tools.Types + ) where + +import Control.Applicative +import Control.Lens hiding ((.=), at) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.String (fromString) +import Data.Text (Text) +import Data.Text.Lens (unpacked) +import Data.Text.Region hiding (Region(..), update) +import qualified Data.Text.Region as R + +import HsDev.Tools.Refact +import HsDev.Tools.Base +import HsDev.Tools.Types + +instance Regioned a => Regioned (Note a) where + regions = note . regions + +corrections :: [Note OutputMessage] -> [Note Refact] +corrections = mapMaybe toRefact where + toRefact :: Note OutputMessage -> Maybe (Note Refact) + toRefact n = useSuggestion <|> findCorrector n where + -- Use existing suggestion + useSuggestion :: Maybe (Note Refact) + useSuggestion = do + sugg <- view (note . messageSuggestion) n + return $ set + note + (Refact + (view (note . message) n) + (replace (fromRegion $ view noteRegion n) sugg)) + n + +type CorrectorMatch = Note OutputMessage -> Maybe (Note Refact) + +correctors :: [CorrectorMatch] +correctors = [ + match "^The (?:qualified )?import of .([\\w\\.]+). is redundant" $ \_ rgn -> Refact -- There are different quotes in Windows/Linux + "Redundant import" + (cut + (expandLines rgn)), + match "^(.*?)\nFound:\n (.*?)\nWhy not:\n (.*?)$" $ \g rgn -> Refact + (g `at` 1) + (replace + ((rgn ^. regionFrom) `regionSize` pt 0 (contentsLength $ g `at` 2)) + (g `at` 3))] + +match :: String -> ((Int -> Maybe Text) -> R.Region -> Refact) -> CorrectorMatch +match pat f n = do + g <- matchRx pat (view (note . message . unpacked) n) + return $ set note (f (fmap fromString . g) (fromRegion $ view noteRegion n)) n + +findCorrector :: Note OutputMessage -> Maybe (Note Refact) +findCorrector n = listToMaybe $ mapMaybe ($ n) correctors diff --git a/src/HsDev/Tools/Base.hs b/src/HsDev/Tools/Base.hs --- a/src/HsDev/Tools/Base.hs +++ b/src/HsDev/Tools/Base.hs @@ -1,87 +1,87 @@ -module HsDev.Tools.Base ( - runTool, runTool_, - Result, ToolM, - runWait, runWait_, - tool, tool_, - matchRx, splitRx, replaceRx, - at, at_, - - module HsDev.Tools.Types - ) where - -import Control.Monad.Except -import Data.Array (assocs) -import Data.List (unfoldr, intercalate) -import Data.Maybe (fromMaybe) -import Data.String -import System.Exit -import System.Process -import Text.Regex.PCRE ((=~), MatchResult(..)) - -import HsDev.Error -import HsDev.Tools.Types -import HsDev.Util (liftIOErrors) - --- | Run tool, throwing HsDevError on fail -runTool :: FilePath -> [String] -> String -> IO String -runTool name args input = hsdevLiftIOWith onIOError $ do - (code, out, err) <- readProcessWithExitCode name args input - case code of - ExitFailure ecode -> hsdevError $ ToolError name $ - "exited with code " ++ show ecode ++ ": " ++ err - ExitSuccess -> return out - where - onIOError s = ToolError name $ unlines [ - "args: [" ++ intercalate ", " args ++ "]", - "stdin: " ++ input, - "error: " ++ s] - --- | Run tool with not stdin -runTool_ :: FilePath -> [String] -> IO String -runTool_ name args = runTool name args "" - -type Result = Either String String -type ToolM a = ExceptT String IO a - --- | Run command and wait for result -runWait :: FilePath -> [String] -> String -> IO Result -runWait name args input = do - (code, out, err) <- readProcessWithExitCode name args input - return $ if code == ExitSuccess && not (null out) then Right out else Left err - --- | Run command with no input -runWait_ :: FilePath -> [String] -> IO Result -runWait_ name args = runWait name args "" - --- | Tool -tool :: FilePath -> [String] -> String -> ToolM String -tool name args input = liftIOErrors $ ExceptT $ runWait name args input - --- | Tool with no input -tool_ :: FilePath -> [String] -> ToolM String -tool_ name args = tool name args "" - -matchRx :: String -> String -> Maybe (Int -> Maybe String) -matchRx pat str = if matched then Just look else Nothing where - m :: MatchResult String - m = str =~ pat - matched = not $ null $ mrMatch m - groups = filter (not . null . snd) $ assocs $ mrSubs m - look i = lookup i groups - -splitRx :: String -> String -> [String] -splitRx pat = unfoldr split' . Just where - split' :: Maybe String -> Maybe (String, Maybe String) - split' Nothing = Nothing - split' (Just str) = case str =~ pat of - (pre, "", "") -> Just (pre, Nothing) - (pre, _, post) -> Just (pre, Just post) - -replaceRx :: String -> String -> String -> String -replaceRx pat w = intercalate w . splitRx pat - -at :: (Int -> Maybe a) -> Int -> a -at g i = fromMaybe (error $ "Can't find group " ++ show i) $ g i - -at_ :: IsString s => (Int -> Maybe s) -> Int -> s -at_ g = fromMaybe (fromString "") . g +module HsDev.Tools.Base ( + runTool, runTool_, + Result, ToolM, + runWait, runWait_, + tool, tool_, + matchRx, splitRx, replaceRx, + at, at_, + + module HsDev.Tools.Types + ) where + +import Control.Monad.Except +import Data.Array (assocs) +import Data.List (unfoldr, intercalate) +import Data.Maybe (fromMaybe) +import Data.String +import System.Exit +import System.Process +import Text.Regex.PCRE ((=~), MatchResult(..)) + +import HsDev.Error +import HsDev.Tools.Types +import HsDev.Util (liftIOErrors) + +-- | Run tool, throwing HsDevError on fail +runTool :: FilePath -> [String] -> String -> IO String +runTool name args input = hsdevLiftIOWith onIOError $ do + (code, out, err) <- readProcessWithExitCode name args input + case code of + ExitFailure ecode -> hsdevError $ ToolError name $ + "exited with code " ++ show ecode ++ ": " ++ err + ExitSuccess -> return out + where + onIOError s = ToolError name $ unlines [ + "args: [" ++ intercalate ", " args ++ "]", + "stdin: " ++ input, + "error: " ++ s] + +-- | Run tool with not stdin +runTool_ :: FilePath -> [String] -> IO String +runTool_ name args = runTool name args "" + +type Result = Either String String +type ToolM a = ExceptT String IO a + +-- | Run command and wait for result +runWait :: FilePath -> [String] -> String -> IO Result +runWait name args input = do + (code, out, err) <- readProcessWithExitCode name args input + return $ if code == ExitSuccess && not (null out) then Right out else Left err + +-- | Run command with no input +runWait_ :: FilePath -> [String] -> IO Result +runWait_ name args = runWait name args "" + +-- | Tool +tool :: FilePath -> [String] -> String -> ToolM String +tool name args input = liftIOErrors $ ExceptT $ runWait name args input + +-- | Tool with no input +tool_ :: FilePath -> [String] -> ToolM String +tool_ name args = tool name args "" + +matchRx :: String -> String -> Maybe (Int -> Maybe String) +matchRx pat str = if matched then Just look else Nothing where + m :: MatchResult String + m = str =~ pat + matched = not $ null $ mrMatch m + groups = filter (not . null . snd) $ assocs $ mrSubs m + look i = lookup i groups + +splitRx :: String -> String -> [String] +splitRx pat = unfoldr split' . Just where + split' :: Maybe String -> Maybe (String, Maybe String) + split' Nothing = Nothing + split' (Just str) = case str =~ pat of + (pre, "", "") -> Just (pre, Nothing) + (pre, _, post) -> Just (pre, Just post) + +replaceRx :: String -> String -> String -> String +replaceRx pat w = intercalate w . splitRx pat + +at :: (Int -> Maybe a) -> Int -> a +at g i = fromMaybe (error $ "Can't find group " ++ show i) $ g i + +at_ :: IsString s => (Int -> Maybe s) -> Int -> s +at_ g = fromMaybe (fromString "") . g diff --git a/src/HsDev/Tools/Cabal.hs b/src/HsDev/Tools/Cabal.hs --- a/src/HsDev/Tools/Cabal.hs +++ b/src/HsDev/Tools/Cabal.hs @@ -1,85 +1,85 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} - -module HsDev.Tools.Cabal ( - CabalPackage(..), - cabalList, - - -- * Reexports - Version, License(..) - ) where - -import Control.Arrow -import Control.Monad -import Data.Aeson -import Data.Char (isSpace) -import Data.Maybe -import Distribution.License -import Distribution.Text -import Distribution.Version - -import HsDev.Tools.Base -import HsDev.Util - -data CabalPackage = CabalPackage { - cabalPackageName :: String, - cabalPackageSynopsis :: Maybe String, - cabalPackageDefaultVersion :: Maybe Version, - cabalPackageInstalledVersions :: [Version], - cabalPackageHomepage :: Maybe String, - cabalPackageLicense :: Maybe License } - deriving (Eq, Read, Show) - -instance ToJSON CabalPackage where - toJSON cp = object [ - "name" .= cabalPackageName cp, - "synopsis" .= cabalPackageSynopsis cp, - "default-version" .= fmap display (cabalPackageDefaultVersion cp), - "installed-versions" .= map display (cabalPackageInstalledVersions cp), - "homepage" .= cabalPackageHomepage cp, - "license" .= fmap display (cabalPackageLicense cp)] - -instance FromJSON CabalPackage where - parseJSON = withObject "cabal-package" $ \v -> CabalPackage <$> - (v .:: "name") <*> - (v .:: "synopsis") <*> - ((join . fmap simpleParse) <$> (v .:: "default-version")) <*> - (mapMaybe simpleParse <$> (v .:: "installed-versions")) <*> - (v .:: "homepage") <*> - ((join . fmap simpleParse) <$> (v .:: "license")) - -cabalList :: [String] -> ToolM [CabalPackage] -cabalList queries = do -#if mingw32_HOST_OS - rs <- liftM (split (all isSpace) . lines) $ tool_ "powershell" [ - "-Command", - unwords (["&", "{", "chcp 65001 | out-null;", "cabal list"] ++ queries ++ ["}"])] -#else - rs <- liftM (split (all isSpace) . lines) $ tool_ "cabal" ("list" : queries) -#endif - return $ map toPackage $ mapMaybe parseFields rs - where - toPackage :: (String, [(String, String)]) -> CabalPackage - toPackage (name, fs) = CabalPackage { - cabalPackageName = name, - cabalPackageSynopsis = lookup "Synopsis" fs, - cabalPackageDefaultVersion = (lookup "Default available version" fs >>= simpleParse), - cabalPackageInstalledVersions = fromMaybe [] (lookup "Installed versions" fs >>= mapM (simpleParse . trim) . split (== ',')), - cabalPackageHomepage = lookup "Homepage" fs, - cabalPackageLicense = lookup "License" fs >>= simpleParse } - - parseFields :: [String] -> Maybe (String, [(String, String)]) - parseFields [] = Nothing - parseFields (('*':name):fs) = Just (trim name, mapMaybe parseField' fs) where - parseField' :: String -> Maybe (String, String) - parseField' str = case parseField str of - (fname, Just fval) -> Just (fname, fval) - _ -> Nothing - parseFields _ = Nothing - - -- foo: bar → (foo, bar) - parseField :: String -> (String, Maybe String) - parseField = (trim *** (parseValue . trim . drop 1)) . break (== ':') - -- [ ... ] → Nothing, ... → Just ... - parseValue :: String -> Maybe String - parseValue ('[':_) = Nothing - parseValue v = Just v +{-# LANGUAGE OverloadedStrings, CPP #-} + +module HsDev.Tools.Cabal ( + CabalPackage(..), + cabalList, + + -- * Reexports + Version, License(..) + ) where + +import Control.Arrow +import Control.Monad +import Data.Aeson +import Data.Char (isSpace) +import Data.Maybe +import Distribution.License +import Distribution.Text +import Distribution.Version + +import HsDev.Tools.Base +import HsDev.Util + +data CabalPackage = CabalPackage { + cabalPackageName :: String, + cabalPackageSynopsis :: Maybe String, + cabalPackageDefaultVersion :: Maybe Version, + cabalPackageInstalledVersions :: [Version], + cabalPackageHomepage :: Maybe String, + cabalPackageLicense :: Maybe License } + deriving (Eq, Read, Show) + +instance ToJSON CabalPackage where + toJSON cp = object [ + "name" .= cabalPackageName cp, + "synopsis" .= cabalPackageSynopsis cp, + "default-version" .= fmap display (cabalPackageDefaultVersion cp), + "installed-versions" .= map display (cabalPackageInstalledVersions cp), + "homepage" .= cabalPackageHomepage cp, + "license" .= fmap display (cabalPackageLicense cp)] + +instance FromJSON CabalPackage where + parseJSON = withObject "cabal-package" $ \v -> CabalPackage <$> + (v .:: "name") <*> + (v .:: "synopsis") <*> + ((join . fmap simpleParse) <$> (v .:: "default-version")) <*> + (mapMaybe simpleParse <$> (v .:: "installed-versions")) <*> + (v .:: "homepage") <*> + ((join . fmap simpleParse) <$> (v .:: "license")) + +cabalList :: [String] -> ToolM [CabalPackage] +cabalList queries = do +#if mingw32_HOST_OS + rs <- liftM (split (all isSpace) . lines) $ tool_ "powershell" [ + "-Command", + unwords (["&", "{", "chcp 65001 | out-null;", "cabal list"] ++ queries ++ ["}"])] +#else + rs <- liftM (split (all isSpace) . lines) $ tool_ "cabal" ("list" : queries) +#endif + return $ map toPackage $ mapMaybe parseFields rs + where + toPackage :: (String, [(String, String)]) -> CabalPackage + toPackage (name, fs) = CabalPackage { + cabalPackageName = name, + cabalPackageSynopsis = lookup "Synopsis" fs, + cabalPackageDefaultVersion = (lookup "Default available version" fs >>= simpleParse), + cabalPackageInstalledVersions = fromMaybe [] (lookup "Installed versions" fs >>= mapM (simpleParse . trim) . split (== ',')), + cabalPackageHomepage = lookup "Homepage" fs, + cabalPackageLicense = lookup "License" fs >>= simpleParse } + + parseFields :: [String] -> Maybe (String, [(String, String)]) + parseFields [] = Nothing + parseFields (('*':name):fs) = Just (trim name, mapMaybe parseField' fs) where + parseField' :: String -> Maybe (String, String) + parseField' str = case parseField str of + (fname, Just fval) -> Just (fname, fval) + _ -> Nothing + parseFields _ = Nothing + + -- foo: bar → (foo, bar) + parseField :: String -> (String, Maybe String) + parseField = (trim *** (parseValue . trim . drop 1)) . break (== ':') + -- [ ... ] → Nothing, ... → Just ... + parseValue :: String -> Maybe String + parseValue ('[':_) = Nothing + parseValue v = Just v diff --git a/src/HsDev/Tools/ClearImports.hs b/src/HsDev/Tools/ClearImports.hs --- a/src/HsDev/Tools/ClearImports.hs +++ b/src/HsDev/Tools/ClearImports.hs @@ -1,113 +1,113 @@ -module HsDev.Tools.ClearImports ( - dumpMinimalImports, waitImports, cleanTmpImports, - findMinimalImports, - groupImports, splitImport, - clearImports, - - module Control.Monad.Except - ) where - -import Control.Arrow -import Control.Concurrent (threadDelay) -import Control.Exception -import Control.Monad.Except -import Data.Char -import Data.List -import Data.Maybe (mapMaybe) -import Data.Text (unpack) -import System.Directory -import System.FilePath -import qualified Language.Haskell.Exts as Exts - -import GHC -import GHC.Paths (libdir) - -import HsDev.Util -import HsDev.Tools.Ghc.Compat - --- | Dump minimal imports -dumpMinimalImports :: [String] -> FilePath -> ExceptT String IO String -dumpMinimalImports opts f = do - cur <- liftE getCurrentDirectory - file <- liftE $ canonicalizePath f - cts <- liftE $ fmap unpack $ readFileUtf8 file - - mname <- case Exts.parseFileContentsWithMode (pmode file) cts of - Exts.ParseFailed loc err -> throwError $ - "Failed to parse file at " ++ - Exts.prettyPrint loc ++ ":" ++ err - Exts.ParseOk (Exts.Module _ (Just (Exts.ModuleHead _ (Exts.ModuleName _ mname) _ _)) _ _ _) -> return mname - _ -> throwError "Error" - - void $ liftE $ runGhc (Just libdir) $ do - df <- getSessionDynFlags - let - df' = df { - ghcLink = NoLink, - hscTarget = HscNothing, - dumpDir = Just cur, - stubDir = Just cur, - objectDir = Just cur, - hiDir = Just cur } - (df'', _, _) <- parseDynamicFlags df' (map noLoc ("-ddump-minimal-imports" : opts)) - _ <- setSessionDynFlags df'' - cleanupHandler df'' $ do - t <- guessTarget file Nothing - setTargets [t] - load LoadAllTargets - - length mname `seq` return mname - where - pmode :: FilePath -> Exts.ParseMode - pmode f' = Exts.defaultParseMode { - Exts.parseFilename = f', - Exts.baseLanguage = Exts.Haskell2010, - Exts.extensions = Exts.glasgowExts ++ map Exts.parseExtension exts, - Exts.fixities = Just Exts.baseFixities } - exts = mapMaybe (stripPrefix "-X") opts - --- | Read imports from file -waitImports :: FilePath -> IO [String] -waitImports f = retry 1000 $ do - is <- liftM lines $ readFile f - length is `seq` return is - --- | Clean temporary files -cleanTmpImports :: FilePath -> IO () -cleanTmpImports dir = do - dumps <- liftM (filter ((== ".imports") . takeExtension)) $ directoryContents dir - forM_ dumps $ handle ignoreIO' . retry 1000 . removeFile - where - ignoreIO' :: IOException -> IO () - ignoreIO' _ = return () - --- | Dump and read imports -findMinimalImports :: [String] -> FilePath -> ExceptT String IO [String] -findMinimalImports opts f = do - file <- liftE $ canonicalizePath f - mname <- dumpMinimalImports opts file - is <- liftE $ waitImports (mname <.> "imports") - tmp <- liftE getCurrentDirectory - liftE $ cleanTmpImports tmp - return is - --- | Groups several lines related to one import by indents -groupImports :: [String] -> [[String]] -groupImports = unfoldr getPack where - getPack [] = Nothing - getPack (s:ss) = Just $ first (s:) $ break (null . takeWhile isSpace) ss - --- | Split import to import and import-list -splitImport :: [String] -> (String, String) -splitImport = splitBraces . unwords . map trim where - cut = twice $ reverse . drop 1 - twice f = f . f - splitBraces = (trim *** (trim . cut)) . break (== '(') - --- | Returns minimal imports for file specified -clearImports :: [String] -> FilePath -> ExceptT String IO [(String, String)] -clearImports opts = liftM (map splitImport . groupImports) . findMinimalImports opts - --- | Retry action on fail -retry :: (MonadPlus m, MonadIO m) => Int -> m a -> m a -retry dt act = msum $ act : repeat ((liftIO (threadDelay dt) >>) act) +module HsDev.Tools.ClearImports ( + dumpMinimalImports, waitImports, cleanTmpImports, + findMinimalImports, + groupImports, splitImport, + clearImports, + + module Control.Monad.Except + ) where + +import Control.Arrow +import Control.Concurrent (threadDelay) +import Control.Exception +import Control.Monad.Except +import Data.Char +import Data.List +import Data.Maybe (mapMaybe) +import Data.Text (unpack) +import System.Directory +import System.FilePath +import qualified Language.Haskell.Exts as Exts + +import GHC +import GHC.Paths (libdir) + +import HsDev.Util +import HsDev.Tools.Ghc.Compat + +-- | Dump minimal imports +dumpMinimalImports :: [String] -> FilePath -> ExceptT String IO String +dumpMinimalImports opts f = do + cur <- liftE getCurrentDirectory + file <- liftE $ canonicalizePath f + cts <- liftE $ fmap unpack $ readFileUtf8 file + + mname <- case Exts.parseFileContentsWithMode (pmode file) cts of + Exts.ParseFailed loc err -> throwError $ + "Failed to parse file at " ++ + Exts.prettyPrint loc ++ ":" ++ err + Exts.ParseOk (Exts.Module _ (Just (Exts.ModuleHead _ (Exts.ModuleName _ mname) _ _)) _ _ _) -> return mname + _ -> throwError "Error" + + void $ liftE $ runGhc (Just libdir) $ do + df <- getSessionDynFlags + let + df' = df { + ghcLink = NoLink, + hscTarget = HscNothing, + dumpDir = Just cur, + stubDir = Just cur, + objectDir = Just cur, + hiDir = Just cur } + (df'', _, _) <- parseDynamicFlags df' (map noLoc ("-ddump-minimal-imports" : opts)) + _ <- setSessionDynFlags df'' + cleanupHandler df'' $ do + t <- guessTarget file Nothing + setTargets [t] + load LoadAllTargets + + length mname `seq` return mname + where + pmode :: FilePath -> Exts.ParseMode + pmode f' = Exts.defaultParseMode { + Exts.parseFilename = f', + Exts.baseLanguage = Exts.Haskell2010, + Exts.extensions = Exts.glasgowExts ++ map Exts.parseExtension exts, + Exts.fixities = Just Exts.baseFixities } + exts = mapMaybe (stripPrefix "-X") opts + +-- | Read imports from file +waitImports :: FilePath -> IO [String] +waitImports f = retry 1000 $ do + is <- liftM lines $ readFile f + length is `seq` return is + +-- | Clean temporary files +cleanTmpImports :: FilePath -> IO () +cleanTmpImports dir = do + dumps <- liftM (filter ((== ".imports") . takeExtension)) $ directoryContents dir + forM_ dumps $ handle ignoreIO' . retry 1000 . removeFile + where + ignoreIO' :: IOException -> IO () + ignoreIO' _ = return () + +-- | Dump and read imports +findMinimalImports :: [String] -> FilePath -> ExceptT String IO [String] +findMinimalImports opts f = do + file <- liftE $ canonicalizePath f + mname <- dumpMinimalImports opts file + is <- liftE $ waitImports (mname <.> "imports") + tmp <- liftE getCurrentDirectory + liftE $ cleanTmpImports tmp + return is + +-- | Groups several lines related to one import by indents +groupImports :: [String] -> [[String]] +groupImports = unfoldr getPack where + getPack [] = Nothing + getPack (s:ss) = Just $ first (s:) $ break (null . takeWhile isSpace) ss + +-- | Split import to import and import-list +splitImport :: [String] -> (String, String) +splitImport = splitBraces . unwords . map trim where + cut = twice $ reverse . drop 1 + twice f = f . f + splitBraces = (trim *** (trim . cut)) . break (== '(') + +-- | Returns minimal imports for file specified +clearImports :: [String] -> FilePath -> ExceptT String IO [(String, String)] +clearImports opts = liftM (map splitImport . groupImports) . findMinimalImports opts + +-- | Retry action on fail +retry :: (MonadPlus m, MonadIO m) => Int -> m a -> m a +retry dt act = msum $ act : repeat ((liftIO (threadDelay dt) >>) act) diff --git a/src/HsDev/Tools/Ghc/Base.hs b/src/HsDev/Tools/Ghc/Base.hs --- a/src/HsDev/Tools/Ghc/Base.hs +++ b/src/HsDev/Tools/Ghc/Base.hs @@ -1,196 +1,196 @@ -{-# LANGUAGE PatternGuards #-} - -module HsDev.Tools.Ghc.Base ( - -- * Running Ghc - ghcRun, ghcRunWith, - -- * Commonly used DynFlags - interpretedFlags, noLinkFlags, - -- * Setting DynFlags - withFlags, modifyFlags, - -- * Loading targets - clearTargets, makeTarget, loadTargets, - loadInteractive, reload, - -- * Logging messages - collectMessages, collectMessages_, - - -- * Util - formatType, - spanRegion, - withCurrentDirectory, - logToChan, logToNull - ) where - -import Control.Lens (view, over) -import Control.Monad -import Control.Monad.Except -import Data.Time.Clock (getCurrentTime) -import Data.String (fromString) -import Data.Text (Text) -import qualified Data.Text as T -import System.Directory (getCurrentDirectory, setCurrentDirectory) -import System.FilePath - -import Exception (ExceptionMonad(..)) -import GHC hiding (Warning, Module) -import Outputable -import FastString (unpackFS) -import StringBuffer -import Type -import qualified Pretty - -import Control.Concurrent.FiniteChan -import System.Directory.Paths -import HsDev.Symbols.Location (Position(..), Region(..), region, ModuleLocation(..)) -import HsDev.Tools.Types -import HsDev.Tools.Ghc.Compat -import qualified HsDev.Tools.Ghc.Compat as C (setLogAction, addLogAction, unqualStyle) - --- | Run ghc -ghcRun :: GhcMonad m => [String] -> m a -> m a -ghcRun = ghcRunWith interpretedFlags - --- | Run ghc -ghcRunWith :: GhcMonad m => (DynFlags -> DynFlags) -> [String] -> m a -> m a -ghcRunWith onFlags opts act = do - fs <- getSessionDynFlags - cleanupHandler fs $ do - (fs', _, _) <- parseDynamicFlags fs (map noLoc opts) - void $ setSessionDynFlags $ onFlags fs' - modifyFlags $ C.setLogAction logToNull - act - -interpretedFlags :: DynFlags -> DynFlags -interpretedFlags fs = fs { - ghcMode = CompManager, - ghcLink = LinkInMemory, - hscTarget = HscInterpreted } - -noLinkFlags :: DynFlags -> DynFlags -noLinkFlags fs = fs { - ghcMode = CompManager, - ghcLink = NoLink, - hscTarget = HscNothing } - --- | Alter @DynFlags@ temporary -withFlags :: GhcMonad m => m a -> m a -withFlags = gbracket getSessionDynFlags (void . setSessionDynFlags) . const - --- | Update @DynFlags@ -modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m () -modifyFlags f = do - fs <- getSessionDynFlags - let - fs' = f fs - _ <- setSessionDynFlags fs' - -- _ <- liftIO $ initPackages fs' - return () - --- | Clear loaded targets -clearTargets :: GhcMonad m => m () -clearTargets = loadTargets [] - --- | Make target with its source code optional -makeTarget :: GhcMonad m => Text -> Maybe Text -> m Target -makeTarget name Nothing = guessTarget (T.unpack name) Nothing -makeTarget name (Just cts) = do - t <- guessTarget (T.unpack name) Nothing - tm <- liftIO getCurrentTime - return t { targetContents = Just (stringToStringBuffer $ T.unpack cts, tm) } - --- | Load all targets -loadTargets :: GhcMonad m => [Target] -> m () -loadTargets ts = setTargets ts >> load LoadAllTargets >> return () - --- | Load and set interactive context -loadInteractive :: GhcMonad m => Path -> Maybe Text -> m () -loadInteractive fpath mcts = do - fpath' <- liftIO $ canonicalize fpath - withCurrentDirectory (view path $ takeDir fpath') $ do - t <- makeTarget (over path takeFileName fpath') mcts - loadTargets [t] - g <- getModuleGraph - setContext [IIModule (ms_mod_name m) | m <- modSummaries g] - --- | Reload targets -reload :: GhcMonad m => m () -reload = do - ts <- getTargets - ctx <- getContext - setContext [] - clearTargets - setTargets ts - setContext ctx - --- | Collect messages from ghc for underlying computation -collectMessages :: GhcMonad m => m a -> m (a, [Note OutputMessage]) -collectMessages act = do - ch <- liftIO newChan - r <- gbracket (liftM log_action getSessionDynFlags) (\action' -> modifyFlags (\fs -> fs { log_action = action' })) $ \_ -> do - modifyFlags (C.addLogAction $ logToChan ch) - act - notes <- liftIO $ stopChan ch - return (r, notes) - --- | Same as @collectMessages@, but when no result except notes needed -collectMessages_ :: GhcMonad m => m () -> m [Note OutputMessage] -collectMessages_ = fmap snd . collectMessages - --- | Format type for output -formatType :: GHC.DynFlags -> GHC.Type -> String -formatType dflag t = showOutputable dflag (removeForAlls t) - --- | Get region of @SrcSpan@ -spanRegion :: SrcSpan -> Region -spanRegion (RealSrcSpan s) = Position (srcSpanStartLine s) (srcSpanStartCol s) `region` Position (srcSpanEndLine s) (srcSpanEndCol s) -spanRegion _ = Position 0 0 `region` Position 0 0 - --- | Set current directory and restore it after action -withCurrentDirectory :: GhcMonad m => FilePath -> m a -> m a -withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ - const (liftIO (setCurrentDirectory dir) >> act) - --- | Log ghc warnings and errors as to chan --- You may have to apply recalcTabs on result notes -logToChan :: Chan (Note OutputMessage) -> LogAction -logToChan ch fs sev src msg - | Just sev' <- checkSev sev = do - src' <- canonicalize srcMod - void $ sendChan ch Note { - _noteSource = src', - _noteRegion = spanRegion src, - _noteLevel = Just sev', - _note = OutputMessage { - _message = fromString $ showSDoc fs msg, - _messageSuggestion = Nothing } } - | otherwise = return () - where - checkSev SevWarning = Just Warning - checkSev SevError = Just Error - checkSev SevFatal = Just Error - checkSev _ = Nothing - srcMod = case src of - RealSrcSpan s' -> FileModule (fromFilePath $ unpackFS $ srcSpanFile s') Nothing - _ -> NoLocation - --- | Don't log ghc warnings and errors -logToNull :: LogAction -logToNull _ _ _ _ = return () - --- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@ - -removeForAlls :: Type -> Type -removeForAlls ty = removeForAlls' ty' tty' where - ty' = dropForAlls ty - tty' = splitFunTy_maybe ty' - -removeForAlls' :: Type -> Maybe (Type, Type) -> Type -removeForAlls' ty Nothing = ty -removeForAlls' ty (Just (pre, ftype)) - | isPredTy pre = mkFunTy pre (dropForAlls ftype) - | otherwise = ty - -showOutputable :: Outputable a => DynFlags -> a -> String -showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr - -showUnqualifiedPage :: DynFlags -> SDoc -> String -showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . withPprStyleDoc dflag (C.unqualStyle dflag) +{-# LANGUAGE PatternGuards #-} + +module HsDev.Tools.Ghc.Base ( + -- * Running Ghc + ghcRun, ghcRunWith, + -- * Commonly used DynFlags + interpretedFlags, noLinkFlags, + -- * Setting DynFlags + withFlags, modifyFlags, + -- * Loading targets + clearTargets, makeTarget, loadTargets, + loadInteractive, reload, + -- * Logging messages + collectMessages, collectMessages_, + + -- * Util + formatType, + spanRegion, + withCurrentDirectory, + logToChan, logToNull + ) where + +import Control.Lens (view, over) +import Control.Monad +import Control.Monad.Except +import Data.Time.Clock (getCurrentTime) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.FilePath + +import Exception (ExceptionMonad(..)) +import GHC hiding (Warning, Module) +import Outputable +import FastString (unpackFS) +import StringBuffer +import Type +import qualified Pretty + +import Control.Concurrent.FiniteChan +import System.Directory.Paths +import HsDev.Symbols.Location (Position(..), Region(..), region, ModuleLocation(..)) +import HsDev.Tools.Types +import HsDev.Tools.Ghc.Compat +import qualified HsDev.Tools.Ghc.Compat as C (setLogAction, addLogAction, unqualStyle) + +-- | Run ghc +ghcRun :: GhcMonad m => [String] -> m a -> m a +ghcRun = ghcRunWith interpretedFlags + +-- | Run ghc +ghcRunWith :: GhcMonad m => (DynFlags -> DynFlags) -> [String] -> m a -> m a +ghcRunWith onFlags opts act = do + fs <- getSessionDynFlags + cleanupHandler fs $ do + (fs', _, _) <- parseDynamicFlags fs (map noLoc opts) + void $ setSessionDynFlags $ onFlags fs' + modifyFlags $ C.setLogAction logToNull + act + +interpretedFlags :: DynFlags -> DynFlags +interpretedFlags fs = fs { + ghcMode = CompManager, + ghcLink = LinkInMemory, + hscTarget = HscInterpreted } + +noLinkFlags :: DynFlags -> DynFlags +noLinkFlags fs = fs { + ghcMode = CompManager, + ghcLink = NoLink, + hscTarget = HscNothing } + +-- | Alter @DynFlags@ temporary +withFlags :: GhcMonad m => m a -> m a +withFlags = gbracket getSessionDynFlags (void . setSessionDynFlags) . const + +-- | Update @DynFlags@ +modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m () +modifyFlags f = do + fs <- getSessionDynFlags + let + fs' = f fs + _ <- setSessionDynFlags fs' + -- _ <- liftIO $ initPackages fs' + return () + +-- | Clear loaded targets +clearTargets :: GhcMonad m => m () +clearTargets = loadTargets [] + +-- | Make target with its source code optional +makeTarget :: GhcMonad m => Text -> Maybe Text -> m Target +makeTarget name Nothing = guessTarget (T.unpack name) Nothing +makeTarget name (Just cts) = do + t <- guessTarget (T.unpack name) Nothing + tm <- liftIO getCurrentTime + return t { targetContents = Just (stringToStringBuffer $ T.unpack cts, tm) } + +-- | Load all targets +loadTargets :: GhcMonad m => [Target] -> m () +loadTargets ts = setTargets ts >> load LoadAllTargets >> return () + +-- | Load and set interactive context +loadInteractive :: GhcMonad m => Path -> Maybe Text -> m () +loadInteractive fpath mcts = do + fpath' <- liftIO $ canonicalize fpath + withCurrentDirectory (view path $ takeDir fpath') $ do + t <- makeTarget (over path takeFileName fpath') mcts + loadTargets [t] + g <- getModuleGraph + setContext [IIModule (ms_mod_name m) | m <- modSummaries g] + +-- | Reload targets +reload :: GhcMonad m => m () +reload = do + ts <- getTargets + ctx <- getContext + setContext [] + clearTargets + setTargets ts + setContext ctx + +-- | Collect messages from ghc for underlying computation +collectMessages :: GhcMonad m => m a -> m (a, [Note OutputMessage]) +collectMessages act = do + ch <- liftIO newChan + r <- gbracket (liftM log_action getSessionDynFlags) (\action' -> modifyFlags (\fs -> fs { log_action = action' })) $ \_ -> do + modifyFlags (C.addLogAction $ logToChan ch) + act + notes <- liftIO $ stopChan ch + return (r, notes) + +-- | Same as @collectMessages@, but when no result except notes needed +collectMessages_ :: GhcMonad m => m () -> m [Note OutputMessage] +collectMessages_ = fmap snd . collectMessages + +-- | Format type for output +formatType :: GHC.DynFlags -> GHC.Type -> String +formatType dflag t = showOutputable dflag (removeForAlls t) + +-- | Get region of @SrcSpan@ +spanRegion :: SrcSpan -> Region +spanRegion (RealSrcSpan s) = Position (srcSpanStartLine s) (srcSpanStartCol s) `region` Position (srcSpanEndLine s) (srcSpanEndCol s) +spanRegion _ = Position 0 0 `region` Position 0 0 + +-- | Set current directory and restore it after action +withCurrentDirectory :: GhcMonad m => FilePath -> m a -> m a +withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ + const (liftIO (setCurrentDirectory dir) >> act) + +-- | Log ghc warnings and errors as to chan +-- You may have to apply recalcTabs on result notes +logToChan :: Chan (Note OutputMessage) -> LogAction +logToChan ch fs sev src msg + | Just sev' <- checkSev sev = do + src' <- canonicalize srcMod + void $ sendChan ch Note { + _noteSource = src', + _noteRegion = spanRegion src, + _noteLevel = Just sev', + _note = OutputMessage { + _message = fromString $ showSDoc fs msg, + _messageSuggestion = Nothing } } + | otherwise = return () + where + checkSev SevWarning = Just Warning + checkSev SevError = Just Error + checkSev SevFatal = Just Error + checkSev _ = Nothing + srcMod = case src of + RealSrcSpan s' -> FileModule (fromFilePath $ unpackFS $ srcSpanFile s') Nothing + _ -> NoLocation + +-- | Don't log ghc warnings and errors +logToNull :: LogAction +logToNull _ _ _ _ = return () + +-- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@ + +removeForAlls :: Type -> Type +removeForAlls ty = removeForAlls' ty' tty' where + ty' = dropForAlls ty + tty' = splitFunTy_maybe ty' + +removeForAlls' :: Type -> Maybe (Type, Type) -> Type +removeForAlls' ty Nothing = ty +removeForAlls' ty (Just (pre, ftype)) + | isPredTy pre = mkFunTy pre (dropForAlls ftype) + | otherwise = ty + +showOutputable :: Outputable a => DynFlags -> a -> String +showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr + +showUnqualifiedPage :: DynFlags -> SDoc -> String +showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . withPprStyleDoc dflag (C.unqualStyle dflag) diff --git a/src/HsDev/Tools/Ghc/Check.hs b/src/HsDev/Tools/Ghc/Check.hs --- a/src/HsDev/Tools/Ghc/Check.hs +++ b/src/HsDev/Tools/Ghc/Check.hs @@ -1,48 +1,48 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HsDev.Tools.Ghc.Check ( - check, - - Ghc, - module HsDev.Tools.Types, - module HsDev.Symbols.Types, - PackageDb(..), PackageDbStack(..), Project(..), - - module Control.Monad.Except - ) where - -import Control.Lens (view, (^.)) -import Control.Monad.Except -import qualified Data.Map as M -import Data.Text (Text) -import System.Log.Simple (MonadLog(..), scope, sendLog, Level(Trace)) - -import GHC hiding (Warning, Module) - -import HsDev.Error -import HsDev.PackageDb -import HsDev.Symbols.Location -import HsDev.Symbols.Types -import HsDev.Tools.Base -import HsDev.Tools.Ghc.Worker -import HsDev.Tools.Types -import HsDev.Tools.Tabs -import System.Directory.Paths - --- | Check module source -check :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m [Note OutputMessage] -check m msrc = scope "check" $ case view (moduleId . moduleLocation) m of - FileModule file _ -> do - let - dir = sourceRoot_ (m ^. moduleId) - -- FIXME: There can be dependent modules with modified file contents - -- Their contents should be set here too - srcs = maybe mempty (M.singleton file) msrc - ex <- liftIO $ dirExists dir - sendLog Trace "loading targets" - notes <- withFlags $ (if ex then withCurrentDirectory (dir ^. path) else id) $ collectMessages_ $ do - target <- makeTarget (relPathTo dir file) msrc - loadTargets [target] - sendLog Trace "targets checked" - liftIO $ recalcNotesTabs srcs notes - _ -> scope "check" $ hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m) +{-# LANGUAGE OverloadedStrings #-} + +module HsDev.Tools.Ghc.Check ( + check, + + Ghc, + module HsDev.Tools.Types, + module HsDev.Symbols.Types, + PackageDb(..), PackageDbStack(..), Project(..), + + module Control.Monad.Except + ) where + +import Control.Lens (view, (^.)) +import Control.Monad.Except +import qualified Data.Map as M +import Data.Text (Text) +import System.Log.Simple (MonadLog(..), scope, sendLog, Level(Trace)) + +import GHC hiding (Warning, Module) + +import HsDev.Error +import HsDev.PackageDb +import HsDev.Symbols.Location +import HsDev.Symbols.Types +import HsDev.Tools.Base +import HsDev.Tools.Ghc.Worker +import HsDev.Tools.Types +import HsDev.Tools.Tabs +import System.Directory.Paths + +-- | Check module source +check :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m [Note OutputMessage] +check m msrc = scope "check" $ case view (moduleId . moduleLocation) m of + FileModule file _ -> do + let + dir = sourceRoot_ (m ^. moduleId) + -- FIXME: There can be dependent modules with modified file contents + -- Their contents should be set here too + srcs = maybe mempty (M.singleton file) msrc + ex <- liftIO $ dirExists dir + sendLog Trace "loading targets" + notes <- withFlags $ (if ex then withCurrentDirectory (dir ^. path) else id) $ collectMessages_ $ do + target <- makeTarget (relPathTo dir file) msrc + loadTargets [target] + sendLog Trace "targets checked" + liftIO $ recalcNotesTabs srcs notes + _ -> scope "check" $ hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m) diff --git a/src/HsDev/Tools/Ghc/Compat.hs b/src/HsDev/Tools/Ghc/Compat.hs --- a/src/HsDev/Tools/Ghc/Compat.hs +++ b/src/HsDev/Tools/Ghc/Compat.hs @@ -1,254 +1,254 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Tools.Ghc.Compat ( - pkgDatabase, - TcId, - UnitId, InstalledUnitId, toInstalledUnitId, - unitId, moduleUnitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle, - LogAction, setLogAction, addLogAction, - languages, flags, - recSelParent, recSelCtors, - getFixity, - unqualStyle, - exposedModuleName, - exprType, - modSummaries, - cleanTemps, - mgArgTys, mgResTy - ) where - -import qualified BasicTypes -import qualified DynFlags as GHC -import qualified ErrUtils -import qualified InteractiveEval as Eval -import qualified GHC -import qualified Module -import qualified Name -import qualified Packages as GHC -import qualified PatSyn as GHC -import qualified Pretty -import qualified SysTools -import Outputable - -#if __GLASGOW_HASKELL__ >= 800 -import Data.List (nub) -import qualified IdInfo -import TcRnDriver -#endif - -#if __GLASGOW_HASKELL__ == 710 -import Exception (ExceptionMonad) -import Control.Monad.Reader -#endif - -#if __GLASGOW_HASKELL__ <= 800 -import qualified GHC.PackageDb as GHC -#endif - -pkgDatabase :: GHC.DynFlags -> Maybe [GHC.PackageConfig] -#if __GLASGOW_HASKELL__ >= 800 -pkgDatabase = fmap (nub . concatMap snd) . GHC.pkgDatabase -#elif __GLASGOW_HASKELL__ == 710 -pkgDatabase = GHC.pkgDatabase -#endif - -#if __GLASGOW_HASKELL__ >= 804 -type TcId = GHC.GhcTc -#else -type TcId = GHC.Id -#endif - -#if __GLASGOW_HASKELL__ >= 800 -type UnitId = Module.UnitId -#elif __GLASGOW_HASKELL__ == 710 -type UnitId = Module.PackageKey -#endif - -#if __GLASGOW_HASKELL__ >= 802 -type InstalledUnitId = Module.InstalledUnitId -#else -type InstalledUnitId = UnitId -#endif - -toInstalledUnitId :: UnitId -> InstalledUnitId -#if __GLASGOW_HASKELL__ >= 802 -toInstalledUnitId = Module.toInstalledUnitId -#else -toInstalledUnitId = id -#endif - -unitId :: GHC.PackageConfig -> InstalledUnitId -#if __GLASGOW_HASKELL__ >= 800 -unitId = GHC.unitId -#elif __GLASGOW_HASKELL__ == 710 -unitId = GHC.packageKey -#endif - -moduleUnitId :: GHC.Module -> UnitId -#if __GLASGOW_HASKELL__ >= 800 -moduleUnitId = GHC.moduleUnitId -#elif __GLASGOW_HASKELL__ == 710 -moduleUnitId = GHC.modulePackageKey -#endif - -depends :: GHC.DynFlags -> GHC.PackageConfig -> [InstalledUnitId] -#if __GLASGOW_HASKELL__ >= 800 -depends _ = GHC.depends -#elif __GLASGOW_HASKELL__ == 710 -depends df = map (GHC.resolveInstalledPackageId df) . GHC.depends -#endif - -getPackageDetails :: GHC.DynFlags -> InstalledUnitId -> GHC.PackageConfig -#if __GLASGOW_HASKELL__ >= 802 -getPackageDetails = GHC.getInstalledPackageDetails -#else -getPackageDetails = GHC.getPackageDetails -#endif - -patSynType :: GHC.PatSyn -> GHC.Type -patSynType p = GHC.patSynInstResTy p (GHC.patSynArgs p) - -#if __GLASGOW_HASKELL__ >= 800 -cleanupHandler :: GHC.DynFlags -> m a -> m a -cleanupHandler _ = id -#elif __GLASGOW_HASKELL__ == 710 -cleanupHandler :: (ExceptionMonad m) => GHC.DynFlags -> m a -> m a -cleanupHandler = GHC.defaultCleanupHandler -#endif - -renderStyle :: Pretty.Mode -> Int -> Pretty.Doc -> String -#if __GLASGOW_HASKELL__ >= 800 -renderStyle m cols = Pretty.renderStyle (Pretty.Style m cols 1.5) -#elif __GLASGOW_HASKELL__ == 710 -renderStyle = Pretty.showDoc -#endif - -type LogAction = GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> ErrUtils.MsgDoc -> IO () - -setLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags -setLogAction act fs = fs { GHC.log_action = act' } where - act' :: GHC.LogAction -#if __GLASGOW_HASKELL__ >= 800 - act' df _ sev src _ msg = act df sev src msg -#elif __GLASGOW_HASKELL__ == 710 - act' df sev src _ msg = act df sev src msg -#endif - -addLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags -addLogAction act fs = fs { GHC.log_action = logBoth } where - logBoth :: GHC.LogAction -#if __GLASGOW_HASKELL__ >= 800 - logBoth df wreason sev src style msg = do - GHC.log_action fs df wreason sev src style msg - GHC.log_action (setLogAction act fs) df wreason sev src style msg -#elif __GLASGOW_HASKELL__ == 710 - logBoth df sev src style ms = do - GHC.log_action fs df sev src style msg - GHC.log_action (setLogAction act fs) df sev src style msg -#endif - -#if __GLASGOW_HASKELL__ == 710 -instance (Monad m, GHC.HasDynFlags m) => GHC.HasDynFlags (ReaderT r m) where - getDynFlags = lift GHC.getDynFlags -#endif - -flags :: [String] -#if __GLASGOW_HASKELL__ >= 800 -flags = concat [ - [option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags], - ["warn-" ++ option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags], - [option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]] -#elif __GLASGOW_HASKELL__ >= 710 -flags = concat [ - [option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags], - [option | (GHC.FlagSpec option _ _ _) <- GHC.fWarningFlags], - [option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]] -#elif __GLASGOW_HASKELL__ >= 704 -flags = concat [ - [option | (option, _, _) <- GHC.fFlags], - [option | (option, _, _) <- GHC.fWarningFlags], - [option | (option, _, _) <- GHC.fLangFlags]] -#endif - -#if __GLASGOW_HASKELL__ >= 800 -recSelParent :: IdInfo.RecSelParent -> String -recSelParent (IdInfo.RecSelData p) = Name.getOccString p -recSelParent (IdInfo.RecSelPatSyn p) = Name.getOccString p -#else -recSelParent :: GHC.TyCon -> String -recSelParent = Name.getOccString -#endif - -#if __GLASGOW_HASKELL__ >= 800 -recSelCtors :: IdInfo.RecSelParent -> [String] -recSelCtors (IdInfo.RecSelData p) = map Name.getOccString (GHC.tyConDataCons p) -recSelCtors (IdInfo.RecSelPatSyn p) = [Name.getOccString p] -#else -recSelCtors :: GHC.TyCon -> [String] -recSelCtors = return . Name.getOccString -#endif - -getFixity :: BasicTypes.Fixity -> (Int, BasicTypes.FixityDirection) -#if __GLASGOW_HASKELL__ >= 800 -getFixity (BasicTypes.Fixity _ i d) = (i, d) -#else -getFixity (BasicTypes.Fixity i d) = (i, d) -#endif - -languages :: [String] -languages = GHC.supportedLanguagesAndExtensions - -unqualStyle :: GHC.DynFlags -> PprStyle -#if __GLASGOW_HASKELL__ >= 802 -unqualStyle df = mkUserStyle df neverQualify AllTheWay -#else -unqualStyle _ = mkUserStyle neverQualify AllTheWay -#endif - -#if __GLASGOW_HASKELL__ > 800 -exposedModuleName :: (a, Maybe b) -> a -exposedModuleName = fst -#else -exposedModuleName :: GHC.ExposedModule unit mname -> mname -exposedModuleName = GHC.exposedName -#endif - -exprType :: GHC.GhcMonad m => String -> m GHC.Type -#if __GLASGOW_HASKELL__ > 800 -exprType = Eval.exprType TM_Inst -#else -exprType = Eval.exprType -#endif - -modSummaries :: GHC.ModuleGraph -> [GHC.ModSummary] -#if __GLASGOW_HASKELL__ >= 804 -modSummaries = GHC.mgModSummaries -#else -modSummaries = id -#endif - -cleanTemps :: GHC.DynFlags -> IO () -#if __GLASGOW_HASKELL__ >= 804 -cleanTemps _ = return () -#else -cleanTemps df = do - SysTools.cleanTempFiles df - SysTools.cleanTempDirs df -#endif - -mgArgTys :: GHC.MatchGroup TcId (GHC.LHsExpr TcId) -> Maybe [GHC.Type] -#if __GLASGOW_HASKELL__ >= 806 -mgArgTys (GHC.MG{GHC.mg_ext=ext}) = Just $ GHC.mg_arg_tys ext -mgArgTys _ = Nothing -#else -mgArgTys = Just . GHC.mg_arg_tys -#endif - -mgResTy :: GHC.MatchGroup TcId (GHC.LHsExpr TcId) -> Maybe GHC.Type -#if __GLASGOW_HASKELL__ >= 806 -mgResTy (GHC.MG{GHC.mg_ext=ext}) = Just $ GHC.mg_res_ty ext -mgResTy _ = Nothing -#else -mgResTy = Just . GHC.mg_res_ty -#endif +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Tools.Ghc.Compat ( + pkgDatabase, + TcId, + UnitId, InstalledUnitId, toInstalledUnitId, + unitId, moduleUnitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle, + LogAction, setLogAction, addLogAction, + languages, flags, + recSelParent, recSelCtors, + getFixity, + unqualStyle, + exposedModuleName, + exprType, + modSummaries, + cleanTemps, + mgArgTys, mgResTy + ) where + +import qualified BasicTypes +import qualified DynFlags as GHC +import qualified ErrUtils +import qualified InteractiveEval as Eval +import qualified GHC +import qualified Module +import qualified Name +import qualified Packages as GHC +import qualified PatSyn as GHC +import qualified Pretty +import qualified SysTools +import Outputable + +#if __GLASGOW_HASKELL__ >= 800 +import Data.List (nub) +import qualified IdInfo +import TcRnDriver +#endif + +#if __GLASGOW_HASKELL__ == 710 +import Exception (ExceptionMonad) +import Control.Monad.Reader +#endif + +#if __GLASGOW_HASKELL__ <= 800 +import qualified GHC.PackageDb as GHC +#endif + +pkgDatabase :: GHC.DynFlags -> Maybe [GHC.PackageConfig] +#if __GLASGOW_HASKELL__ >= 800 +pkgDatabase = fmap (nub . concatMap snd) . GHC.pkgDatabase +#elif __GLASGOW_HASKELL__ == 710 +pkgDatabase = GHC.pkgDatabase +#endif + +#if __GLASGOW_HASKELL__ >= 804 +type TcId = GHC.GhcTc +#else +type TcId = GHC.Id +#endif + +#if __GLASGOW_HASKELL__ >= 800 +type UnitId = Module.UnitId +#elif __GLASGOW_HASKELL__ == 710 +type UnitId = Module.PackageKey +#endif + +#if __GLASGOW_HASKELL__ >= 802 +type InstalledUnitId = Module.InstalledUnitId +#else +type InstalledUnitId = UnitId +#endif + +toInstalledUnitId :: UnitId -> InstalledUnitId +#if __GLASGOW_HASKELL__ >= 802 +toInstalledUnitId = Module.toInstalledUnitId +#else +toInstalledUnitId = id +#endif + +unitId :: GHC.PackageConfig -> InstalledUnitId +#if __GLASGOW_HASKELL__ >= 800 +unitId = GHC.unitId +#elif __GLASGOW_HASKELL__ == 710 +unitId = GHC.packageKey +#endif + +moduleUnitId :: GHC.Module -> UnitId +#if __GLASGOW_HASKELL__ >= 800 +moduleUnitId = GHC.moduleUnitId +#elif __GLASGOW_HASKELL__ == 710 +moduleUnitId = GHC.modulePackageKey +#endif + +depends :: GHC.DynFlags -> GHC.PackageConfig -> [InstalledUnitId] +#if __GLASGOW_HASKELL__ >= 800 +depends _ = GHC.depends +#elif __GLASGOW_HASKELL__ == 710 +depends df = map (GHC.resolveInstalledPackageId df) . GHC.depends +#endif + +getPackageDetails :: GHC.DynFlags -> InstalledUnitId -> GHC.PackageConfig +#if __GLASGOW_HASKELL__ >= 802 +getPackageDetails = GHC.getInstalledPackageDetails +#else +getPackageDetails = GHC.getPackageDetails +#endif + +patSynType :: GHC.PatSyn -> GHC.Type +patSynType p = GHC.patSynInstResTy p (GHC.patSynArgs p) + +#if __GLASGOW_HASKELL__ >= 800 +cleanupHandler :: GHC.DynFlags -> m a -> m a +cleanupHandler _ = id +#elif __GLASGOW_HASKELL__ == 710 +cleanupHandler :: (ExceptionMonad m) => GHC.DynFlags -> m a -> m a +cleanupHandler = GHC.defaultCleanupHandler +#endif + +renderStyle :: Pretty.Mode -> Int -> Pretty.Doc -> String +#if __GLASGOW_HASKELL__ >= 800 +renderStyle m cols = Pretty.renderStyle (Pretty.Style m cols 1.5) +#elif __GLASGOW_HASKELL__ == 710 +renderStyle = Pretty.showDoc +#endif + +type LogAction = GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> ErrUtils.MsgDoc -> IO () + +setLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags +setLogAction act fs = fs { GHC.log_action = act' } where + act' :: GHC.LogAction +#if __GLASGOW_HASKELL__ >= 800 + act' df _ sev src _ msg = act df sev src msg +#elif __GLASGOW_HASKELL__ == 710 + act' df sev src _ msg = act df sev src msg +#endif + +addLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags +addLogAction act fs = fs { GHC.log_action = logBoth } where + logBoth :: GHC.LogAction +#if __GLASGOW_HASKELL__ >= 800 + logBoth df wreason sev src style msg = do + GHC.log_action fs df wreason sev src style msg + GHC.log_action (setLogAction act fs) df wreason sev src style msg +#elif __GLASGOW_HASKELL__ == 710 + logBoth df sev src style ms = do + GHC.log_action fs df sev src style msg + GHC.log_action (setLogAction act fs) df sev src style msg +#endif + +#if __GLASGOW_HASKELL__ == 710 +instance (Monad m, GHC.HasDynFlags m) => GHC.HasDynFlags (ReaderT r m) where + getDynFlags = lift GHC.getDynFlags +#endif + +flags :: [String] +#if __GLASGOW_HASKELL__ >= 800 +flags = concat [ + [option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags], + ["warn-" ++ option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags], + [option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]] +#elif __GLASGOW_HASKELL__ >= 710 +flags = concat [ + [option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags], + [option | (GHC.FlagSpec option _ _ _) <- GHC.fWarningFlags], + [option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]] +#elif __GLASGOW_HASKELL__ >= 704 +flags = concat [ + [option | (option, _, _) <- GHC.fFlags], + [option | (option, _, _) <- GHC.fWarningFlags], + [option | (option, _, _) <- GHC.fLangFlags]] +#endif + +#if __GLASGOW_HASKELL__ >= 800 +recSelParent :: IdInfo.RecSelParent -> String +recSelParent (IdInfo.RecSelData p) = Name.getOccString p +recSelParent (IdInfo.RecSelPatSyn p) = Name.getOccString p +#else +recSelParent :: GHC.TyCon -> String +recSelParent = Name.getOccString +#endif + +#if __GLASGOW_HASKELL__ >= 800 +recSelCtors :: IdInfo.RecSelParent -> [String] +recSelCtors (IdInfo.RecSelData p) = map Name.getOccString (GHC.tyConDataCons p) +recSelCtors (IdInfo.RecSelPatSyn p) = [Name.getOccString p] +#else +recSelCtors :: GHC.TyCon -> [String] +recSelCtors = return . Name.getOccString +#endif + +getFixity :: BasicTypes.Fixity -> (Int, BasicTypes.FixityDirection) +#if __GLASGOW_HASKELL__ >= 800 +getFixity (BasicTypes.Fixity _ i d) = (i, d) +#else +getFixity (BasicTypes.Fixity i d) = (i, d) +#endif + +languages :: [String] +languages = GHC.supportedLanguagesAndExtensions + +unqualStyle :: GHC.DynFlags -> PprStyle +#if __GLASGOW_HASKELL__ >= 802 +unqualStyle df = mkUserStyle df neverQualify AllTheWay +#else +unqualStyle _ = mkUserStyle neverQualify AllTheWay +#endif + +#if __GLASGOW_HASKELL__ > 800 +exposedModuleName :: (a, Maybe b) -> a +exposedModuleName = fst +#else +exposedModuleName :: GHC.ExposedModule unit mname -> mname +exposedModuleName = GHC.exposedName +#endif + +exprType :: GHC.GhcMonad m => String -> m GHC.Type +#if __GLASGOW_HASKELL__ > 800 +exprType = Eval.exprType TM_Inst +#else +exprType = Eval.exprType +#endif + +modSummaries :: GHC.ModuleGraph -> [GHC.ModSummary] +#if __GLASGOW_HASKELL__ >= 804 +modSummaries = GHC.mgModSummaries +#else +modSummaries = id +#endif + +cleanTemps :: GHC.DynFlags -> IO () +#if __GLASGOW_HASKELL__ >= 804 +cleanTemps _ = return () +#else +cleanTemps df = do + SysTools.cleanTempFiles df + SysTools.cleanTempDirs df +#endif + +mgArgTys :: GHC.MatchGroup TcId (GHC.LHsExpr TcId) -> Maybe [GHC.Type] +#if __GLASGOW_HASKELL__ >= 806 +mgArgTys (GHC.MG{GHC.mg_ext=ext}) = Just $ GHC.mg_arg_tys ext +mgArgTys _ = Nothing +#else +mgArgTys = Just . GHC.mg_arg_tys +#endif + +mgResTy :: GHC.MatchGroup TcId (GHC.LHsExpr TcId) -> Maybe GHC.Type +#if __GLASGOW_HASKELL__ >= 806 +mgResTy (GHC.MG{GHC.mg_ext=ext}) = Just $ GHC.mg_res_ty ext +mgResTy _ = Nothing +#else +mgResTy = Just . GHC.mg_res_ty +#endif diff --git a/src/HsDev/Tools/Ghc/MGhc.hs b/src/HsDev/Tools/Ghc/MGhc.hs --- a/src/HsDev/Tools/Ghc/MGhc.hs +++ b/src/HsDev/Tools/Ghc/MGhc.hs @@ -1,260 +1,260 @@ -{-# LANGUAGE CPP, UnicodeSyntax, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Tools.Ghc.MGhc ( - Session(..), sessionKey, sessionData, - SessionState(..), sessionActive, sessionMap, - MGhcT(..), runMGhcT, liftGhc, - currentSession, getSessionData, setSessionData, hasSession, findSession, findSessionBy, saveSession, - initSession, newSession, - switchSession, switchSession_, - deleteSession, restoreSession, usingSession, tempSession - ) where - -import Control.Lens -import Control.Monad.Fail as Fail -import Control.Monad.Morph -import Control.Monad.Catch -import Control.Monad.Reader -import Control.Monad.State -import Data.Default as Def -import Data.IORef -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isJust) -import System.Log.Simple.Monad (MonadLog(..)) - -import HsDev.Tools.Ghc.Compat (cleanTemps) - -import DynFlags -import Exception hiding (catch, mask, uninterruptibleMask, bracket, finally) -import GHC -import GHCi -import GhcMonad hiding (Session(..)) -import qualified GhcMonad (Session(..)) -import HscTypes -import Outputable - -data Session s d = Session { - _sessionKey :: s, - _sessionData :: d } - deriving (Eq, Ord, Read, Show) - -sessionKey :: Lens' (Session s d) s -sessionKey = lens g s where - g = _sessionKey - s sess k = sess { _sessionKey = k } - -sessionData :: Lens' (Session s d) d -sessionData = lens g s where - g = _sessionData - s sess dat = sess { _sessionData = dat } - -data SessionState s d = SessionState { - _sessionActive :: Maybe (Session s d), - _sessionMap :: Map s (HscEnv, d) } - -instance Default (SessionState s d) where - def = SessionState Nothing M.empty - -sessionActive :: Lens' (SessionState s d) (Maybe (Session s d)) -sessionActive = lens g s where - g = _sessionActive - s st nm = st { _sessionActive = nm } - -sessionMap :: Lens' (SessionState s d) (Map s (HscEnv, d)) -sessionMap = lens g s where - g = _sessionMap - s st m = st { _sessionMap = m } - -instance ExceptionMonad m => ExceptionMonad (StateT s m) where - gcatch act onErr = StateT $ \st -> gcatch (runStateT act st) (\e -> runStateT (onErr e) st) - gmask f = StateT $ gmask . f' where - f' st' act' = runStateT (f act) st' where - act st = StateT $ act' . runStateT st - -instance ExceptionMonad m => ExceptionMonad (ReaderT r m) where - gcatch act onErr = ReaderT $ \v -> gcatch (runReaderT act v) (\e -> runReaderT (onErr e) v) - gmask f = ReaderT $ gmask . f' where - f' v' act' = runReaderT (f act) v' where - act v = ReaderT $ act' . runReaderT v - --- | Multi-session ghc monad -newtype MGhcT s d m a = MGhcT { unMGhcT :: GhcT (ReaderT (Maybe FilePath) (StateT (SessionState s d) m)) a } - deriving (Functor, Applicative, Monad, MonadFail, MonadIO, ExceptionMonad, HasDynFlags, GhcMonad, MonadState (SessionState s d), MonadReader (Maybe FilePath), MonadThrow, MonadCatch, MonadMask, MonadLog) - -instance MonadTrans GhcT where - lift = liftGhcT - -instance MFunctor GhcT where - hoist fn = GhcT . (fn .) . unGhcT - -instance MonadFail m => MonadFail (GhcT m) where - fail = lift . Fail.fail - -instance MonadState st m => MonadState st (GhcT m) where - get = lift get - put = lift . put - state = lift . state - -instance MonadReader r m => MonadReader r (GhcT m) where - ask = lift ask - local f act = GhcT $ local f . unGhcT act - -instance MonadThrow m => MonadThrow (GhcT m) where - throwM = lift . throwM - -instance MonadCatch m => MonadCatch (GhcT m) where - catch act onError = GhcT $ \sess -> catch (unGhcT act sess) (flip unGhcT sess . onError) - -instance MonadMask m => MonadMask (GhcT m) where - mask f = GhcT $ \s -> mask $ \g -> unGhcT (f $ q g) s where - q g' act = GhcT $ g' . unGhcT act - uninterruptibleMask f = GhcT $ \s -> uninterruptibleMask $ \g -> unGhcT (f $ q g) s where - q g' act = GhcT $ g' . unGhcT act -#if MIN_VERSION_exceptions(0,10,0) - generalBracket acq rel act = GhcT $ \r -> generalBracket - (unGhcT acq r) - (\res exitCase -> case exitCase of - ExitCaseSuccess v -> unGhcT (rel res (ExitCaseSuccess v)) r - ExitCaseException e -> unGhcT (rel res (ExitCaseException e)) r - ExitCaseAbort -> unGhcT (rel res ExitCaseAbort) r) - (\res -> unGhcT (act res) r) -#elif MIN_VERSION_exceptions(0,9,0) - generalBracket acq rel clean act = GhcT $ \r -> generalBracket - (unGhcT acq r) - (\res -> unGhcT (rel res) r) - (\res e -> unGhcT (clean res e) r) - (\res -> unGhcT (act res) r) -#endif - --- | Run multi-session ghc -runMGhcT :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => Maybe FilePath -> MGhcT s d m a -> m a -runMGhcT lib act = do - ref <- liftIO $ newIORef (panic "empty session") - let - session = GhcMonad.Session ref - flip evalStateT Def.def $ flip runReaderT lib $ flip unGhcT session $ unMGhcT $ act `gfinally` cleanup - where - cleanup :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m () - cleanup = do - void saveSession - sessions <- gets (M.elems . view sessionMap) - liftIO $ mapM_ (cleanupSession . view _1) sessions - modify (set sessionMap M.empty) - --- | Lift `Ghc` monad onto `MGhc` -liftGhc :: MonadIO m => Ghc a -> MGhcT s d m a -liftGhc (Ghc act) = MGhcT $ GhcT $ liftIO . act - --- | Get current session -currentSession :: MonadIO m => MGhcT s d m (Maybe (Session s d)) -currentSession = gets (view sessionActive) - --- | Get current session data -getSessionData :: MonadIO m => MGhcT s d m (Maybe d) -getSessionData = gets (preview (sessionActive . _Just . sessionData)) - --- | Set current session data -setSessionData :: MonadIO m => d -> MGhcT s d m () -setSessionData sdata = modify (set (sessionActive . _Just . sessionData) sdata) - --- | Does session exist -hasSession :: (MonadIO m, Ord s) => s -> MGhcT s d m Bool -hasSession key = do - msess <- findSession key - return $ isJust msess - --- | Find session -findSession :: (MonadIO m, Ord s) => s -> MGhcT s d m (Maybe (Session s d)) -findSession key = do - sdata <- gets (preview (sessionMap . ix key . _2)) - return $ fmap (Session key) sdata - --- | Find session by -findSessionBy :: MonadIO m => (s -> Bool) -> MGhcT s d m [Session s d] -findSessionBy p = do - sessions <- gets (M.toList . view sessionMap) - return [Session key sdata | (key, (_, sdata)) <- sessions, p key] - --- | Save current session -saveSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m (Maybe (Session s d)) -saveSession = do - msess <- currentSession - case msess of - Just (Session key' dat') -> do - sess <- getSession - modify (set (sessionMap . at key') (Just (sess, dat'))) - Nothing -> return () - return msess - --- | Initialize new session -initSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m () -initSession = do - lib <- ask - initGhcMonad lib - void saveSession - -activateSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m (Maybe HscEnv) -activateSession key = do - void saveSession - sdata <- gets (view (sessionMap . ix key . _2)) - modify (set sessionActive $ Just (Session key sdata)) - gets (preview (sessionMap . ix key . _1)) - --- | Create new named session, deleting existing session -newSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m () -newSession key = do - msess <- activateSession key - maybe (return ()) (liftIO . cleanupSession) msess - initSession - --- | Switch to session, creating if not exist, returns True if session was created -switchSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m Bool -switchSession key = do - msess <- activateSession key - case msess of - Nothing -> initSession >> return True - Just sess -> setSession sess >> return False - --- | Switch to session, creating if not exist and initializing with passed function -switchSession_ :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> Maybe (MGhcT s d m ()) -> MGhcT s d m () -switchSession_ key f = do - new <- switchSession key - when new $ fromMaybe (return ()) f - --- | Delete existing session -deleteSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m () -deleteSession key = do - cur <- saveSession - when (preview (_Just . sessionKey) cur == Just key) $ - modify (set sessionActive Nothing) - msess <- gets (preview (sessionMap . ix key . _1)) - modify (set (sessionMap . at key) Nothing) - case msess of - Nothing -> return () - Just sess -> liftIO $ cleanupSession sess - --- | Save and restore session -restoreSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m a -> MGhcT s d m a -restoreSession act = bracket saveSession (maybe (return ()) (void . switchSession . view sessionKey)) $ const act - --- | Run action using session, restoring session back -usingSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a -usingSession key act = restoreSession $ do - void $ switchSession key - act - --- | Run with temporary session, like @usingSession@, but deletes self session -tempSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a -tempSession key act = do - exist' <- hasSession key - usingSession key act `finally` unless exist' (deleteSession key) - --- | Cleanup session -cleanupSession :: HscEnv -> IO () -cleanupSession env = do - cleanTemps df - stopIServ env - where - df = hsc_dflags env +{-# LANGUAGE CPP, UnicodeSyntax, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Tools.Ghc.MGhc ( + Session(..), sessionKey, sessionData, + SessionState(..), sessionActive, sessionMap, + MGhcT(..), runMGhcT, liftGhc, + currentSession, getSessionData, setSessionData, hasSession, findSession, findSessionBy, saveSession, + initSession, newSession, + switchSession, switchSession_, + deleteSession, restoreSession, usingSession, tempSession + ) where + +import Control.Lens +import Control.Monad.Fail as Fail +import Control.Monad.Morph +import Control.Monad.Catch +import Control.Monad.Reader +import Control.Monad.State +import Data.Default as Def +import Data.IORef +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, isJust) +import System.Log.Simple.Monad (MonadLog(..)) + +import HsDev.Tools.Ghc.Compat (cleanTemps) + +import DynFlags +import Exception hiding (catch, mask, uninterruptibleMask, bracket, finally) +import GHC +import GHCi +import GhcMonad hiding (Session(..)) +import qualified GhcMonad (Session(..)) +import HscTypes +import Outputable + +data Session s d = Session { + _sessionKey :: s, + _sessionData :: d } + deriving (Eq, Ord, Read, Show) + +sessionKey :: Lens' (Session s d) s +sessionKey = lens g s where + g = _sessionKey + s sess k = sess { _sessionKey = k } + +sessionData :: Lens' (Session s d) d +sessionData = lens g s where + g = _sessionData + s sess dat = sess { _sessionData = dat } + +data SessionState s d = SessionState { + _sessionActive :: Maybe (Session s d), + _sessionMap :: Map s (HscEnv, d) } + +instance Default (SessionState s d) where + def = SessionState Nothing M.empty + +sessionActive :: Lens' (SessionState s d) (Maybe (Session s d)) +sessionActive = lens g s where + g = _sessionActive + s st nm = st { _sessionActive = nm } + +sessionMap :: Lens' (SessionState s d) (Map s (HscEnv, d)) +sessionMap = lens g s where + g = _sessionMap + s st m = st { _sessionMap = m } + +instance ExceptionMonad m => ExceptionMonad (StateT s m) where + gcatch act onErr = StateT $ \st -> gcatch (runStateT act st) (\e -> runStateT (onErr e) st) + gmask f = StateT $ gmask . f' where + f' st' act' = runStateT (f act) st' where + act st = StateT $ act' . runStateT st + +instance ExceptionMonad m => ExceptionMonad (ReaderT r m) where + gcatch act onErr = ReaderT $ \v -> gcatch (runReaderT act v) (\e -> runReaderT (onErr e) v) + gmask f = ReaderT $ gmask . f' where + f' v' act' = runReaderT (f act) v' where + act v = ReaderT $ act' . runReaderT v + +-- | Multi-session ghc monad +newtype MGhcT s d m a = MGhcT { unMGhcT :: GhcT (ReaderT (Maybe FilePath) (StateT (SessionState s d) m)) a } + deriving (Functor, Applicative, Monad, MonadFail, MonadIO, ExceptionMonad, HasDynFlags, GhcMonad, MonadState (SessionState s d), MonadReader (Maybe FilePath), MonadThrow, MonadCatch, MonadMask, MonadLog) + +instance MonadTrans GhcT where + lift = liftGhcT + +instance MFunctor GhcT where + hoist fn = GhcT . (fn .) . unGhcT + +instance MonadFail m => MonadFail (GhcT m) where + fail = lift . Fail.fail + +instance MonadState st m => MonadState st (GhcT m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadReader r m => MonadReader r (GhcT m) where + ask = lift ask + local f act = GhcT $ local f . unGhcT act + +instance MonadThrow m => MonadThrow (GhcT m) where + throwM = lift . throwM + +instance MonadCatch m => MonadCatch (GhcT m) where + catch act onError = GhcT $ \sess -> catch (unGhcT act sess) (flip unGhcT sess . onError) + +instance MonadMask m => MonadMask (GhcT m) where + mask f = GhcT $ \s -> mask $ \g -> unGhcT (f $ q g) s where + q g' act = GhcT $ g' . unGhcT act + uninterruptibleMask f = GhcT $ \s -> uninterruptibleMask $ \g -> unGhcT (f $ q g) s where + q g' act = GhcT $ g' . unGhcT act +#if MIN_VERSION_exceptions(0,10,0) + generalBracket acq rel act = GhcT $ \r -> generalBracket + (unGhcT acq r) + (\res exitCase -> case exitCase of + ExitCaseSuccess v -> unGhcT (rel res (ExitCaseSuccess v)) r + ExitCaseException e -> unGhcT (rel res (ExitCaseException e)) r + ExitCaseAbort -> unGhcT (rel res ExitCaseAbort) r) + (\res -> unGhcT (act res) r) +#elif MIN_VERSION_exceptions(0,9,0) + generalBracket acq rel clean act = GhcT $ \r -> generalBracket + (unGhcT acq r) + (\res -> unGhcT (rel res) r) + (\res e -> unGhcT (clean res e) r) + (\res -> unGhcT (act res) r) +#endif + +-- | Run multi-session ghc +runMGhcT :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => Maybe FilePath -> MGhcT s d m a -> m a +runMGhcT lib act = do + ref <- liftIO $ newIORef (panic "empty session") + let + session = GhcMonad.Session ref + flip evalStateT Def.def $ flip runReaderT lib $ flip unGhcT session $ unMGhcT $ act `gfinally` cleanup + where + cleanup :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m () + cleanup = do + void saveSession + sessions <- gets (M.elems . view sessionMap) + liftIO $ mapM_ (cleanupSession . view _1) sessions + modify (set sessionMap M.empty) + +-- | Lift `Ghc` monad onto `MGhc` +liftGhc :: MonadIO m => Ghc a -> MGhcT s d m a +liftGhc (Ghc act) = MGhcT $ GhcT $ liftIO . act + +-- | Get current session +currentSession :: MonadIO m => MGhcT s d m (Maybe (Session s d)) +currentSession = gets (view sessionActive) + +-- | Get current session data +getSessionData :: MonadIO m => MGhcT s d m (Maybe d) +getSessionData = gets (preview (sessionActive . _Just . sessionData)) + +-- | Set current session data +setSessionData :: MonadIO m => d -> MGhcT s d m () +setSessionData sdata = modify (set (sessionActive . _Just . sessionData) sdata) + +-- | Does session exist +hasSession :: (MonadIO m, Ord s) => s -> MGhcT s d m Bool +hasSession key = do + msess <- findSession key + return $ isJust msess + +-- | Find session +findSession :: (MonadIO m, Ord s) => s -> MGhcT s d m (Maybe (Session s d)) +findSession key = do + sdata <- gets (preview (sessionMap . ix key . _2)) + return $ fmap (Session key) sdata + +-- | Find session by +findSessionBy :: MonadIO m => (s -> Bool) -> MGhcT s d m [Session s d] +findSessionBy p = do + sessions <- gets (M.toList . view sessionMap) + return [Session key sdata | (key, (_, sdata)) <- sessions, p key] + +-- | Save current session +saveSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m (Maybe (Session s d)) +saveSession = do + msess <- currentSession + case msess of + Just (Session key' dat') -> do + sess <- getSession + modify (set (sessionMap . at key') (Just (sess, dat'))) + Nothing -> return () + return msess + +-- | Initialize new session +initSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s d m () +initSession = do + lib <- ask + initGhcMonad lib + void saveSession + +activateSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m (Maybe HscEnv) +activateSession key = do + void saveSession + sdata <- gets (view (sessionMap . ix key . _2)) + modify (set sessionActive $ Just (Session key sdata)) + gets (preview (sessionMap . ix key . _1)) + +-- | Create new named session, deleting existing session +newSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m () +newSession key = do + msess <- activateSession key + maybe (return ()) (liftIO . cleanupSession) msess + initSession + +-- | Switch to session, creating if not exist, returns True if session was created +switchSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m Bool +switchSession key = do + msess <- activateSession key + case msess of + Nothing -> initSession >> return True + Just sess -> setSession sess >> return False + +-- | Switch to session, creating if not exist and initializing with passed function +switchSession_ :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> Maybe (MGhcT s d m ()) -> MGhcT s d m () +switchSession_ key f = do + new <- switchSession key + when new $ fromMaybe (return ()) f + +-- | Delete existing session +deleteSession :: (MonadIO m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m () +deleteSession key = do + cur <- saveSession + when (preview (_Just . sessionKey) cur == Just key) $ + modify (set sessionActive Nothing) + msess <- gets (preview (sessionMap . ix key . _1)) + modify (set (sessionMap . at key) Nothing) + case msess of + Nothing -> return () + Just sess -> liftIO $ cleanupSession sess + +-- | Save and restore session +restoreSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => MGhcT s d m a -> MGhcT s d m a +restoreSession act = bracket saveSession (maybe (return ()) (void . switchSession . view sessionKey)) $ const act + +-- | Run action using session, restoring session back +usingSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a +usingSession key act = restoreSession $ do + void $ switchSession key + act + +-- | Run with temporary session, like @usingSession@, but deletes self session +tempSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s, Monoid d) => s -> MGhcT s d m a -> MGhcT s d m a +tempSession key act = do + exist' <- hasSession key + usingSession key act `finally` unless exist' (deleteSession key) + +-- | Cleanup session +cleanupSession :: HscEnv -> IO () +cleanupSession env = do + cleanTemps df + stopIServ env + where + df = hsc_dflags env diff --git a/src/HsDev/Tools/Ghc/Prelude.hs b/src/HsDev/Tools/Ghc/Prelude.hs --- a/src/HsDev/Tools/Ghc/Prelude.hs +++ b/src/HsDev/Tools/Ghc/Prelude.hs @@ -1,91 +1,91 @@ -module HsDev.Tools.Ghc.Prelude ( - reduce, trim, - -- * Regexes - rx, srx, splitRx, - -- * Case - lowerCase, upperCase, titleCase, camelCase, underscoreCase, - - module Control.Lens, - module Data.Char, - module Data.List, - module Data.Maybe - ) where - -import Control.Lens -import Data.Array (assocs) -import Data.Char -import Data.List hiding (uncons) -import Data.Maybe -import Text.Regex.PCRE - --- | Reduce list to one element -reduce :: ([a] -> a) -> [a] -> [a] -reduce = (return .) - --- | Trim string -trim :: String -> String -trim = p . p where - p = reverse . dropWhile isSpace - --- | Match regex -rx :: String -> String -> Maybe String -rx r s = case s =~ r of - "" -> Nothing - res -> Just res - --- | Replace regex -srx :: String -> String -> String -> String -srx pat s = concat . unfoldr split' . Just where - split' :: Maybe String -> Maybe (String, Maybe String) - split' Nothing = Nothing - split' (Just str) = case mrMatch r of - "" -> Just (mrBefore r, Nothing) - _ -> Just (mrBefore r ++ subst, Just $ mrAfter r) - where - r = str =~ pat - groups = filter (not . null . snd) $ assocs $ mrSubs r - look i = lookup i groups - subst = subst' s where - subst' :: String -> String - subst' "" = "" - subst' "\\" = "\\" - subst' ('\\':'\\':ss') = '\\' : subst' ss' - subst' ('\\':ss') = case span isDigit ss' of - ([], _) -> '\\' : subst' ss' - (num, tl) -> fromMaybe "" (look $ read num) ++ subst' tl - subst' (s':ss') = s' : subst' ss' - --- | Split by regex -splitRx :: String -> String -> [String] -splitRx pat = unfoldr split' . Just where - split' :: Maybe String -> Maybe (String, Maybe String) - split' Nothing = Nothing - split' (Just str) = case mrMatch r of - "" -> Just (mrBefore r, Nothing) - _ -> Just (mrBefore r, Just $ mrAfter r) - where - r = str =~ pat - -lowerCase :: String -> String -lowerCase = map toLower - -upperCase :: String -> String -upperCase = map toUpper - --- | Convert to title case -titleCase :: String -> String -titleCase = over _head toUpper - --- | Convert to camel case -camelCase :: String -> String -camelCase = concatMap titleCase . splitRx "[\\s_]+" - --- | Convert to underscore case -underscoreCase :: String -> String -underscoreCase = intercalate "_" . map lowerCase . unfoldr break' where - break' :: String -> Maybe (String, String) - break' str = do - (s, ss) <- uncons str - let - (h, tl) = break isUpper ss - return (s:h, tl) +module HsDev.Tools.Ghc.Prelude ( + reduce, trim, + -- * Regexes + rx, srx, splitRx, + -- * Case + lowerCase, upperCase, titleCase, camelCase, underscoreCase, + + module Control.Lens, + module Data.Char, + module Data.List, + module Data.Maybe + ) where + +import Control.Lens +import Data.Array (assocs) +import Data.Char +import Data.List hiding (uncons) +import Data.Maybe +import Text.Regex.PCRE + +-- | Reduce list to one element +reduce :: ([a] -> a) -> [a] -> [a] +reduce = (return .) + +-- | Trim string +trim :: String -> String +trim = p . p where + p = reverse . dropWhile isSpace + +-- | Match regex +rx :: String -> String -> Maybe String +rx r s = case s =~ r of + "" -> Nothing + res -> Just res + +-- | Replace regex +srx :: String -> String -> String -> String +srx pat s = concat . unfoldr split' . Just where + split' :: Maybe String -> Maybe (String, Maybe String) + split' Nothing = Nothing + split' (Just str) = case mrMatch r of + "" -> Just (mrBefore r, Nothing) + _ -> Just (mrBefore r ++ subst, Just $ mrAfter r) + where + r = str =~ pat + groups = filter (not . null . snd) $ assocs $ mrSubs r + look i = lookup i groups + subst = subst' s where + subst' :: String -> String + subst' "" = "" + subst' "\\" = "\\" + subst' ('\\':'\\':ss') = '\\' : subst' ss' + subst' ('\\':ss') = case span isDigit ss' of + ([], _) -> '\\' : subst' ss' + (num, tl) -> fromMaybe "" (look $ read num) ++ subst' tl + subst' (s':ss') = s' : subst' ss' + +-- | Split by regex +splitRx :: String -> String -> [String] +splitRx pat = unfoldr split' . Just where + split' :: Maybe String -> Maybe (String, Maybe String) + split' Nothing = Nothing + split' (Just str) = case mrMatch r of + "" -> Just (mrBefore r, Nothing) + _ -> Just (mrBefore r, Just $ mrAfter r) + where + r = str =~ pat + +lowerCase :: String -> String +lowerCase = map toLower + +upperCase :: String -> String +upperCase = map toUpper + +-- | Convert to title case +titleCase :: String -> String +titleCase = over _head toUpper + +-- | Convert to camel case +camelCase :: String -> String +camelCase = concatMap titleCase . splitRx "[\\s_]+" + +-- | Convert to underscore case +underscoreCase :: String -> String +underscoreCase = intercalate "_" . map lowerCase . unfoldr break' where + break' :: String -> Maybe (String, String) + break' str = do + (s, ss) <- uncons str + let + (h, tl) = break isUpper ss + return (s:h, tl) diff --git a/src/HsDev/Tools/Ghc/Repl.hs b/src/HsDev/Tools/Ghc/Repl.hs --- a/src/HsDev/Tools/Ghc/Repl.hs +++ b/src/HsDev/Tools/Ghc/Repl.hs @@ -1,57 +1,57 @@ -{-# LANGUAGE OverloadedStrings, TypeApplications #-} - -module HsDev.Tools.Ghc.Repl ( - importModules, preludeModules, - evaluate, - expressionType, - - ReplResult(..), - tryRepl - ) where - -import Control.Monad -import Control.Monad.Catch -import Data.Aeson -import Data.Dynamic -import Text.Format - -import GhcMonad -import GHC - -import HsDev.Tools.Ghc.Base -import qualified HsDev.Tools.Ghc.Compat as C -import HsDev.Util - --- | Import some modules -importModules :: GhcMonad m => [String] -> m () -importModules mods = mapM parseImportDecl ["import " ++ m | m <- mods] >>= setContext . map IIDecl - --- | Default interpreter modules -preludeModules :: [String] -preludeModules = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"] - --- | Evaluate expression -evaluate :: GhcMonad m => String -> m String -evaluate expr = liftM fromDynamic (dynCompileExpr $ "show ({})" ~~ expr) >>= - maybe (fail "evaluate fail") return - --- | Get expression type as string -expressionType :: GhcMonad m => String -> m String -expressionType expr = do - dflags <- getSessionDynFlags - ty <- C.exprType expr - return $ formatType dflags ty - -data ReplResult a = ReplError String | ReplOk a deriving (Eq, Ord, Read, Show) - -instance ToJSON a => ToJSON (ReplResult a) where - toJSON (ReplError e) = object ["error" .= e] - toJSON (ReplOk v) = object ["ok" .= v] - -instance FromJSON a => FromJSON (ReplResult a) where - parseJSON = withObject "repl-result" $ \v -> msum [ - ReplError <$> v .:: "error", - ReplOk <$> v .:: "ok"] - -tryRepl :: (GhcMonad m, MonadCatch m) => m a -> m (ReplResult a) -tryRepl = fmap (either (ReplError . displayException @SomeException) ReplOk) . try +{-# LANGUAGE OverloadedStrings, TypeApplications #-} + +module HsDev.Tools.Ghc.Repl ( + importModules, preludeModules, + evaluate, + expressionType, + + ReplResult(..), + tryRepl + ) where + +import Control.Monad +import Control.Monad.Catch +import Data.Aeson +import Data.Dynamic +import Text.Format + +import GhcMonad +import GHC + +import HsDev.Tools.Ghc.Base +import qualified HsDev.Tools.Ghc.Compat as C +import HsDev.Util + +-- | Import some modules +importModules :: GhcMonad m => [String] -> m () +importModules mods = mapM parseImportDecl ["import " ++ m | m <- mods] >>= setContext . map IIDecl + +-- | Default interpreter modules +preludeModules :: [String] +preludeModules = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"] + +-- | Evaluate expression +evaluate :: GhcMonad m => String -> m String +evaluate expr = liftM fromDynamic (dynCompileExpr $ "show ({})" ~~ expr) >>= + maybe (fail "evaluate fail") return + +-- | Get expression type as string +expressionType :: GhcMonad m => String -> m String +expressionType expr = do + dflags <- getSessionDynFlags + ty <- C.exprType expr + return $ formatType dflags ty + +data ReplResult a = ReplError String | ReplOk a deriving (Eq, Ord, Read, Show) + +instance ToJSON a => ToJSON (ReplResult a) where + toJSON (ReplError e) = object ["error" .= e] + toJSON (ReplOk v) = object ["ok" .= v] + +instance FromJSON a => FromJSON (ReplResult a) where + parseJSON = withObject "repl-result" $ \v -> msum [ + ReplError <$> v .:: "error", + ReplOk <$> v .:: "ok"] + +tryRepl :: (GhcMonad m, MonadCatch m) => m a -> m (ReplResult a) +tryRepl = fmap (either (ReplError . displayException @SomeException) ReplOk) . try diff --git a/src/HsDev/Tools/Ghc/Session.hs b/src/HsDev/Tools/Ghc/Session.hs --- a/src/HsDev/Tools/Ghc/Session.hs +++ b/src/HsDev/Tools/Ghc/Session.hs @@ -1,42 +1,42 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Tools.Ghc.Session ( - targetSession, interpretModule, - - module HsDev.Tools.Ghc.Worker - ) where - -import Control.Lens -import Data.Maybe (isJust) -import Data.Text (Text, unpack) -import System.Log.Simple - -import Control.Concurrent.Worker -import System.Directory.Paths -import HsDev.Symbols.Types -import HsDev.Sandbox (getModuleOpts) -import HsDev.Tools.Ghc.Worker - -import qualified GHC - --- | Session for module -targetSession :: [String] -> Module -> GhcM () -targetSession opts m = do - (pdbs, opts') <- getModuleOpts opts m - ghcSession pdbs ("-Wall" : opts') - --- | Interpret file -interpretModule :: Module -> Maybe Text -> GhcM () -interpretModule m mcts - | isJust mpath = do - let - rootDir = maybe (takeDir fpath) (view projectPath) (m ^? moduleId . moduleLocation . moduleProject . _Just) - withCurrentDirectory (view path rootDir) $ do - t <- makeTarget (relPathTo rootDir fpath) mcts - loadTargets [t] - GHC.setContext [GHC.IIModule . GHC.mkModuleName . unpack . view (moduleId . moduleName) $ m] - | otherwise = return () - where - mpath = m ^? moduleId . moduleLocation . moduleFile - Just fpath = mpath +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Tools.Ghc.Session ( + targetSession, interpretModule, + + module HsDev.Tools.Ghc.Worker + ) where + +import Control.Lens +import Data.Maybe (isJust) +import Data.Text (Text, unpack) +import System.Log.Simple + +import Control.Concurrent.Worker +import System.Directory.Paths +import HsDev.Symbols.Types +import HsDev.Sandbox (getModuleOpts) +import HsDev.Tools.Ghc.Worker + +import qualified GHC + +-- | Session for module +targetSession :: [String] -> Module -> GhcM () +targetSession opts m = do + (pdbs, opts') <- getModuleOpts opts m + ghcSession pdbs ("-Wall" : opts') + +-- | Interpret file +interpretModule :: Module -> Maybe Text -> GhcM () +interpretModule m mcts + | isJust mpath = do + let + rootDir = maybe (takeDir fpath) (view projectPath) (m ^? moduleId . moduleLocation . moduleProject . _Just) + withCurrentDirectory (view path rootDir) $ do + t <- makeTarget (relPathTo rootDir fpath) mcts + loadTargets [t] + GHC.setContext [GHC.IIModule . GHC.mkModuleName . unpack . view (moduleId . moduleName) $ m] + | otherwise = return () + where + mpath = m ^? moduleId . moduleLocation . moduleFile + Just fpath = mpath diff --git a/src/HsDev/Tools/Ghc/System.hs b/src/HsDev/Tools/Ghc/System.hs --- a/src/HsDev/Tools/Ghc/System.hs +++ b/src/HsDev/Tools/Ghc/System.hs @@ -1,55 +1,55 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HsDev.Tools.Ghc.System ( - BuildInfo(..), buildInfo, - examineCompilerVersion, - - formatBuildPath, buildPath - ) where - -import Control.Arrow -import qualified Data.Map as M -import Data.Maybe -import Distribution.Text (display) -import Distribution.System (buildOS) -import qualified System.Info as Sys -import Text.Format - -import DynFlags (DynFlags) -import PackageConfig as GHC -import GHC (getSessionDynFlags) - -import HsDev.Tools.Ghc.Compat as Compat -import HsDev.Tools.Ghc.Worker (GhcM) - -data BuildInfo = BuildInfo { - targetArch :: String, - targetOS :: String, - cabalOS :: String, - compilerName :: String, - compilerVersion :: String } - -buildInfo :: DynFlags -> BuildInfo -buildInfo = BuildInfo Sys.arch Sys.os (display buildOS) Sys.compilerName . examineCompilerVersion - -examineCompilerVersion :: DynFlags -> String -examineCompilerVersion = - display . - fromMaybe Sys.compilerVersion . - M.lookup Sys.compilerName . - M.fromList . - map (GHC.packageNameString &&& GHC.packageVersion) . - fromMaybe [] . Compat.pkgDatabase - --- | Can contain {arch}, {os}/{platform}, {compiler}, {version} -formatBuildPath :: String -> BuildInfo -> String -formatBuildPath f = formats f . toArgs where - toArgs b = [ - "arch" ~% targetArch b, - "os" ~% targetOS b, - "os/cabal" ~% cabalOS b, - "compiler" ~% compilerName b, - "version" ~% compilerVersion b] - -buildPath :: String -> GhcM FilePath -buildPath f = fmap (formatBuildPath f . buildInfo) getSessionDynFlags +{-# LANGUAGE OverloadedStrings #-} + +module HsDev.Tools.Ghc.System ( + BuildInfo(..), buildInfo, + examineCompilerVersion, + + formatBuildPath, buildPath + ) where + +import Control.Arrow +import qualified Data.Map as M +import Data.Maybe +import Distribution.Text (display) +import Distribution.System (buildOS) +import qualified System.Info as Sys +import Text.Format + +import DynFlags (DynFlags) +import PackageConfig as GHC +import GHC (getSessionDynFlags) + +import HsDev.Tools.Ghc.Compat as Compat +import HsDev.Tools.Ghc.Worker (GhcM) + +data BuildInfo = BuildInfo { + targetArch :: String, + targetOS :: String, + cabalOS :: String, + compilerName :: String, + compilerVersion :: String } + +buildInfo :: DynFlags -> BuildInfo +buildInfo = BuildInfo Sys.arch Sys.os (display buildOS) Sys.compilerName . examineCompilerVersion + +examineCompilerVersion :: DynFlags -> String +examineCompilerVersion = + display . + fromMaybe Sys.compilerVersion . + M.lookup Sys.compilerName . + M.fromList . + map (GHC.packageNameString &&& GHC.packageVersion) . + fromMaybe [] . Compat.pkgDatabase + +-- | Can contain {arch}, {os}/{platform}, {compiler}, {version} +formatBuildPath :: String -> BuildInfo -> String +formatBuildPath f = formats f . toArgs where + toArgs b = [ + "arch" ~% targetArch b, + "os" ~% targetOS b, + "os/cabal" ~% cabalOS b, + "compiler" ~% compilerName b, + "version" ~% compilerVersion b] + +buildPath :: String -> GhcM FilePath +buildPath f = fmap (formatBuildPath f . buildInfo) getSessionDynFlags diff --git a/src/HsDev/Tools/Ghc/Types.hs b/src/HsDev/Tools/Ghc/Types.hs --- a/src/HsDev/Tools/Ghc/Types.hs +++ b/src/HsDev/Tools/Ghc/Types.hs @@ -1,152 +1,152 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, TemplateHaskell, OverloadedStrings #-} - -module HsDev.Tools.Ghc.Types ( - TypedExpr(..), typedExpr, typedType, - moduleTypes, fileTypes, - setModuleTypes, inferTypes - ) where - -import Control.DeepSeq -import Control.Lens (over, view, set, each, preview, makeLenses, _Just) -import Control.Monad -import Control.Monad.Fail (MonadFail) -import Control.Monad.IO.Class -import Data.Aeson -import Data.Generics -import Data.List (find) -import Data.Maybe -import Data.String (fromString) -import Data.Text (Text) -import System.Log.Simple (MonadLog(..), scope) - -import GHC hiding (exprType, Module, moduleName) -import GhcPlugins (mkFunTys) -import CoreUtils as C -import NameSet (NameSet) -import Desugar (deSugarExpr) -import TcHsSyn (hsPatType) -import Outputable -import PprTyThing -import qualified Pretty - -import System.Directory.Paths -import HsDev.Error -import HsDev.Symbols -import HsDev.Tools.Ghc.Worker as Ghc -import HsDev.Tools.Ghc.Compat -import HsDev.Tools.Types -import HsDev.Util - -class HasType a where - getType :: GhcMonad m => a -> m (Maybe (SrcSpan, Type)) - -instance HasType (LHsExpr TcId) where - getType e = do - env <- getSession - mbe <- liftIO $ liftM snd $ deSugarExpr env e - return $ do - ex <- mbe - return (getLoc e, C.exprType ex) - -instance HasType (LHsBind TcId) where - getType (L _ FunBind { fun_id = fid, fun_matches = m}) = return $ do - argTys <- mgArgTys m - resTy <- mgResTy m - return (getLoc fid, mkFunTys argTys resTy) - getType _ = return Nothing - -instance HasType (LPat TcId) where - getType (L spn pat) = return $ Just (spn, hsPatType pat) - -locatedTypes :: Typeable a => TypecheckedSource -> [Located a] -locatedTypes = types' p where - types' :: Typeable r => (r -> Bool) -> GenericQ [r] - types' p' = everythingTyped (++) [] ([] `mkQ` (\x -> [x | p' x])) - p (L spn _) = isGoodSrcSpan spn - -everythingTyped :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r -everythingTyped k z f x - | (const False `extQ` nameSet) x = z - | otherwise = foldl k (f x) (gmapQ (everythingTyped k z f) x) - where - nameSet :: NameSet -> Bool - nameSet = const True - -moduleTypes :: (MonadFail m, GhcMonad m) => Path -> m [(SrcSpan, Type)] -moduleTypes fpath = do - fpath' <- liftIO $ canonicalize fpath - mg <- getModuleGraph - [m] <- liftIO $ flip filterM (modSummaries mg) $ \m -> do - mfile <- traverse (liftIO . canonicalize) $ ml_hs_file (ms_location m) - return (Just (view path fpath') == mfile) - p <- parseModule m - tm <- typecheckModule p - let - ts = tm_typechecked_source tm - liftM (catMaybes . concat) $ sequence [ - mapM getType (locatedTypes ts :: [LHsExpr TcId]), - mapM getType (locatedTypes ts :: [LHsBind TcId]), - mapM getType (locatedTypes ts :: [LPat TcId])] - -data TypedExpr = TypedExpr { - _typedExpr :: Maybe Text, - _typedType :: Text } - deriving (Eq, Ord, Read, Show) - -makeLenses ''TypedExpr - -instance NFData TypedExpr where - rnf (TypedExpr e t) = rnf e `seq` rnf t - -instance ToJSON TypedExpr where - toJSON (TypedExpr e t) = object $ noNulls [ - "expr" .= e, - "type" .= t] - -instance FromJSON TypedExpr where - parseJSON = withObject "typed-expr" $ \v -> TypedExpr <$> - v .::? "expr" <*> - v .:: "type" - --- | Get all types in module -fileTypes :: (MonadLog m, MonadFail m, GhcMonad m) => Module -> Maybe Text -> m [Note TypedExpr] -fileTypes m msrc = scope "types" $ case view (moduleId . moduleLocation) m of - FileModule file proj -> do - file' <- liftIO $ canonicalize file - cts <- maybe (liftIO $ readFileUtf8 (view path file')) return msrc - let - dir = fromMaybe - (sourceModuleRoot (view (moduleId . moduleName) m) file') $ - preview (_Just . projectPath) proj - ex <- liftIO $ dirExists dir - (if ex then Ghc.withCurrentDirectory (view path dir) else id) $ do - target <- makeTarget (relPathTo dir file') msrc - loadTargets [target] - ts <- moduleTypes file' - df <- getSessionDynFlags - return $ map (setExpr cts . recalcTabs cts 8 . uncurry (toNote df)) ts - _ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m) - where - toNote :: DynFlags -> SrcSpan -> Type -> Note Text - toNote df spn tp = Note { - _noteSource = noLocation, - _noteRegion = spanRegion spn, - _noteLevel = Nothing, - _note = fromString $ showType df tp } - setExpr :: Text -> Note Text -> Note TypedExpr - setExpr cts n = over note (TypedExpr (Just (regionStr (view noteRegion n) cts))) n - showType :: DynFlags -> Type -> String - showType df = renderStyle Pretty.OneLineMode 80 . withPprStyleDoc df (unqualStyle df) . pprTypeForUser - --- | Set types to module -setModuleTypes :: [Note TypedExpr] -> Module -> Module -setModuleTypes ts = over (moduleScope . each . each) setType . over (moduleExports . each) setType where - setType :: Symbol -> Symbol - setType d = fromMaybe d $ do - pos <- view symbolPosition d - tnote <- find ((== pos) . view (noteRegion . regionFrom)) ts - return $ set (symbolInfo . functionType) (Just $ view (note . typedType) tnote) d - --- | Infer types in module -inferTypes :: (MonadLog m, MonadFail m, GhcMonad m) => Module -> Maybe Text -> m Module -inferTypes m msrc = scope "infer" $ liftM (`setModuleTypes` m) $ fileTypes m msrc +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, TemplateHaskell, OverloadedStrings #-} + +module HsDev.Tools.Ghc.Types ( + TypedExpr(..), typedExpr, typedType, + moduleTypes, fileTypes, + setModuleTypes, inferTypes + ) where + +import Control.DeepSeq +import Control.Lens (over, view, set, each, preview, makeLenses, _Just) +import Control.Monad +import Control.Monad.Fail (MonadFail) +import Control.Monad.IO.Class +import Data.Aeson +import Data.Generics +import Data.List (find) +import Data.Maybe +import Data.String (fromString) +import Data.Text (Text) +import System.Log.Simple (MonadLog(..), scope) + +import GHC hiding (exprType, Module, moduleName) +import GhcPlugins (mkFunTys) +import CoreUtils as C +import NameSet (NameSet) +import Desugar (deSugarExpr) +import TcHsSyn (hsPatType) +import Outputable +import PprTyThing +import qualified Pretty + +import System.Directory.Paths +import HsDev.Error +import HsDev.Symbols +import HsDev.Tools.Ghc.Worker as Ghc +import HsDev.Tools.Ghc.Compat +import HsDev.Tools.Types +import HsDev.Util + +class HasType a where + getType :: GhcMonad m => a -> m (Maybe (SrcSpan, Type)) + +instance HasType (LHsExpr TcId) where + getType e = do + env <- getSession + mbe <- liftIO $ liftM snd $ deSugarExpr env e + return $ do + ex <- mbe + return (getLoc e, C.exprType ex) + +instance HasType (LHsBind TcId) where + getType (L _ FunBind { fun_id = fid, fun_matches = m}) = return $ do + argTys <- mgArgTys m + resTy <- mgResTy m + return (getLoc fid, mkFunTys argTys resTy) + getType _ = return Nothing + +instance HasType (LPat TcId) where + getType (L spn pat) = return $ Just (spn, hsPatType pat) + +locatedTypes :: Typeable a => TypecheckedSource -> [Located a] +locatedTypes = types' p where + types' :: Typeable r => (r -> Bool) -> GenericQ [r] + types' p' = everythingTyped (++) [] ([] `mkQ` (\x -> [x | p' x])) + p (L spn _) = isGoodSrcSpan spn + +everythingTyped :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r +everythingTyped k z f x + | (const False `extQ` nameSet) x = z + | otherwise = foldl k (f x) (gmapQ (everythingTyped k z f) x) + where + nameSet :: NameSet -> Bool + nameSet = const True + +moduleTypes :: (MonadFail m, GhcMonad m) => Path -> m [(SrcSpan, Type)] +moduleTypes fpath = do + fpath' <- liftIO $ canonicalize fpath + mg <- getModuleGraph + [m] <- liftIO $ flip filterM (modSummaries mg) $ \m -> do + mfile <- traverse (liftIO . canonicalize) $ ml_hs_file (ms_location m) + return (Just (view path fpath') == mfile) + p <- parseModule m + tm <- typecheckModule p + let + ts = tm_typechecked_source tm + liftM (catMaybes . concat) $ sequence [ + mapM getType (locatedTypes ts :: [LHsExpr TcId]), + mapM getType (locatedTypes ts :: [LHsBind TcId]), + mapM getType (locatedTypes ts :: [LPat TcId])] + +data TypedExpr = TypedExpr { + _typedExpr :: Maybe Text, + _typedType :: Text } + deriving (Eq, Ord, Read, Show) + +makeLenses ''TypedExpr + +instance NFData TypedExpr where + rnf (TypedExpr e t) = rnf e `seq` rnf t + +instance ToJSON TypedExpr where + toJSON (TypedExpr e t) = object $ noNulls [ + "expr" .= e, + "type" .= t] + +instance FromJSON TypedExpr where + parseJSON = withObject "typed-expr" $ \v -> TypedExpr <$> + v .::? "expr" <*> + v .:: "type" + +-- | Get all types in module +fileTypes :: (MonadLog m, MonadFail m, GhcMonad m) => Module -> Maybe Text -> m [Note TypedExpr] +fileTypes m msrc = scope "types" $ case view (moduleId . moduleLocation) m of + FileModule file proj -> do + file' <- liftIO $ canonicalize file + cts <- maybe (liftIO $ readFileUtf8 (view path file')) return msrc + let + dir = fromMaybe + (sourceModuleRoot (view (moduleId . moduleName) m) file') $ + preview (_Just . projectPath) proj + ex <- liftIO $ dirExists dir + (if ex then Ghc.withCurrentDirectory (view path dir) else id) $ do + target <- makeTarget (relPathTo dir file') msrc + loadTargets [target] + ts <- moduleTypes file' + df <- getSessionDynFlags + return $ map (setExpr cts . recalcTabs cts 8 . uncurry (toNote df)) ts + _ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m) + where + toNote :: DynFlags -> SrcSpan -> Type -> Note Text + toNote df spn tp = Note { + _noteSource = noLocation, + _noteRegion = spanRegion spn, + _noteLevel = Nothing, + _note = fromString $ showType df tp } + setExpr :: Text -> Note Text -> Note TypedExpr + setExpr cts n = over note (TypedExpr (Just (regionStr (view noteRegion n) cts))) n + showType :: DynFlags -> Type -> String + showType df = renderStyle Pretty.OneLineMode 80 . withPprStyleDoc df (unqualStyle df) . pprTypeForUser + +-- | Set types to module +setModuleTypes :: [Note TypedExpr] -> Module -> Module +setModuleTypes ts = over (moduleScope . each . each) setType . over (moduleExports . each) setType where + setType :: Symbol -> Symbol + setType d = fromMaybe d $ do + pos <- view symbolPosition d + tnote <- find ((== pos) . view (noteRegion . regionFrom)) ts + return $ set (symbolInfo . functionType) (Just $ view (note . typedType) tnote) d + +-- | Infer types in module +inferTypes :: (MonadLog m, MonadFail m, GhcMonad m) => Module -> Maybe Text -> m Module +inferTypes m msrc = scope "infer" $ liftM (`setModuleTypes` m) $ fileTypes m msrc diff --git a/src/HsDev/Tools/Ghc/Worker.hs b/src/HsDev/Tools/Ghc/Worker.hs --- a/src/HsDev/Tools/Ghc/Worker.hs +++ b/src/HsDev/Tools/Ghc/Worker.hs @@ -1,131 +1,131 @@ -{-# LANGUAGE PatternGuards, OverloadedStrings, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Tools.Ghc.Worker ( - -- * Workers - SessionType(..), SessionConfig(..), - GhcM, GhcWorker, MGhcT(..), runGhcM, - ghcWorker, - workerSession, ghcSession, ghciSession, haddockSession, tmpSession, - - Ghc, - LogT(..), - - module HsDev.Tools.Ghc.Base, - module HsDev.Tools.Ghc.Repl, - module HsDev.Tools.Ghc.MGhc, - module Control.Concurrent.Worker - ) where - -import Control.Lens (view) -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Catch -import Data.Monoid -import qualified System.Log.Simple as Log -import System.Log.Simple.Monad (MonadLog(..), LogT(..), withLog) -import Text.Format hiding (withFlags) - -import Exception (ExceptionMonad(..), ghandle) -import GHC hiding (Warning, Module) -import GHC.Paths - -import Control.Concurrent.Worker -import HsDev.PackageDb.Types -import HsDev.Tools.Ghc.Base -import HsDev.Tools.Ghc.Repl -import HsDev.Tools.Ghc.MGhc - -data SessionType = SessionGhci | SessionGhc | SessionHaddock | SessionTmp deriving (Eq, Ord) -data SessionConfig = SessionConfig SessionType PackageDbStack deriving (Eq, Ord) - -instance Show SessionType where - show SessionGhci = "ghci" - show SessionGhc = "ghc" - show SessionHaddock = "haddock" - show SessionTmp = "tmp" - -instance Formattable SessionType - -instance Show SessionConfig where - show (SessionConfig t pdb) = "{} {}" ~~ t ~~ pdb - -instance Formattable SessionConfig - -type GhcM a = MGhcT SessionConfig (First DynFlags) (LogT IO) a - -type GhcWorker = Worker (MGhcT SessionConfig (First DynFlags) (LogT IO)) - -instance (Monad m, GhcMonad m) => GhcMonad (ReaderT r m) where - getSession = lift getSession - setSession = lift . setSession - -instance ExceptionMonad m => ExceptionMonad (LogT m) where - gcatch act onError = LogT $ gcatch (runLogT act) (runLogT . onError) - gmask f = LogT $ gmask f' where - f' g' = runLogT $ f (LogT . g' . runLogT) - -instance MonadThrow Ghc where - throwM = liftIO . throwM - -runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a -runGhcM dir act = do - l <- Log.askLog - liftIO $ withLog l $ runMGhcT dir act - --- | Multi-session ghc worker -ghcWorker :: MonadLog m => m GhcWorker -ghcWorker = do - l <- Log.askLog - liftIO $ startWorker (withLog l . runGhcM (Just libdir)) (Log.scope "ghc") (ghandle logErr) - where - logErr :: MonadLog m => SomeException -> m () - logErr e = Log.sendLog Log.Warning ("exception in ghc worker task: {}" ~~ displayException e) - --- | Create session with options -workerSession :: SessionType -> PackageDbStack -> [String] -> GhcM () -workerSession ty pdbs opts = do - ms <- findSessionBy toKill - forM_ ms $ \s' -> do - Log.sendLog Log.Trace $ "killing session: {}" ~~ view sessionKey s' - deleteSession $ view sessionKey s' - Log.sendLog Log.Trace $ "session: {}" ~~ SessionConfig ty pdbs - switchSession_ (SessionConfig ty pdbs) $ Just initialize - setSessionFlags - where - toKill (SessionConfig ty' pdbs') = or [ - (ty == ty' && pdbs /= pdbs'), - (ty /= ty' && ty' `elem` [SessionTmp, SessionHaddock] && ty /= SessionTmp)] - initialize = do - run - dflags <- getSessionDynFlags - setSessionData (First $ Just dflags) - run = case ty of - SessionGhci -> ghcRun pdbsOpts (importModules preludeModules) - SessionGhc -> ghcRun pdbsOpts (return ()) - SessionTmp -> ghcRun pdbsOpts (return ()) - SessionHaddock -> ghcRunWith noLinkFlags ("-haddock" : pdbsOpts) (return ()) - setSessionFlags = do - Log.sendLog Log.Trace $ "setting flags: {}" ~~ unwords opts - mdflags <- fmap (join . fmap getFirst) getSessionData - dflags <- maybe getSessionDynFlags return mdflags - (df', _, _) <- parseDynamicFlags dflags (map noLoc opts) - void $ setSessionDynFlags df' - pdbsOpts = packageDbStackOpts pdbs - --- | Get ghc session -ghcSession :: PackageDbStack -> [String] -> GhcM () -ghcSession = workerSession SessionGhc - --- | Get ghci session -ghciSession :: GhcM () -ghciSession = workerSession SessionGhci userDb [] - --- | Get haddock session with flags -haddockSession :: PackageDbStack -> [String] -> GhcM () -haddockSession = workerSession SessionHaddock - --- | Get haddock session with flags -tmpSession :: PackageDbStack -> [String] -> GhcM () -tmpSession = workerSession SessionTmp +{-# LANGUAGE PatternGuards, OverloadedStrings, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Tools.Ghc.Worker ( + -- * Workers + SessionType(..), SessionConfig(..), + GhcM, GhcWorker, MGhcT(..), runGhcM, + ghcWorker, + workerSession, ghcSession, ghciSession, haddockSession, tmpSession, + + Ghc, + LogT(..), + + module HsDev.Tools.Ghc.Base, + module HsDev.Tools.Ghc.Repl, + module HsDev.Tools.Ghc.MGhc, + module Control.Concurrent.Worker + ) where + +import Control.Lens (view) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Catch +import Data.Monoid +import qualified System.Log.Simple as Log +import System.Log.Simple.Monad (MonadLog(..), LogT(..), withLog) +import Text.Format hiding (withFlags) + +import Exception (ExceptionMonad(..), ghandle) +import GHC hiding (Warning, Module) +import GHC.Paths + +import Control.Concurrent.Worker +import HsDev.PackageDb.Types +import HsDev.Tools.Ghc.Base +import HsDev.Tools.Ghc.Repl +import HsDev.Tools.Ghc.MGhc + +data SessionType = SessionGhci | SessionGhc | SessionHaddock | SessionTmp deriving (Eq, Ord) +data SessionConfig = SessionConfig SessionType PackageDbStack deriving (Eq, Ord) + +instance Show SessionType where + show SessionGhci = "ghci" + show SessionGhc = "ghc" + show SessionHaddock = "haddock" + show SessionTmp = "tmp" + +instance Formattable SessionType + +instance Show SessionConfig where + show (SessionConfig t pdb) = "{} {}" ~~ t ~~ pdb + +instance Formattable SessionConfig + +type GhcM a = MGhcT SessionConfig (First DynFlags) (LogT IO) a + +type GhcWorker = Worker (MGhcT SessionConfig (First DynFlags) (LogT IO)) + +instance (Monad m, GhcMonad m) => GhcMonad (ReaderT r m) where + getSession = lift getSession + setSession = lift . setSession + +instance ExceptionMonad m => ExceptionMonad (LogT m) where + gcatch act onError = LogT $ gcatch (runLogT act) (runLogT . onError) + gmask f = LogT $ gmask f' where + f' g' = runLogT $ f (LogT . g' . runLogT) + +instance MonadThrow Ghc where + throwM = liftIO . throwM + +runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a +runGhcM dir act = do + l <- Log.askLog + liftIO $ withLog l $ runMGhcT dir act + +-- | Multi-session ghc worker +ghcWorker :: MonadLog m => m GhcWorker +ghcWorker = do + l <- Log.askLog + liftIO $ startWorker (withLog l . runGhcM (Just libdir)) (Log.scope "ghc") (ghandle logErr) + where + logErr :: MonadLog m => SomeException -> m () + logErr e = Log.sendLog Log.Warning ("exception in ghc worker task: {}" ~~ displayException e) + +-- | Create session with options +workerSession :: SessionType -> PackageDbStack -> [String] -> GhcM () +workerSession ty pdbs opts = do + ms <- findSessionBy toKill + forM_ ms $ \s' -> do + Log.sendLog Log.Trace $ "killing session: {}" ~~ view sessionKey s' + deleteSession $ view sessionKey s' + Log.sendLog Log.Trace $ "session: {}" ~~ SessionConfig ty pdbs + switchSession_ (SessionConfig ty pdbs) $ Just initialize + setSessionFlags + where + toKill (SessionConfig ty' pdbs') = or [ + (ty == ty' && pdbs /= pdbs'), + (ty /= ty' && ty' `elem` [SessionTmp, SessionHaddock] && ty /= SessionTmp)] + initialize = do + run + dflags <- getSessionDynFlags + setSessionData (First $ Just dflags) + run = case ty of + SessionGhci -> ghcRun pdbsOpts (importModules preludeModules) + SessionGhc -> ghcRun pdbsOpts (return ()) + SessionTmp -> ghcRun pdbsOpts (return ()) + SessionHaddock -> ghcRunWith noLinkFlags ("-haddock" : pdbsOpts) (return ()) + setSessionFlags = do + Log.sendLog Log.Trace $ "setting flags: {}" ~~ unwords opts + mdflags <- fmap (join . fmap getFirst) getSessionData + dflags <- maybe getSessionDynFlags return mdflags + (df', _, _) <- parseDynamicFlags dflags (map noLoc opts) + void $ setSessionDynFlags df' + pdbsOpts = packageDbStackOpts pdbs + +-- | Get ghc session +ghcSession :: PackageDbStack -> [String] -> GhcM () +ghcSession = workerSession SessionGhc + +-- | Get ghci session +ghciSession :: GhcM () +ghciSession = workerSession SessionGhci userDb [] + +-- | Get haddock session with flags +haddockSession :: PackageDbStack -> [String] -> GhcM () +haddockSession = workerSession SessionHaddock + +-- | Get haddock session with flags +tmpSession :: PackageDbStack -> [String] -> GhcM () +tmpSession = workerSession SessionTmp diff --git a/src/HsDev/Tools/HDocs.hs b/src/HsDev/Tools/HDocs.hs --- a/src/HsDev/Tools/HDocs.hs +++ b/src/HsDev/Tools/HDocs.hs @@ -1,179 +1,179 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} - -module HsDev.Tools.HDocs ( - hdocsy, hdocs, hdocsPackage, hdocsCabal, - setSymbolDocs, setDocs, setModuleDocs, - - hdocsProcess, - - readDocs, readModuleDocs, readProjectTargetDocs, - - hdocsSupported, - - module Control.Monad.Except - ) where - -import Control.Lens -import Control.Monad () -import Control.Monad.Except - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text) -#ifdef NODOCS -import qualified System.Log.Simple as Log -#endif - -#ifndef NODOCS -import Control.DeepSeq -import Data.Aeson (decode) -import qualified Data.ByteString.Lazy.Char8 as L (pack) -import Data.String (fromString) -import qualified Data.Text as T - -import qualified HDocs.Module as HDocs -import qualified HDocs.Haddock as HDocs - -import qualified GHC -#endif - -import qualified PackageConfig as P - -import Data.LookupTable -#ifndef NODOCS -import HsDev.Error -import HsDev.Scan.Browse (packageConfigs, readPackage) -import HsDev.Tools.Base -#endif -import HsDev.Symbols -import HsDev.Tools.Ghc.Worker -import System.Directory.Paths - --- | Get docs for modules -hdocsy :: PackageDbStack -> [ModuleLocation] -> [String] -> GhcM [Map String String] -#ifndef NODOCS -hdocsy pdbs mlocs opts = (map $ force . HDocs.formatDocs) <$> docs' mlocs where - docs' :: [ModuleLocation] -> GhcM [HDocs.ModuleDocMap] - docs' ms = do - haddockSession pdbs opts - liftGhc $ hsdevLiftWith (ToolError "hdocs") $ - liftM (map snd) $ HDocs.readSourcesGhc opts $ map (view (moduleFile . path)) ms -#else -hdocsy _ _ _ = notSupported >> return mempty -#endif - --- | Get docs for module -hdocs :: PackageDbStack -> ModuleLocation -> [String] -> GhcM (Map String String) -#ifndef NODOCS -hdocs pdbs mloc opts = (force . HDocs.formatDocs) <$> docs' mloc where - docs' :: ModuleLocation -> GhcM HDocs.ModuleDocMap - docs' mloc' = do - haddockSession pdbs opts - liftGhc $ case mloc' of - (FileModule fpath _) -> hsdevLiftWith (ToolError "hdocs") $ liftM snd $ HDocs.readSourceGhc opts (view path fpath) - (InstalledModule _ _ mname _) -> do - df <- GHC.getSessionDynFlags - liftIO $ hsdevLiftWith (ToolError "hdocs") $ HDocs.moduleDocsF df (T.unpack mname) - _ -> hsdevError $ ToolError "hdocs" $ "Can't get docs for: " ++ show mloc' -#else -hdocs _ _ _ = notSupported >> return mempty -#endif - --- | Get docs for package -hdocsPackage :: P.PackageConfig -> GhcM (Map Text (Map Text Text)) -#ifndef NODOCS -hdocsPackage p = do - ifaces <- - liftIO . hsdevLiftWith (ToolError "hdocs") . - liftM concat . mapM ((`mplus` return []) . HDocs.readInstalledInterfaces) $ - P.haddockInterfaces p - let - idocs = HDocs.installedInterfacesDocs ifaces - iexports = M.fromList $ map (HDocs.exportsDocs idocs) ifaces - docs = M.map HDocs.formatDocs iexports - tdocs = M.map (M.map fromString . M.mapKeys fromString) . M.mapKeys fromString $ docs - return $!! tdocs -#else -hdocsPackage _ = notSupported >> return mempty -#endif - --- | Get all docs -hdocsCabal :: PackageDbStack -> [String] -> GhcM [(ModulePackage, (Map Text (Map Text Text)))] -#ifndef NODOCS -hdocsCabal pdbs opts = do - haddockSession pdbs opts - pkgs <- packageConfigs - forM pkgs $ \pkg -> do - pkgDocs' <- hdocsPackage pkg - return (readPackage pkg, pkgDocs') -#else -hdocsCabal _ _ = notSupported >> return mempty -#endif - --- | Set docs for module -setSymbolDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Symbol -> m Symbol -setSymbolDocs tbl d sym = do - symDocs <- cacheInTableM tbl (symName, symMod) (return $ M.lookup symName d) - return $ set symbolDocs symDocs sym - where - symName = view (symbolId . symbolName) sym - symMod = view (symbolId . symbolModule . moduleName) sym - --- | Set docs for module symbols -setDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Module -> m Module -setDocs tbl d = mapMOf (moduleExports . each) setDoc >=> mapMOf (moduleScope . each . each) setDoc where - setDoc = setSymbolDocs tbl d - --- | Set docs for modules -setModuleDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text (Map Text Text) -> Module -> m Module -setModuleDocs tbl docs m = maybe return (setDocs tbl) (M.lookup (view (moduleId . moduleName) m) docs) $ m - -hdocsProcess :: String -> [String] -> IO (Maybe (Map String String)) -#ifndef NODOCS -hdocsProcess mname opts = liftM (decode . L.pack . last . lines) $ runTool_ "hdocs" opts' where - opts' = mname : concat [["-g", opt] | opt <- opts] -#else -hdocsProcess _ _ = return mempty -#endif - --- | Read docs for one module -readDocs :: Text -> [String] -> Path -> GhcM (Maybe (Map String String)) -#ifndef NODOCS -readDocs mname opts fpath = do - docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts [view path fpath] - return $ fmap HDocs.formatDocs $ lookup (T.unpack mname) docs -#else -readDocs _ _ _ = notSupported >> return mempty -#endif - --- | Read docs for one module -readModuleDocs :: [String] -> Module -> GhcM (Maybe (Map String String)) -#ifndef NODOCS -readModuleDocs opts m = case view (moduleId . moduleLocation) m of - FileModule fpath _ -> withCurrentDirectory (sourceRoot_ (m ^. moduleId) ^. path) $ do - readDocs (m ^. moduleId . moduleName) opts fpath - _ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m) -#else -readModuleDocs _ _ = notSupported >> return mempty -#endif - -readProjectTargetDocs :: [String] -> Project -> [Path] -> GhcM (Map String (Map String String)) -#ifndef NODOCS -readProjectTargetDocs opts proj fpaths = withCurrentDirectory (proj ^. projectPath . path) $ do - docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts (fpaths ^.. each . path) - return $ M.map HDocs.formatDocs $ M.fromList docs -#else -readProjectTargetDocs _ _ _ = notSupported >> return mempty -#endif - -#ifdef NODOCS -notSupported :: Log.MonadLog m => m () -notSupported = Log.sendLog Log.Warning "compiled without hdocs support" -#endif - -hdocsSupported :: Bool -#ifndef NODOCS -hdocsSupported = True -#else -hdocsSupported = False -#endif +{-# LANGUAGE CPP, OverloadedStrings #-} + +module HsDev.Tools.HDocs ( + hdocsy, hdocs, hdocsPackage, hdocsCabal, + setSymbolDocs, setDocs, setModuleDocs, + + hdocsProcess, + + readDocs, readModuleDocs, readProjectTargetDocs, + + hdocsSupported, + + module Control.Monad.Except + ) where + +import Control.Lens +import Control.Monad () +import Control.Monad.Except + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +#ifdef NODOCS +import qualified System.Log.Simple as Log +#endif + +#ifndef NODOCS +import Control.DeepSeq +import Data.Aeson (decode) +import qualified Data.ByteString.Lazy.Char8 as L (pack) +import Data.String (fromString) +import qualified Data.Text as T + +import qualified HDocs.Module as HDocs +import qualified HDocs.Haddock as HDocs + +import qualified GHC +#endif + +import qualified PackageConfig as P + +import Data.LookupTable +#ifndef NODOCS +import HsDev.Error +import HsDev.Scan.Browse (packageConfigs, readPackage) +import HsDev.Tools.Base +#endif +import HsDev.Symbols +import HsDev.Tools.Ghc.Worker +import System.Directory.Paths + +-- | Get docs for modules +hdocsy :: PackageDbStack -> [ModuleLocation] -> [String] -> GhcM [Map String String] +#ifndef NODOCS +hdocsy pdbs mlocs opts = (map $ force . HDocs.formatDocs) <$> docs' mlocs where + docs' :: [ModuleLocation] -> GhcM [HDocs.ModuleDocMap] + docs' ms = do + haddockSession pdbs opts + liftGhc $ hsdevLiftWith (ToolError "hdocs") $ + liftM (map snd) $ HDocs.readSourcesGhc opts $ map (view (moduleFile . path)) ms +#else +hdocsy _ _ _ = notSupported >> return mempty +#endif + +-- | Get docs for module +hdocs :: PackageDbStack -> ModuleLocation -> [String] -> GhcM (Map String String) +#ifndef NODOCS +hdocs pdbs mloc opts = (force . HDocs.formatDocs) <$> docs' mloc where + docs' :: ModuleLocation -> GhcM HDocs.ModuleDocMap + docs' mloc' = do + haddockSession pdbs opts + liftGhc $ case mloc' of + (FileModule fpath _) -> hsdevLiftWith (ToolError "hdocs") $ liftM snd $ HDocs.readSourceGhc opts (view path fpath) + (InstalledModule _ _ mname _) -> do + df <- GHC.getSessionDynFlags + liftIO $ hsdevLiftWith (ToolError "hdocs") $ HDocs.moduleDocsF df (T.unpack mname) + _ -> hsdevError $ ToolError "hdocs" $ "Can't get docs for: " ++ show mloc' +#else +hdocs _ _ _ = notSupported >> return mempty +#endif + +-- | Get docs for package +hdocsPackage :: P.PackageConfig -> GhcM (Map Text (Map Text Text)) +#ifndef NODOCS +hdocsPackage p = do + ifaces <- + liftIO . hsdevLiftWith (ToolError "hdocs") . + liftM concat . mapM ((`mplus` return []) . HDocs.readInstalledInterfaces) $ + P.haddockInterfaces p + let + idocs = HDocs.installedInterfacesDocs ifaces + iexports = M.fromList $ map (HDocs.exportsDocs idocs) ifaces + docs = M.map HDocs.formatDocs iexports + tdocs = M.map (M.map fromString . M.mapKeys fromString) . M.mapKeys fromString $ docs + return $!! tdocs +#else +hdocsPackage _ = notSupported >> return mempty +#endif + +-- | Get all docs +hdocsCabal :: PackageDbStack -> [String] -> GhcM [(ModulePackage, (Map Text (Map Text Text)))] +#ifndef NODOCS +hdocsCabal pdbs opts = do + haddockSession pdbs opts + pkgs <- packageConfigs + forM pkgs $ \pkg -> do + pkgDocs' <- hdocsPackage pkg + return (readPackage pkg, pkgDocs') +#else +hdocsCabal _ _ = notSupported >> return mempty +#endif + +-- | Set docs for module +setSymbolDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Symbol -> m Symbol +setSymbolDocs tbl d sym = do + symDocs <- cacheInTableM tbl (symName, symMod) (return $ M.lookup symName d) + return $ set symbolDocs symDocs sym + where + symName = view (symbolId . symbolName) sym + symMod = view (symbolId . symbolModule . moduleName) sym + +-- | Set docs for module symbols +setDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Module -> m Module +setDocs tbl d = mapMOf (moduleExports . each) setDoc >=> mapMOf (moduleScope . each . each) setDoc where + setDoc = setSymbolDocs tbl d + +-- | Set docs for modules +setModuleDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text (Map Text Text) -> Module -> m Module +setModuleDocs tbl docs m = maybe return (setDocs tbl) (M.lookup (view (moduleId . moduleName) m) docs) $ m + +hdocsProcess :: String -> [String] -> IO (Maybe (Map String String)) +#ifndef NODOCS +hdocsProcess mname opts = liftM (decode . L.pack . last . lines) $ runTool_ "hdocs" opts' where + opts' = mname : concat [["-g", opt] | opt <- opts] +#else +hdocsProcess _ _ = return mempty +#endif + +-- | Read docs for one module +readDocs :: Text -> [String] -> Path -> GhcM (Maybe (Map String String)) +#ifndef NODOCS +readDocs mname opts fpath = do + docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts [view path fpath] + return $ fmap HDocs.formatDocs $ lookup (T.unpack mname) docs +#else +readDocs _ _ _ = notSupported >> return mempty +#endif + +-- | Read docs for one module +readModuleDocs :: [String] -> Module -> GhcM (Maybe (Map String String)) +#ifndef NODOCS +readModuleDocs opts m = case view (moduleId . moduleLocation) m of + FileModule fpath _ -> withCurrentDirectory (sourceRoot_ (m ^. moduleId) ^. path) $ do + readDocs (m ^. moduleId . moduleName) opts fpath + _ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m) +#else +readModuleDocs _ _ = notSupported >> return mempty +#endif + +readProjectTargetDocs :: [String] -> Project -> [Path] -> GhcM (Map String (Map String String)) +#ifndef NODOCS +readProjectTargetDocs opts proj fpaths = withCurrentDirectory (proj ^. projectPath . path) $ do + docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts (fpaths ^.. each . path) + return $ M.map HDocs.formatDocs $ M.fromList docs +#else +readProjectTargetDocs _ _ _ = notSupported >> return mempty +#endif + +#ifdef NODOCS +notSupported :: Log.MonadLog m => m () +notSupported = Log.sendLog Log.Warning "compiled without hdocs support" +#endif + +hdocsSupported :: Bool +#ifndef NODOCS +hdocsSupported = True +#else +hdocsSupported = False +#endif diff --git a/src/HsDev/Tools/HLint.hs b/src/HsDev/Tools/HLint.hs --- a/src/HsDev/Tools/HLint.hs +++ b/src/HsDev/Tools/HLint.hs @@ -1,119 +1,119 @@ -{-# LANGUAGE CPP #-} - -module HsDev.Tools.HLint ( - hlint, - hlintSupported, - - module Control.Monad.Except - ) where - -import Control.Monad.Except -import Data.Text (Text) - -import HsDev.Tools.Base - -#ifndef NOHLINT -import Control.Arrow -import Control.Lens (over, view, _Just) -import Data.Char -import Data.List -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Data.Ord -import Data.String (fromString) -import Language.Haskell.Exts.SrcLoc -import Language.Haskell.HLint3 (argsSettings, parseModuleEx, applyHints, Idea(..), parseErrorMessage, ParseFlags(..), CppFlags(..)) -import qualified Language.Haskell.HLint3 as HL (Severity(..)) - -import System.Directory.Paths -import HsDev.Symbols.Location -import HsDev.Util (readFileUtf8) -#endif - -hlint :: [String] -> FilePath -> Maybe Text -> ExceptT String IO [Note OutputMessage] -#ifndef NOHLINT -hlint opts file msrc = do - file' <- liftIO $ canonicalize file - cts <- maybe (liftIO $ readFileUtf8 file') return msrc - (flags, classify, hint) <- liftIO $ argsSettings opts - p <- liftIO $ parseModuleEx (flags { cppFlags = CppSimple }) file' (Just $ T.unpack cts) - m <- either (throwError . parseErrorMessage) return p - return $ map (recalcTabs cts 8 . indentIdea cts . fromIdea) $ - filter (not . ignoreIdea) $ - applyHints classify hint [m] -#else -hlint _ _ _ = throwError "Compiled with no hlint support" -#endif - -#ifndef NOHLINT -ignoreIdea :: Idea -> Bool -ignoreIdea idea = ideaSeverity idea == HL.Ignore - -fromIdea :: Idea -> Note OutputMessage -fromIdea idea = Note { - _noteSource = FileModule (fromFilePath $ srcSpanFilename src) Nothing, - _noteRegion = Region (Position (srcSpanStartLine src) (srcSpanStartColumn src)) (Position (srcSpanEndLine src) (srcSpanEndColumn src)), - _noteLevel = Just $ case ideaSeverity idea of - HL.Warning -> Warning - HL.Error -> Error - _ -> Hint, - _note = OutputMessage { - _message = fromString $ ideaHint idea, - _messageSuggestion = fmap fromString $ ideaTo idea } } - where - src = ideaSpan idea - -indentIdea :: Text -> Note OutputMessage -> Note OutputMessage -indentIdea cts idea = case analyzeIndent cts of - Nothing -> idea - Just i -> over (note . messageSuggestion . _Just) (indent' i) idea - where - indent' i' = T.intercalate (fromString "\n") . indentTail . map (uncurry T.append . first ((`T.replicate` i') . (`div` 2) . T.length) . T.span isSpace) . T.split (== '\n') - indentTail [] = [] - indentTail (h : hs) = h : map (firstIndent `T.append`) hs - firstIndent = T.takeWhile isSpace firstLine - firstLine = regionStr (Position firstLineNum 1 `region` Position (succ firstLineNum) 1) cts - firstLineNum = view (noteRegion . regionFrom . positionLine) idea - --- | Indent in source -data Indent = Spaces Int | Tabs deriving (Eq, Ord) - -instance Show Indent where - show (Spaces n) = replicate n ' ' - show Tabs = "\t" - --- | Analyze source indentation to convert suggestion to same indentation --- Returns one indent -analyzeIndent :: Text -> Maybe Text -analyzeIndent = - fmap (fromString . show) . selectIndent . map fst . dropUnusual . - sortBy (comparing $ negate . snd) . - map (head &&& length) . - group . sort . - mapMaybe (guessIndent . T.takeWhile isSpace) . T.lines - where - selectIndent :: [Indent] -> Maybe Indent - selectIndent [] = Nothing - selectIndent (Tabs : _) = Just Tabs - selectIndent indents = Just $ Spaces $ foldr1 gcd $ mapMaybe spaces indents where - spaces :: Indent -> Maybe Int - spaces Tabs = Nothing - spaces (Spaces n) = Just n - dropUnusual :: [(Indent, Int)] -> [(Indent, Int)] - dropUnusual [] = [] - dropUnusual is@((_, freq):_) = takeWhile ((> freq `div` 5) . snd) is - --- | Guess indent of one line -guessIndent :: Text -> Maybe Indent -guessIndent s - | T.all (== ' ') s = Just $ Spaces $ T.length s - | T.all (== '\t') s = Just Tabs - | otherwise = Nothing -#endif - -hlintSupported :: Bool -#ifndef NOHLINT -hlintSupported = True -#else -hlintSupported = False -#endif +{-# LANGUAGE CPP #-} + +module HsDev.Tools.HLint ( + hlint, + hlintSupported, + + module Control.Monad.Except + ) where + +import Control.Monad.Except +import Data.Text (Text) + +import HsDev.Tools.Base + +#ifndef NOHLINT +import Control.Arrow +import Control.Lens (over, view, _Just) +import Data.Char +import Data.List +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Data.Ord +import Data.String (fromString) +import Language.Haskell.Exts.SrcLoc +import Language.Haskell.HLint3 (argsSettings, parseModuleEx, applyHints, Idea(..), parseErrorMessage, ParseFlags(..), CppFlags(..)) +import qualified Language.Haskell.HLint3 as HL (Severity(..)) + +import System.Directory.Paths +import HsDev.Symbols.Location +import HsDev.Util (readFileUtf8) +#endif + +hlint :: [String] -> FilePath -> Maybe Text -> ExceptT String IO [Note OutputMessage] +#ifndef NOHLINT +hlint opts file msrc = do + file' <- liftIO $ canonicalize file + cts <- maybe (liftIO $ readFileUtf8 file') return msrc + (flags, classify, hint) <- liftIO $ argsSettings opts + p <- liftIO $ parseModuleEx (flags { cppFlags = CppSimple }) file' (Just $ T.unpack cts) + m <- either (throwError . parseErrorMessage) return p + return $ map (recalcTabs cts 8 . indentIdea cts . fromIdea) $ + filter (not . ignoreIdea) $ + applyHints classify hint [m] +#else +hlint _ _ _ = throwError "Compiled with no hlint support" +#endif + +#ifndef NOHLINT +ignoreIdea :: Idea -> Bool +ignoreIdea idea = ideaSeverity idea == HL.Ignore + +fromIdea :: Idea -> Note OutputMessage +fromIdea idea = Note { + _noteSource = FileModule (fromFilePath $ srcSpanFilename src) Nothing, + _noteRegion = Region (Position (srcSpanStartLine src) (srcSpanStartColumn src)) (Position (srcSpanEndLine src) (srcSpanEndColumn src)), + _noteLevel = Just $ case ideaSeverity idea of + HL.Warning -> Warning + HL.Error -> Error + _ -> Hint, + _note = OutputMessage { + _message = fromString $ ideaHint idea, + _messageSuggestion = fmap fromString $ ideaTo idea } } + where + src = ideaSpan idea + +indentIdea :: Text -> Note OutputMessage -> Note OutputMessage +indentIdea cts idea = case analyzeIndent cts of + Nothing -> idea + Just i -> over (note . messageSuggestion . _Just) (indent' i) idea + where + indent' i' = T.intercalate (fromString "\n") . indentTail . map (uncurry T.append . first ((`T.replicate` i') . (`div` 2) . T.length) . T.span isSpace) . T.split (== '\n') + indentTail [] = [] + indentTail (h : hs) = h : map (firstIndent `T.append`) hs + firstIndent = T.takeWhile isSpace firstLine + firstLine = regionStr (Position firstLineNum 1 `region` Position (succ firstLineNum) 1) cts + firstLineNum = view (noteRegion . regionFrom . positionLine) idea + +-- | Indent in source +data Indent = Spaces Int | Tabs deriving (Eq, Ord) + +instance Show Indent where + show (Spaces n) = replicate n ' ' + show Tabs = "\t" + +-- | Analyze source indentation to convert suggestion to same indentation +-- Returns one indent +analyzeIndent :: Text -> Maybe Text +analyzeIndent = + fmap (fromString . show) . selectIndent . map fst . dropUnusual . + sortBy (comparing $ negate . snd) . + map (head &&& length) . + group . sort . + mapMaybe (guessIndent . T.takeWhile isSpace) . T.lines + where + selectIndent :: [Indent] -> Maybe Indent + selectIndent [] = Nothing + selectIndent (Tabs : _) = Just Tabs + selectIndent indents = Just $ Spaces $ foldr1 gcd $ mapMaybe spaces indents where + spaces :: Indent -> Maybe Int + spaces Tabs = Nothing + spaces (Spaces n) = Just n + dropUnusual :: [(Indent, Int)] -> [(Indent, Int)] + dropUnusual [] = [] + dropUnusual is@((_, freq):_) = takeWhile ((> freq `div` 5) . snd) is + +-- | Guess indent of one line +guessIndent :: Text -> Maybe Indent +guessIndent s + | T.all (== ' ') s = Just $ Spaces $ T.length s + | T.all (== '\t') s = Just Tabs + | otherwise = Nothing +#endif + +hlintSupported :: Bool +#ifndef NOHLINT +hlintSupported = True +#else +hlintSupported = False +#endif diff --git a/src/HsDev/Tools/Hayoo.hs b/src/HsDev/Tools/Hayoo.hs --- a/src/HsDev/Tools/Hayoo.hs +++ b/src/HsDev/Tools/Hayoo.hs @@ -1,143 +1,143 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HsDev.Tools.Hayoo ( - -- * Types - HayooResult(..), HayooSymbol(..), - hayooAsSymbol, - -- * Search help online - hayoo, - -- * Utils - untagDescription, - - -- * Reexportss - module Control.Monad.Except - ) where - -import Control.Arrow -import Control.Applicative -import Control.Lens (lens) -import Control.Monad.Except - -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Either -import Data.Maybe (listToMaybe, fromJust) -import Network.HTTP.Client -import Network.URI (escapeURIString, isUnescapedInURIComponent) -import Data.String (fromString) -import qualified Data.Text as T (unpack, unlines) - -import HsDev.Symbols -import HsDev.Tools.Base (replaceRx) -import HsDev.Util - --- | Hayoo response -data HayooResult = HayooResult { - resultMax :: Int, - resultOffset :: Int, - resultCount :: Int, - resultResult :: [HayooSymbol] } - deriving (Eq, Ord, Read, Show) - --- | Hayoo symbol -data HayooSymbol = HayooSymbol { - resultUri :: String, - tag :: String, - hayooPackage :: String, - hayooName :: String, - hayooSource :: String, - hayooDescription :: String, - hayooSignature :: String, - hayooModules :: [String], - hayooScore :: Double, - hayooType :: String } - deriving (Eq, Ord, Read, Show) - -newtype HayooValue = HayooValue { hayooValue :: Either Value HayooSymbol } - -instance FromJSON HayooResult where - parseJSON = withObject "hayoo response" $ \v -> HayooResult <$> - (v .:: "max") <*> - (v .:: "offset") <*> - (v .:: "count") <*> - ((rights . map hayooValue) <$> (v .:: "result")) - -instance Sourced HayooSymbol where - sourcedName = lens g' s' where - g' = fromString . hayooName - s' sym n = sym { hayooName = T.unpack n } - sourcedModule = lens g' s' where - g' h = ModuleId nm (OtherLocation $ fromString $ resultUri h) where - nm = maybe mempty fromString $ listToMaybe $ hayooModules h - s' h _ = h - sourcedDocs f h = (\d' -> h { hayooDescription = T.unpack d' }) <$> f (fromString $ hayooDescription h) - -instance Documented HayooSymbol where - brief f - | hayooType f == "function" = fromString $ hayooName f ++ " :: " ++ hayooSignature f - | otherwise = fromString $ hayooType f ++ " " ++ hayooName f - detailed f = T.unlines $ defaultDetailed f ++ map fromString online where - online = [ - "", "Hayoo online documentation", "", - "Package: " ++ hayooPackage f, - "Hackage URL: " ++ resultUri f] - -instance FromJSON HayooSymbol where - parseJSON = withObject "symbol" $ \v -> HayooSymbol <$> - (v .:: "resultUri") <*> - (v .:: "tag") <*> - (v .:: "resultPackage") <*> - (v .:: "resultName") <*> - (v .:: "resultSource") <*> - (v .:: "resultDescription") <*> - (v .:: "resultSignature") <*> - (v .:: "resultModules") <*> - (v .:: "resultScore") <*> - (v .:: "resultType") - -instance FromJSON HayooValue where - parseJSON v = HayooValue <$> ((Right <$> parseJSON v) <|> pure (Left v)) - --- | 'HayooFunction' as 'Symbol' -hayooAsSymbol :: HayooSymbol -> Maybe Symbol -hayooAsSymbol f - | hayooType f `elem` ["function", "type", "newtype", "data", "class"] = Just Symbol { - _symbolId = SymbolId { - _symbolName = fromString $ hayooName f, - _symbolModule = ModuleId { - _moduleName = fromString $ head $ hayooModules f, - _moduleLocation = OtherLocation (fromString $ resultUri f) } }, - _symbolDocs = Just (fromString $ addOnline $ untagDescription $ hayooDescription f), - _symbolPosition = Nothing, - _symbolInfo = info } - | otherwise = Nothing - where - -- Add other info - addOnline d = unlines [ - d, "", - "Hayoo online documentation", - "", - "Package: " ++ hayooPackage f, - "Hackage URL: " ++ resultUri f] - - info - | hayooType f == "function" = Function (Just $ fromString $ hayooSignature f) - | hayooType f `elem` ["type", "newtype", "data", "class"] = (fromJust $ lookup (hayooType f) ctors) [] [] - | otherwise = error "Impossible" - ctors = [("type", Type), ("newtype", NewType), ("data", Data), ("class", Class)] - --- | Search hayoo -hayoo :: Manager -> String -> Maybe Int -> ExceptT String IO HayooResult -hayoo m q page = do - resp <- liftIO $ do - req <- parseRequest $ maybe id addPage page $ "http://hayoo.fh-wedel.de/json/?query=" ++ escapeURIString isUnescapedInURIComponent q - resp <- httpLbs req m - return $ responseBody resp - ExceptT $ return $ eitherDecode resp - where - addPage :: Int -> String -> String - addPage p s = s ++ "&page=" ++ show p - --- | Remove tags in description -untagDescription :: String -> String -untagDescription = replaceRx "]*>" "" +{-# LANGUAGE OverloadedStrings #-} + +module HsDev.Tools.Hayoo ( + -- * Types + HayooResult(..), HayooSymbol(..), + hayooAsSymbol, + -- * Search help online + hayoo, + -- * Utils + untagDescription, + + -- * Reexportss + module Control.Monad.Except + ) where + +import Control.Arrow +import Control.Applicative +import Control.Lens (lens) +import Control.Monad.Except + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Either +import Data.Maybe (listToMaybe, fromJust) +import Network.HTTP.Client +import Network.URI (escapeURIString, isUnescapedInURIComponent) +import Data.String (fromString) +import qualified Data.Text as T (unpack, unlines) + +import HsDev.Symbols +import HsDev.Tools.Base (replaceRx) +import HsDev.Util + +-- | Hayoo response +data HayooResult = HayooResult { + resultMax :: Int, + resultOffset :: Int, + resultCount :: Int, + resultResult :: [HayooSymbol] } + deriving (Eq, Ord, Read, Show) + +-- | Hayoo symbol +data HayooSymbol = HayooSymbol { + resultUri :: String, + tag :: String, + hayooPackage :: String, + hayooName :: String, + hayooSource :: String, + hayooDescription :: String, + hayooSignature :: String, + hayooModules :: [String], + hayooScore :: Double, + hayooType :: String } + deriving (Eq, Ord, Read, Show) + +newtype HayooValue = HayooValue { hayooValue :: Either Value HayooSymbol } + +instance FromJSON HayooResult where + parseJSON = withObject "hayoo response" $ \v -> HayooResult <$> + (v .:: "max") <*> + (v .:: "offset") <*> + (v .:: "count") <*> + ((rights . map hayooValue) <$> (v .:: "result")) + +instance Sourced HayooSymbol where + sourcedName = lens g' s' where + g' = fromString . hayooName + s' sym n = sym { hayooName = T.unpack n } + sourcedModule = lens g' s' where + g' h = ModuleId nm (OtherLocation $ fromString $ resultUri h) where + nm = maybe mempty fromString $ listToMaybe $ hayooModules h + s' h _ = h + sourcedDocs f h = (\d' -> h { hayooDescription = T.unpack d' }) <$> f (fromString $ hayooDescription h) + +instance Documented HayooSymbol where + brief f + | hayooType f == "function" = fromString $ hayooName f ++ " :: " ++ hayooSignature f + | otherwise = fromString $ hayooType f ++ " " ++ hayooName f + detailed f = T.unlines $ defaultDetailed f ++ map fromString online where + online = [ + "", "Hayoo online documentation", "", + "Package: " ++ hayooPackage f, + "Hackage URL: " ++ resultUri f] + +instance FromJSON HayooSymbol where + parseJSON = withObject "symbol" $ \v -> HayooSymbol <$> + (v .:: "resultUri") <*> + (v .:: "tag") <*> + (v .:: "resultPackage") <*> + (v .:: "resultName") <*> + (v .:: "resultSource") <*> + (v .:: "resultDescription") <*> + (v .:: "resultSignature") <*> + (v .:: "resultModules") <*> + (v .:: "resultScore") <*> + (v .:: "resultType") + +instance FromJSON HayooValue where + parseJSON v = HayooValue <$> ((Right <$> parseJSON v) <|> pure (Left v)) + +-- | 'HayooFunction' as 'Symbol' +hayooAsSymbol :: HayooSymbol -> Maybe Symbol +hayooAsSymbol f + | hayooType f `elem` ["function", "type", "newtype", "data", "class"] = Just Symbol { + _symbolId = SymbolId { + _symbolName = fromString $ hayooName f, + _symbolModule = ModuleId { + _moduleName = fromString $ head $ hayooModules f, + _moduleLocation = OtherLocation (fromString $ resultUri f) } }, + _symbolDocs = Just (fromString $ addOnline $ untagDescription $ hayooDescription f), + _symbolPosition = Nothing, + _symbolInfo = info } + | otherwise = Nothing + where + -- Add other info + addOnline d = unlines [ + d, "", + "Hayoo online documentation", + "", + "Package: " ++ hayooPackage f, + "Hackage URL: " ++ resultUri f] + + info + | hayooType f == "function" = Function (Just $ fromString $ hayooSignature f) + | hayooType f `elem` ["type", "newtype", "data", "class"] = (fromJust $ lookup (hayooType f) ctors) [] [] + | otherwise = error "Impossible" + ctors = [("type", Type), ("newtype", NewType), ("data", Data), ("class", Class)] + +-- | Search hayoo +hayoo :: Manager -> String -> Maybe Int -> ExceptT String IO HayooResult +hayoo m q page = do + resp <- liftIO $ do + req <- parseRequest $ maybe id addPage page $ "http://hayoo.fh-wedel.de/json/?query=" ++ escapeURIString isUnescapedInURIComponent q + resp <- httpLbs req m + return $ responseBody resp + ExceptT $ return $ eitherDecode resp + where + addPage :: Int -> String -> String + addPage p s = s ++ "&page=" ++ show p + +-- | Remove tags in description +untagDescription :: String -> String +untagDescription = replaceRx "]*>" "" diff --git a/src/HsDev/Tools/Refact.hs b/src/HsDev/Tools/Refact.hs --- a/src/HsDev/Tools/Refact.hs +++ b/src/HsDev/Tools/Refact.hs @@ -1,53 +1,53 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} - -module HsDev.Tools.Refact ( - Refact(..), refactMessage, refactAction, - refact, update, - - replace, cut, paste, - - fromRegion, fromPosition - ) where - -import Control.Lens hiding ((.=)) -import Data.Aeson -import Data.Text (Text) -import Data.Text.Region hiding (Region(..), update) -import qualified Data.Text.Region as R - -import HsDev.Symbols.Location -import HsDev.Util - -data Refact = Refact { - _refactMessage :: Text, - _refactAction :: Replace Text } - deriving (Eq, Show) - -instance ToJSON Refact where - toJSON (Refact msg cor) = object [ - "message" .= msg, - "action" .= cor] - -instance FromJSON Refact where - parseJSON = withObject "correction" $ \v -> Refact <$> - v .:: "message" <*> - v .:: "action" - -makeLenses ''Refact - -instance Regioned Refact where - regions = refactAction . regions - -refact :: [Refact] -> Text -> Text -refact rs = apply act where - act = Edit (rs ^.. each . refactAction) - -update :: Regioned a => [Refact] -> [a] -> [a] -update rs = map (R.update act) where - act = Edit (rs ^.. each . refactAction) - -fromRegion :: Region -> R.Region -fromRegion (Region f t) = fromPosition f `till` fromPosition t - -fromPosition :: Position -> Point -fromPosition (Position l c) = pt (pred l) (pred c) +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} + +module HsDev.Tools.Refact ( + Refact(..), refactMessage, refactAction, + refact, update, + + replace, cut, paste, + + fromRegion, fromPosition + ) where + +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Text (Text) +import Data.Text.Region hiding (Region(..), update) +import qualified Data.Text.Region as R + +import HsDev.Symbols.Location +import HsDev.Util + +data Refact = Refact { + _refactMessage :: Text, + _refactAction :: Replace Text } + deriving (Eq, Show) + +instance ToJSON Refact where + toJSON (Refact msg cor) = object [ + "message" .= msg, + "action" .= cor] + +instance FromJSON Refact where + parseJSON = withObject "correction" $ \v -> Refact <$> + v .:: "message" <*> + v .:: "action" + +makeLenses ''Refact + +instance Regioned Refact where + regions = refactAction . regions + +refact :: [Refact] -> Text -> Text +refact rs = apply act where + act = Edit (rs ^.. each . refactAction) + +update :: Regioned a => [Refact] -> [a] -> [a] +update rs = map (R.update act) where + act = Edit (rs ^.. each . refactAction) + +fromRegion :: Region -> R.Region +fromRegion (Region f t) = fromPosition f `till` fromPosition t + +fromPosition :: Position -> Point +fromPosition (Position l c) = pt (pred l) (pred c) diff --git a/src/HsDev/Tools/Tabs.hs b/src/HsDev/Tools/Tabs.hs --- a/src/HsDev/Tools/Tabs.hs +++ b/src/HsDev/Tools/Tabs.hs @@ -1,30 +1,30 @@ -module HsDev.Tools.Tabs ( - recalcNotesTabs - ) where - -import Control.Lens -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) - -import System.Directory.Paths -import HsDev.Symbols.Location -import HsDev.Tools.Types -import HsDev.Util - --- | Some tools counts tab as 8 symbols and return such file positions; convert them (consider tab = one symbol) -recalcNotesTabs :: Map Path Text -> [Note a] -> IO [Note a] -recalcNotesTabs srcs notes = do - ctsMap <- fmap M.fromList $ mapM loadFileContents files - let - recalc' n = fromMaybe n $ do - fname <- preview (noteSource . moduleFile) n - cts' <- M.lookup fname ctsMap - return $ recalcTabs cts' 8 n - return $ map recalc' notes - where - files = ordNub $ notes ^.. each . noteSource . moduleFile - loadFileContents f = do - cts <- maybe (readFileUtf8 $ view path f) return $ M.lookup f srcs - return (f, cts) +module HsDev.Tools.Tabs ( + recalcNotesTabs + ) where + +import Control.Lens +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) + +import System.Directory.Paths +import HsDev.Symbols.Location +import HsDev.Tools.Types +import HsDev.Util + +-- | Some tools counts tab as 8 symbols and return such file positions; convert them (consider tab = one symbol) +recalcNotesTabs :: Map Path Text -> [Note a] -> IO [Note a] +recalcNotesTabs srcs notes = do + ctsMap <- fmap M.fromList $ mapM loadFileContents files + let + recalc' n = fromMaybe n $ do + fname <- preview (noteSource . moduleFile) n + cts' <- M.lookup fname ctsMap + return $ recalcTabs cts' 8 n + return $ map recalc' notes + where + files = ordNub $ notes ^.. each . noteSource . moduleFile + loadFileContents f = do + cts <- maybe (readFileUtf8 $ view path f) return $ M.lookup f srcs + return (f, cts) diff --git a/src/HsDev/Tools/Types.hs b/src/HsDev/Tools/Types.hs --- a/src/HsDev/Tools/Types.hs +++ b/src/HsDev/Tools/Types.hs @@ -1,100 +1,100 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} - -module HsDev.Tools.Types ( - Severity(..), - Note(..), noteSource, noteRegion, noteLevel, note, - OutputMessage(..), message, messageSuggestion, outputMessage - ) where - -import Control.DeepSeq (NFData(..)) -import Control.Lens (makeLenses) -import Control.Monad -import Data.Aeson hiding (Error) -import Data.Text (Text) - -import System.Directory.Paths -import HsDev.Symbols.Location -import HsDev.Util ((.::), (.::?), noNulls) - --- | Note severity -data Severity = Error | Warning | Hint deriving (Enum, Bounded, Eq, Ord, Read, Show) - -instance NFData Severity where - rnf Error = () - rnf Warning = () - rnf Hint = () - -instance ToJSON Severity where - toJSON Error = toJSON ("error" :: String) - toJSON Warning = toJSON ("warning" :: String) - toJSON Hint = toJSON ("hint" :: String) - -instance FromJSON Severity where - parseJSON v = do - s <- parseJSON v - msum [ - guard (s == ("error" :: String)) >> return Error, - guard (s == ("warning" :: String)) >> return Warning, - guard (s == ("hint" :: String)) >> return Hint, - fail $ "Unknown severity: " ++ s] - --- | Note over some region -data Note a = Note { - _noteSource :: ModuleLocation, - _noteRegion :: Region, - _noteLevel :: Maybe Severity, - _note :: a } - deriving (Eq, Show) - -makeLenses ''Note - -instance Functor Note where - fmap f (Note s r l n) = Note s r l (f n) - -instance NFData a => NFData (Note a) where - rnf (Note s r l n) = rnf s `seq` rnf r `seq` rnf l `seq` rnf n - -instance ToJSON a => ToJSON (Note a) where - toJSON (Note s r l n) = object $ noNulls [ - "source" .= s, - "region" .= r, - "level" .= l, - "note" .= n] - -instance FromJSON a => FromJSON (Note a) where - parseJSON = withObject "note" $ \v -> Note <$> - v .:: "source" <*> - v .:: "region" <*> - v .::? "level" <*> - v .:: "note" - -instance RecalcTabs (Note a) where - recalcTabs cts n' (Note s r l n) = Note s (recalcTabs cts n' r) l n - calcTabs cts n' (Note s r l n) = Note s (calcTabs cts n' r) l n - -instance Paths (Note a) where - paths f (Note s r l n) = Note <$> paths f s <*> pure r <*> pure l <*> pure n - --- | Output message from some tool (ghc, ghc-mod, hlint) with optional suggestion -data OutputMessage = OutputMessage { - _message :: Text, - _messageSuggestion :: Maybe Text } - deriving (Eq, Ord, Read, Show) - -instance NFData OutputMessage where - rnf (OutputMessage m s) = rnf m `seq` rnf s - -instance ToJSON OutputMessage where - toJSON (OutputMessage m s) = object [ - "message" .= m, - "suggestion" .= s] - -instance FromJSON OutputMessage where - parseJSON = withObject "output-message" $ \v -> OutputMessage <$> - v .:: "message" <*> - v .:: "suggestion" - -outputMessage :: Text -> OutputMessage -outputMessage msg = OutputMessage msg Nothing - -makeLenses ''OutputMessage +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} + +module HsDev.Tools.Types ( + Severity(..), + Note(..), noteSource, noteRegion, noteLevel, note, + OutputMessage(..), message, messageSuggestion, outputMessage + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Lens (makeLenses) +import Control.Monad +import Data.Aeson hiding (Error) +import Data.Text (Text) + +import System.Directory.Paths +import HsDev.Symbols.Location +import HsDev.Util ((.::), (.::?), noNulls) + +-- | Note severity +data Severity = Error | Warning | Hint deriving (Enum, Bounded, Eq, Ord, Read, Show) + +instance NFData Severity where + rnf Error = () + rnf Warning = () + rnf Hint = () + +instance ToJSON Severity where + toJSON Error = toJSON ("error" :: String) + toJSON Warning = toJSON ("warning" :: String) + toJSON Hint = toJSON ("hint" :: String) + +instance FromJSON Severity where + parseJSON v = do + s <- parseJSON v + msum [ + guard (s == ("error" :: String)) >> return Error, + guard (s == ("warning" :: String)) >> return Warning, + guard (s == ("hint" :: String)) >> return Hint, + fail $ "Unknown severity: " ++ s] + +-- | Note over some region +data Note a = Note { + _noteSource :: ModuleLocation, + _noteRegion :: Region, + _noteLevel :: Maybe Severity, + _note :: a } + deriving (Eq, Show) + +makeLenses ''Note + +instance Functor Note where + fmap f (Note s r l n) = Note s r l (f n) + +instance NFData a => NFData (Note a) where + rnf (Note s r l n) = rnf s `seq` rnf r `seq` rnf l `seq` rnf n + +instance ToJSON a => ToJSON (Note a) where + toJSON (Note s r l n) = object $ noNulls [ + "source" .= s, + "region" .= r, + "level" .= l, + "note" .= n] + +instance FromJSON a => FromJSON (Note a) where + parseJSON = withObject "note" $ \v -> Note <$> + v .:: "source" <*> + v .:: "region" <*> + v .::? "level" <*> + v .:: "note" + +instance RecalcTabs (Note a) where + recalcTabs cts n' (Note s r l n) = Note s (recalcTabs cts n' r) l n + calcTabs cts n' (Note s r l n) = Note s (calcTabs cts n' r) l n + +instance Paths (Note a) where + paths f (Note s r l n) = Note <$> paths f s <*> pure r <*> pure l <*> pure n + +-- | Output message from some tool (ghc, ghc-mod, hlint) with optional suggestion +data OutputMessage = OutputMessage { + _message :: Text, + _messageSuggestion :: Maybe Text } + deriving (Eq, Ord, Read, Show) + +instance NFData OutputMessage where + rnf (OutputMessage m s) = rnf m `seq` rnf s + +instance ToJSON OutputMessage where + toJSON (OutputMessage m s) = object [ + "message" .= m, + "suggestion" .= s] + +instance FromJSON OutputMessage where + parseJSON = withObject "output-message" $ \v -> OutputMessage <$> + v .:: "message" <*> + v .:: "suggestion" + +outputMessage :: Text -> OutputMessage +outputMessage msg = OutputMessage msg Nothing + +makeLenses ''OutputMessage diff --git a/src/HsDev/Types.hs b/src/HsDev/Types.hs --- a/src/HsDev/Types.hs +++ b/src/HsDev/Types.hs @@ -1,137 +1,137 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HsDev.Types ( - HsDevError(..) - ) where - -import Control.Exception -import Control.DeepSeq (NFData(..)) -import Data.Aeson -import Data.Aeson.Types (Pair, Parser) -import Data.Semigroup -import Data.Typeable -import Data.Text (Text) -import Text.Format - -import HsDev.Symbols.Location -import System.Directory.Paths - --- | hsdev exception type -data HsDevError = - HsDevFailure | - ModuleNotSource ModuleLocation | - BrowseNoModuleInfo String | - FileNotFound Path | - ToolNotFound String | - ProjectNotFound Text | - PackageNotFound Text | - ToolError String String | - NotInspected ModuleLocation | - InspectError String | - InspectCabalError FilePath String | - IOFailed String | - GhcError String | - RequestError String String | - ResponseError String String | - SQLiteError String | - OtherError String | - UnhandledError String - deriving (Typeable) - -instance NFData HsDevError where - rnf HsDevFailure = () - rnf (ModuleNotSource mloc) = rnf mloc - rnf (BrowseNoModuleInfo m) = rnf m - rnf (FileNotFound f) = rnf f - rnf (ToolNotFound t) = rnf t - rnf (ProjectNotFound p) = rnf p - rnf (PackageNotFound p) = rnf p - rnf (ToolError t e) = rnf t `seq` rnf e - rnf (NotInspected mloc) = rnf mloc - rnf (InspectError e) = rnf e - rnf (InspectCabalError c e) = rnf c `seq` rnf e - rnf (IOFailed e) = rnf e - rnf (GhcError e) = rnf e - rnf (RequestError e r) = rnf e `seq` rnf r - rnf (ResponseError e r) = rnf e `seq` rnf r - rnf (SQLiteError e) = rnf e - rnf (OtherError e) = rnf e - rnf (UnhandledError e) = rnf e - -instance Show HsDevError where - show HsDevFailure = format "failure" - show (ModuleNotSource mloc) = format "module is not source: {}" ~~ show mloc - show (BrowseNoModuleInfo m) = format "can't find module info for {}" ~~ m - show (FileNotFound f) = format "file '{}' not found" ~~ f - show (ToolNotFound t) = format "tool '{}' not found" ~~ t - show (ProjectNotFound p) = format "project '{}' not found" ~~ p - show (PackageNotFound p) = format "package '{}' not found" ~~ p - show (ToolError t e) = format "tool '{}' failed: {}" ~~ t ~~ e - show (NotInspected mloc) = "module not inspected: {}" ~~ show mloc - show (InspectError e) = format "failed to inspect: {}" ~~ e - show (InspectCabalError c e) = format "failed to inspect cabal {}: {}" ~~ c ~~ e - show (IOFailed e) = format "io exception: {}" ~~ e - show (GhcError e) = format "ghc exception: {}" ~~ e - show (RequestError e r) = format "request error: {}, request: {}" ~~ e ~~ r - show (ResponseError e r) = format "response error: {}, response: {}" ~~ e ~~ r - show (SQLiteError e) = format "sqlite error: {}" ~~ e - show (OtherError e) = e - show (UnhandledError e) = e - -instance Semigroup HsDevError where - _ <> r = r - -instance Monoid HsDevError where - mempty = HsDevFailure - mappend l r = l <> r - -instance Formattable HsDevError where - -jsonErr :: String -> [Pair] -> Value -jsonErr e = object . (("error" .= e) :) - -instance ToJSON HsDevError where - toJSON HsDevFailure = jsonErr "failure" [] - toJSON (ModuleNotSource mloc) = jsonErr "module is not source" ["module" .= mloc] - toJSON (BrowseNoModuleInfo m) = jsonErr "no module info" ["module" .= m] - toJSON (FileNotFound f) = jsonErr "file not found" ["file" .= f] - toJSON (ToolNotFound t) = jsonErr "tool not found" ["tool" .= t] - toJSON (ProjectNotFound p) = jsonErr "project not found" ["project" .= p] - toJSON (PackageNotFound p) = jsonErr "package not found" ["package" .= p] - toJSON (ToolError t e) = jsonErr "tool error" ["tool" .= t, "msg" .= e] - toJSON (NotInspected mloc) = jsonErr "module not inspected" ["module" .= mloc] - toJSON (InspectError e) = jsonErr "inspect error" ["msg" .= e] - toJSON (InspectCabalError c e) = jsonErr "inspect cabal error" ["cabal" .= c, "msg" .= e] - toJSON (IOFailed e) = jsonErr "io error" ["msg" .= e] - toJSON (GhcError e) = jsonErr "ghc error" ["msg" .= e] - toJSON (RequestError e r) = jsonErr "request error" ["msg" .= e, "request" .= r] - toJSON (ResponseError e r) = jsonErr "response error" ["msg" .= e, "response" .= r] - toJSON (SQLiteError e) = jsonErr "sqlite error" ["msg" .= e] - toJSON (OtherError e) = jsonErr "other error" ["msg" .= e] - toJSON (UnhandledError e) = jsonErr "unhandled error" ["msg" .= e] - -instance FromJSON HsDevError where - parseJSON = withObject "hsdev-error" $ \v -> do - err <- v .: "error" :: Parser String - case err of - "failure" -> pure HsDevFailure - "module is not source" -> ModuleNotSource <$> v .: "module" - "no module info" -> BrowseNoModuleInfo <$> v .: "module" - "file not found" -> FileNotFound <$> v .: "file" - "tool not found" -> ToolNotFound <$> v .: "tool" - "project not found" -> ProjectNotFound <$> v .: "project" - "package not found" -> PackageNotFound <$> v .: "package" - "tool error" -> ToolError <$> v .: "tool" <*> v .: "msg" - "module not inspected" -> NotInspected <$> v .: "module" - "inspect error" -> InspectError <$> v .: "msg" - "inspect cabal error" -> InspectCabalError <$> v .: "cabal" <*> v .: "msg" - "io error" -> IOFailed <$> v .: "msg" - "ghc error" -> GhcError <$> v .: "msg" - "request error" -> RequestError <$> v .: "msg" <*> v .: "request" - "response error" -> ResponseError <$> v .: "msg" <*> v .: "response" - "sqlite error" -> SQLiteError <$> v .: "msg" - "other error" -> OtherError <$> v .: "msg" - "unhandled error" -> UnhandledError <$> v .: "msg" - _ -> fail "invalid error" - -instance Exception HsDevError +{-# LANGUAGE OverloadedStrings #-} + +module HsDev.Types ( + HsDevError(..) + ) where + +import Control.Exception +import Control.DeepSeq (NFData(..)) +import Data.Aeson +import Data.Aeson.Types (Pair, Parser) +import Data.Semigroup +import Data.Typeable +import Data.Text (Text) +import Text.Format + +import HsDev.Symbols.Location +import System.Directory.Paths + +-- | hsdev exception type +data HsDevError = + HsDevFailure | + ModuleNotSource ModuleLocation | + BrowseNoModuleInfo String | + FileNotFound Path | + ToolNotFound String | + ProjectNotFound Text | + PackageNotFound Text | + ToolError String String | + NotInspected ModuleLocation | + InspectError String | + InspectCabalError FilePath String | + IOFailed String | + GhcError String | + RequestError String String | + ResponseError String String | + SQLiteError String | + OtherError String | + UnhandledError String + deriving (Typeable) + +instance NFData HsDevError where + rnf HsDevFailure = () + rnf (ModuleNotSource mloc) = rnf mloc + rnf (BrowseNoModuleInfo m) = rnf m + rnf (FileNotFound f) = rnf f + rnf (ToolNotFound t) = rnf t + rnf (ProjectNotFound p) = rnf p + rnf (PackageNotFound p) = rnf p + rnf (ToolError t e) = rnf t `seq` rnf e + rnf (NotInspected mloc) = rnf mloc + rnf (InspectError e) = rnf e + rnf (InspectCabalError c e) = rnf c `seq` rnf e + rnf (IOFailed e) = rnf e + rnf (GhcError e) = rnf e + rnf (RequestError e r) = rnf e `seq` rnf r + rnf (ResponseError e r) = rnf e `seq` rnf r + rnf (SQLiteError e) = rnf e + rnf (OtherError e) = rnf e + rnf (UnhandledError e) = rnf e + +instance Show HsDevError where + show HsDevFailure = format "failure" + show (ModuleNotSource mloc) = format "module is not source: {}" ~~ show mloc + show (BrowseNoModuleInfo m) = format "can't find module info for {}" ~~ m + show (FileNotFound f) = format "file '{}' not found" ~~ f + show (ToolNotFound t) = format "tool '{}' not found" ~~ t + show (ProjectNotFound p) = format "project '{}' not found" ~~ p + show (PackageNotFound p) = format "package '{}' not found" ~~ p + show (ToolError t e) = format "tool '{}' failed: {}" ~~ t ~~ e + show (NotInspected mloc) = "module not inspected: {}" ~~ show mloc + show (InspectError e) = format "failed to inspect: {}" ~~ e + show (InspectCabalError c e) = format "failed to inspect cabal {}: {}" ~~ c ~~ e + show (IOFailed e) = format "io exception: {}" ~~ e + show (GhcError e) = format "ghc exception: {}" ~~ e + show (RequestError e r) = format "request error: {}, request: {}" ~~ e ~~ r + show (ResponseError e r) = format "response error: {}, response: {}" ~~ e ~~ r + show (SQLiteError e) = format "sqlite error: {}" ~~ e + show (OtherError e) = e + show (UnhandledError e) = e + +instance Semigroup HsDevError where + _ <> r = r + +instance Monoid HsDevError where + mempty = HsDevFailure + mappend l r = l <> r + +instance Formattable HsDevError where + +jsonErr :: String -> [Pair] -> Value +jsonErr e = object . (("error" .= e) :) + +instance ToJSON HsDevError where + toJSON HsDevFailure = jsonErr "failure" [] + toJSON (ModuleNotSource mloc) = jsonErr "module is not source" ["module" .= mloc] + toJSON (BrowseNoModuleInfo m) = jsonErr "no module info" ["module" .= m] + toJSON (FileNotFound f) = jsonErr "file not found" ["file" .= f] + toJSON (ToolNotFound t) = jsonErr "tool not found" ["tool" .= t] + toJSON (ProjectNotFound p) = jsonErr "project not found" ["project" .= p] + toJSON (PackageNotFound p) = jsonErr "package not found" ["package" .= p] + toJSON (ToolError t e) = jsonErr "tool error" ["tool" .= t, "msg" .= e] + toJSON (NotInspected mloc) = jsonErr "module not inspected" ["module" .= mloc] + toJSON (InspectError e) = jsonErr "inspect error" ["msg" .= e] + toJSON (InspectCabalError c e) = jsonErr "inspect cabal error" ["cabal" .= c, "msg" .= e] + toJSON (IOFailed e) = jsonErr "io error" ["msg" .= e] + toJSON (GhcError e) = jsonErr "ghc error" ["msg" .= e] + toJSON (RequestError e r) = jsonErr "request error" ["msg" .= e, "request" .= r] + toJSON (ResponseError e r) = jsonErr "response error" ["msg" .= e, "response" .= r] + toJSON (SQLiteError e) = jsonErr "sqlite error" ["msg" .= e] + toJSON (OtherError e) = jsonErr "other error" ["msg" .= e] + toJSON (UnhandledError e) = jsonErr "unhandled error" ["msg" .= e] + +instance FromJSON HsDevError where + parseJSON = withObject "hsdev-error" $ \v -> do + err <- v .: "error" :: Parser String + case err of + "failure" -> pure HsDevFailure + "module is not source" -> ModuleNotSource <$> v .: "module" + "no module info" -> BrowseNoModuleInfo <$> v .: "module" + "file not found" -> FileNotFound <$> v .: "file" + "tool not found" -> ToolNotFound <$> v .: "tool" + "project not found" -> ProjectNotFound <$> v .: "project" + "package not found" -> PackageNotFound <$> v .: "package" + "tool error" -> ToolError <$> v .: "tool" <*> v .: "msg" + "module not inspected" -> NotInspected <$> v .: "module" + "inspect error" -> InspectError <$> v .: "msg" + "inspect cabal error" -> InspectCabalError <$> v .: "cabal" <*> v .: "msg" + "io error" -> IOFailed <$> v .: "msg" + "ghc error" -> GhcError <$> v .: "msg" + "request error" -> RequestError <$> v .: "msg" <*> v .: "request" + "response error" -> ResponseError <$> v .: "msg" <*> v .: "response" + "sqlite error" -> SQLiteError <$> v .: "msg" + "other error" -> OtherError <$> v .: "msg" + "unhandled error" -> UnhandledError <$> v .: "msg" + _ -> fail "invalid error" + +instance Exception HsDevError diff --git a/src/HsDev/Util.hs b/src/HsDev/Util.hs --- a/src/HsDev/Util.hs +++ b/src/HsDev/Util.hs @@ -1,317 +1,317 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings, TemplateHaskell, CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module HsDev.Util ( - withCurrentDirectory, - directoryContents, - traverseDirectory, searchPath, - haskellSource, - cabalFile, - -- * String utils - tab, - trim, split, - -- * Other utils - ordNub, uniqueBy, mapBy, - -- * Helper - (.::), (.::?), (.::?!), objectUnion, noNulls, fromJSON', - -- * Exceptions - liftException, liftE, tries, triesMap, liftIOErrors, - logAll, - -- * UTF-8 - fromUtf8, toUtf8, readFileUtf8, writeFileUtf8, - -- * IO - hGetLineBS, logIO, ignoreIO, logAsync, - -- * Command line - FromCmd(..), - cmdJson, guardCmd, - withHelp, cmd, parseArgs, - -- * Version stuff - version, - -- * Parse - parseDT, - - -- * Log utils - timer, - - -- * Reexportss - module Control.Monad.Except, - MonadIO(..) - ) where - -import Control.Arrow (second, left, (&&&)) -import Control.Exception -import Control.DeepSeq -import Control.Monad -import Control.Monad.Except -import qualified Control.Monad.Catch as C -import Data.Aeson hiding (Result(..), Error) -import qualified Data.Aeson.Types as A -import Data.Char (isSpace) -import Data.List (unfoldr) -import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import qualified Data.Set as Set -import qualified Data.HashMap.Strict as HM (HashMap, toList, union) -import qualified Data.ByteString.Char8 as B -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Text (Text) -import qualified Data.Text.IO as ST -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Encoding as T -import Data.Time.Clock.POSIX -import Distribution.Text (simpleParse) -import qualified Distribution.Text (Text) -import Options.Applicative -import qualified System.Directory as Dir -import System.FilePath -import System.Log.Simple -import System.IO -import Text.Format -import Text.Read (readMaybe) - -#if !MIN_VERSION_directory(1,2,6) -#if mingw32_HOST_OS -import qualified System.Win32 as Win32 -import Data.Bits ((.&.)) -#else -import qualified System.Posix as Posix -#endif -#endif - -import HsDev.Version - --- | Run action with current directory set -withCurrentDirectory :: (MonadIO m, C.MonadMask m) => FilePath -> m a -> m a -withCurrentDirectory cur act = C.bracket (liftIO Dir.getCurrentDirectory) (liftIO . Dir.setCurrentDirectory) $ - const (liftIO (Dir.setCurrentDirectory cur) >> act) - --- | Is directory symbolic link -dirIsSymLink :: FilePath -> IO Bool -#if MIN_VERSION_directory(1,3,0) -dirIsSymLink = Dir.pathIsSymbolicLink -#elif MIN_VERSION_directory(1,2,6) -dirIsSymLink = Dir.isSymbolicLink -#else -dirIsSymLink path = do -#if mingw32_HOST_OS - isReparsePoint <$> Win32.getFileAttributes path - where - fILE_ATTRIBUTE_REPARSE_POINT = 0x400 - isReparsePoint attr = attr .&. fILE_ATTRIBUTE_REPARSE_POINT /= 0 -#else - Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path -#endif -#endif - --- | Get directory contents safely: no fail, ignoring symbolic links, also prepends paths with dir name -directoryContents :: FilePath -> IO [FilePath] -directoryContents p = handle ignore $ do - b <- Dir.doesDirectoryExist p - isLink <- dirIsSymLink p - if b && (not isLink) - then liftM (map (p ) . filter (`notElem` [".", ".."])) (Dir.getDirectoryContents p) - else return [] - where - ignore :: SomeException -> IO [FilePath] - ignore _ = return [] - --- | Collect all file names in directory recursively -traverseDirectory :: FilePath -> IO [FilePath] -traverseDirectory p = handle onError $ do - cts <- directoryContents p - liftM concat $ forM cts $ \c -> do - isDir <- Dir.doesDirectoryExist c - if isDir - then (c :) <$> traverseDirectory c - else return [c] - where - onError :: IOException -> IO [FilePath] - onError _ = return [] - --- | Search something up -searchPath :: (MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m a) -> m a -searchPath p f = do - p' <- liftIO $ Dir.canonicalizePath p - isDir <- liftIO $ Dir.doesDirectoryExist p' - search' (if isDir then p' else takeDirectory p') - where - search' dir - | isDrive dir = f dir - | otherwise = f dir `mplus` search' (takeDirectory dir) - --- | Is haskell source? -haskellSource :: FilePath -> Bool -haskellSource f = takeExtension f `elem` [".hs", ".lhs"] - --- | Is cabal file? -cabalFile :: FilePath -> Bool -cabalFile f = takeExtension f == ".cabal" - --- | Add N tabs to line -tab :: Int -> String -> String -tab n s = replicate n '\t' ++ s - --- | Trim string -trim :: String -> String -trim = p . p where - p = reverse . dropWhile isSpace - --- | Split list -split :: (a -> Bool) -> [a] -> [[a]] -split p = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break p) - --- | nub is quadratic, https://github.com/nh2/haskell-ordnub/#ordnub -ordNub :: Ord a => [a] -> [a] -ordNub = go Set.empty where - go _ [] = [] - go s (x:xs) - | x `Set.member` s = go s xs - | otherwise = x : go (Set.insert x s) xs - -uniqueBy :: Ord b => (a -> b) -> [a] -> [a] -uniqueBy f = M.elems . mapBy f - -mapBy :: Ord b => (a -> b) -> [a] -> M.Map b a -mapBy f = M.fromList . map (f &&& id) - --- | Workaround, sometimes we get HM.lookup "foo" v == Nothing, but lookup "foo" (HM.toList v) == Just smth -(.::) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser a -v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v - --- | Returns @Nothing@ when key doesn't exist or value is @Null@ -(.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser (Maybe a) -v .::? name = fmap join $ traverse parseJSON $ lookup name $ HM.toList v - --- | Same as @.::?@ for list, returns empty list for non-existant key or @Null@ value -(.::?!) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser [a] -v .::?! name = fromMaybe [] <$> (v .::? name) - --- | Union two JSON objects -objectUnion :: Value -> Value -> Value -objectUnion (Object l) (Object r) = Object $ HM.union l r -objectUnion (Object l) _ = Object l -objectUnion _ (Object r) = Object r -objectUnion _ _ = Null - --- | No Nulls in JSON object -noNulls :: [A.Pair] -> [A.Pair] -noNulls = filter (not . isNull . snd) where - isNull Null = True - isNull v = v == A.emptyArray || v == A.emptyObject || v == A.String "" - --- | Try convert json to value -fromJSON' :: FromJSON a => Value -> Maybe a -fromJSON' v = case fromJSON v of - A.Success r -> Just r - _ -> Nothing - --- | Lift IO exception to ExceptT -liftException :: C.MonadCatch m => m a -> ExceptT String m a -liftException = ExceptT . liftM (left $ \(SomeException e) -> displayException e) . C.try - --- | Same as @liftException@ -liftE :: C.MonadCatch m => m a -> ExceptT String m a -liftE = liftException - --- | Run actions ignoring errors -tries :: MonadPlus m => [m a] -> m [a] -tries acts = liftM catMaybes $ sequence [liftM Just act `mplus` return Nothing | act <- acts] - -triesMap :: MonadPlus m => (a -> m b) -> [a] -> m [b] -triesMap f = tries . map f - --- | Lift IO exceptions to ExceptT -liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a -liftIOErrors act = liftException (runExceptT act) >>= either throwError return - --- | Log exceptions and ignore -logAll :: (MonadLog m, C.MonadCatch m) => m () -> m () -logAll = C.handleAll logExc' where - logExc' e = sendLog Warning $ "exception: {}" ~~ displayException e - -fromUtf8 :: ByteString -> String -fromUtf8 = T.unpack . T.decodeUtf8 - -toUtf8 :: String -> ByteString -toUtf8 = T.encodeUtf8 . T.pack - --- | Read file in UTF8 -readFileUtf8 :: FilePath -> IO Text -readFileUtf8 f = withFile f ReadMode $ \h -> do - hSetEncoding h utf8 - cts <- ST.hGetContents h - cts `deepseq` return cts - -writeFileUtf8 :: FilePath -> Text -> IO () -writeFileUtf8 f cts = withFile f WriteMode $ \h -> do - hSetEncoding h utf8 - ST.hPutStr h cts - -hGetLineBS :: Handle -> IO ByteString -hGetLineBS = fmap L.fromStrict . B.hGetLine - -logIO :: C.MonadCatch m => String -> (String -> m ()) -> m () -> m () -logIO pre out = flip C.catch (onIO out) where - onIO :: (String -> a) -> IOException -> a - onIO out' e = out' $ pre ++ displayException e - -logAsync :: (MonadIO m, C.MonadCatch m) => (String -> m ()) -> m () -> m () -logAsync out = flip C.catch (onAsync out) where - onAsync :: (MonadIO m, C.MonadThrow m) => (String -> m ()) -> AsyncException -> m () - onAsync out' e = out' (displayException e) >> C.throwM e - -ignoreIO :: C.MonadCatch m => m () -> m () -ignoreIO = C.handle ignore' where - ignore' :: Monad m => IOException -> m () - ignore' _ = return () - -class FromCmd a where - cmdP :: Parser a - -cmdJson :: String -> [A.Pair] -> Value -cmdJson nm ps = object $ ("command" .= nm) : ps - -guardCmd :: String -> Object -> A.Parser () -guardCmd nm obj = do - cmdName <- obj .:: "command" - guard (nm == cmdName) - --- | Add help command to parser -withHelp :: Parser a -> Parser a -withHelp = (helper' <*>) where - helper' = abortOption ShowHelpText $ long "help" <> short '?' <> help "show help" <> hidden - --- | Subcommand -cmd :: String -> String -> Parser a -> Mod CommandFields a -cmd n d p = command n (info (withHelp p) (progDesc d)) - --- | Parse arguments or return help -parseArgs :: String -> ParserInfo a -> [String] -> Either String a -parseArgs nm p = handle' . execParserPure (prefs mempty) (p { infoParser = withHelp (infoParser p) }) where - handle' :: ParserResult a -> Either String a - handle' (Success r) = Right r - handle' (Failure f) = Left $ fst $ renderFailure f nm - handle' _ = Left "error: completion invoked result" - --- instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where --- askLog = lift Log.askLog - --- | Get hsdev version as list of integers -version :: Maybe [Int] -version = mapM readMaybe $ split (== '.') $cabalVersion - --- | Parse Distribution.Text -parseDT :: (Monad m, Distribution.Text.Text a) => String -> String -> m a -parseDT typeName v = maybe err return (simpleParse v) where - err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v - --- | Measure time of action -timer :: MonadLog m => Text -> m a -> m a -timer msg act = do - s <- liftIO getPOSIXTime - r <- act - e <- liftIO getPOSIXTime - sendLog Trace $ "{}: {}" ~~ msg ~~ show (e - s) - return r +{-# LANGUAGE FlexibleContexts, OverloadedStrings, TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Util ( + withCurrentDirectory, + directoryContents, + traverseDirectory, searchPath, + haskellSource, + cabalFile, + -- * String utils + tab, + trim, split, + -- * Other utils + ordNub, uniqueBy, mapBy, + -- * Helper + (.::), (.::?), (.::?!), objectUnion, noNulls, fromJSON', + -- * Exceptions + liftException, liftE, tries, triesMap, liftIOErrors, + logAll, + -- * UTF-8 + fromUtf8, toUtf8, readFileUtf8, writeFileUtf8, + -- * IO + hGetLineBS, logIO, ignoreIO, logAsync, + -- * Command line + FromCmd(..), + cmdJson, guardCmd, + withHelp, cmd, parseArgs, + -- * Version stuff + version, + -- * Parse + parseDT, + + -- * Log utils + timer, + + -- * Reexportss + module Control.Monad.Except, + MonadIO(..) + ) where + +import Control.Arrow (second, left, (&&&)) +import Control.Exception +import Control.DeepSeq +import Control.Monad +import Control.Monad.Except +import qualified Control.Monad.Catch as C +import Data.Aeson hiding (Result(..), Error) +import qualified Data.Aeson.Types as A +import Data.Char (isSpace) +import Data.List (unfoldr) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HM (HashMap, toList, union) +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Text (Text) +import qualified Data.Text.IO as ST +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +import Data.Time.Clock.POSIX +import Distribution.Text (simpleParse) +import qualified Distribution.Text (Text) +import Options.Applicative +import qualified System.Directory as Dir +import System.FilePath +import System.Log.Simple +import System.IO +import Text.Format +import Text.Read (readMaybe) + +#if !MIN_VERSION_directory(1,2,6) +#if mingw32_HOST_OS +import qualified System.Win32 as Win32 +import Data.Bits ((.&.)) +#else +import qualified System.Posix as Posix +#endif +#endif + +import HsDev.Version + +-- | Run action with current directory set +withCurrentDirectory :: (MonadIO m, C.MonadMask m) => FilePath -> m a -> m a +withCurrentDirectory cur act = C.bracket (liftIO Dir.getCurrentDirectory) (liftIO . Dir.setCurrentDirectory) $ + const (liftIO (Dir.setCurrentDirectory cur) >> act) + +-- | Is directory symbolic link +dirIsSymLink :: FilePath -> IO Bool +#if MIN_VERSION_directory(1,3,0) +dirIsSymLink = Dir.pathIsSymbolicLink +#elif MIN_VERSION_directory(1,2,6) +dirIsSymLink = Dir.isSymbolicLink +#else +dirIsSymLink path = do +#if mingw32_HOST_OS + isReparsePoint <$> Win32.getFileAttributes path + where + fILE_ATTRIBUTE_REPARSE_POINT = 0x400 + isReparsePoint attr = attr .&. fILE_ATTRIBUTE_REPARSE_POINT /= 0 +#else + Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path +#endif +#endif + +-- | Get directory contents safely: no fail, ignoring symbolic links, also prepends paths with dir name +directoryContents :: FilePath -> IO [FilePath] +directoryContents p = handle ignore $ do + b <- Dir.doesDirectoryExist p + isLink <- dirIsSymLink p + if b && (not isLink) + then liftM (map (p ) . filter (`notElem` [".", ".."])) (Dir.getDirectoryContents p) + else return [] + where + ignore :: SomeException -> IO [FilePath] + ignore _ = return [] + +-- | Collect all file names in directory recursively +traverseDirectory :: FilePath -> IO [FilePath] +traverseDirectory p = handle onError $ do + cts <- directoryContents p + liftM concat $ forM cts $ \c -> do + isDir <- Dir.doesDirectoryExist c + if isDir + then (c :) <$> traverseDirectory c + else return [c] + where + onError :: IOException -> IO [FilePath] + onError _ = return [] + +-- | Search something up +searchPath :: (MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m a) -> m a +searchPath p f = do + p' <- liftIO $ Dir.canonicalizePath p + isDir <- liftIO $ Dir.doesDirectoryExist p' + search' (if isDir then p' else takeDirectory p') + where + search' dir + | isDrive dir = f dir + | otherwise = f dir `mplus` search' (takeDirectory dir) + +-- | Is haskell source? +haskellSource :: FilePath -> Bool +haskellSource f = takeExtension f `elem` [".hs", ".lhs"] + +-- | Is cabal file? +cabalFile :: FilePath -> Bool +cabalFile f = takeExtension f == ".cabal" + +-- | Add N tabs to line +tab :: Int -> String -> String +tab n s = replicate n '\t' ++ s + +-- | Trim string +trim :: String -> String +trim = p . p where + p = reverse . dropWhile isSpace + +-- | Split list +split :: (a -> Bool) -> [a] -> [[a]] +split p = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break p) + +-- | nub is quadratic, https://github.com/nh2/haskell-ordnub/#ordnub +ordNub :: Ord a => [a] -> [a] +ordNub = go Set.empty where + go _ [] = [] + go s (x:xs) + | x `Set.member` s = go s xs + | otherwise = x : go (Set.insert x s) xs + +uniqueBy :: Ord b => (a -> b) -> [a] -> [a] +uniqueBy f = M.elems . mapBy f + +mapBy :: Ord b => (a -> b) -> [a] -> M.Map b a +mapBy f = M.fromList . map (f &&& id) + +-- | Workaround, sometimes we get HM.lookup "foo" v == Nothing, but lookup "foo" (HM.toList v) == Just smth +(.::) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser a +v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v + +-- | Returns @Nothing@ when key doesn't exist or value is @Null@ +(.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser (Maybe a) +v .::? name = fmap join $ traverse parseJSON $ lookup name $ HM.toList v + +-- | Same as @.::?@ for list, returns empty list for non-existant key or @Null@ value +(.::?!) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser [a] +v .::?! name = fromMaybe [] <$> (v .::? name) + +-- | Union two JSON objects +objectUnion :: Value -> Value -> Value +objectUnion (Object l) (Object r) = Object $ HM.union l r +objectUnion (Object l) _ = Object l +objectUnion _ (Object r) = Object r +objectUnion _ _ = Null + +-- | No Nulls in JSON object +noNulls :: [A.Pair] -> [A.Pair] +noNulls = filter (not . isNull . snd) where + isNull Null = True + isNull v = v == A.emptyArray || v == A.emptyObject || v == A.String "" + +-- | Try convert json to value +fromJSON' :: FromJSON a => Value -> Maybe a +fromJSON' v = case fromJSON v of + A.Success r -> Just r + _ -> Nothing + +-- | Lift IO exception to ExceptT +liftException :: C.MonadCatch m => m a -> ExceptT String m a +liftException = ExceptT . liftM (left $ \(SomeException e) -> displayException e) . C.try + +-- | Same as @liftException@ +liftE :: C.MonadCatch m => m a -> ExceptT String m a +liftE = liftException + +-- | Run actions ignoring errors +tries :: MonadPlus m => [m a] -> m [a] +tries acts = liftM catMaybes $ sequence [liftM Just act `mplus` return Nothing | act <- acts] + +triesMap :: MonadPlus m => (a -> m b) -> [a] -> m [b] +triesMap f = tries . map f + +-- | Lift IO exceptions to ExceptT +liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a +liftIOErrors act = liftException (runExceptT act) >>= either throwError return + +-- | Log exceptions and ignore +logAll :: (MonadLog m, C.MonadCatch m) => m () -> m () +logAll = C.handleAll logExc' where + logExc' e = sendLog Warning $ "exception: {}" ~~ displayException e + +fromUtf8 :: ByteString -> String +fromUtf8 = T.unpack . T.decodeUtf8 + +toUtf8 :: String -> ByteString +toUtf8 = T.encodeUtf8 . T.pack + +-- | Read file in UTF8 +readFileUtf8 :: FilePath -> IO Text +readFileUtf8 f = withFile f ReadMode $ \h -> do + hSetEncoding h utf8 + cts <- ST.hGetContents h + cts `deepseq` return cts + +writeFileUtf8 :: FilePath -> Text -> IO () +writeFileUtf8 f cts = withFile f WriteMode $ \h -> do + hSetEncoding h utf8 + ST.hPutStr h cts + +hGetLineBS :: Handle -> IO ByteString +hGetLineBS = fmap L.fromStrict . B.hGetLine + +logIO :: C.MonadCatch m => String -> (String -> m ()) -> m () -> m () +logIO pre out = flip C.catch (onIO out) where + onIO :: (String -> a) -> IOException -> a + onIO out' e = out' $ pre ++ displayException e + +logAsync :: (MonadIO m, C.MonadCatch m) => (String -> m ()) -> m () -> m () +logAsync out = flip C.catch (onAsync out) where + onAsync :: (MonadIO m, C.MonadThrow m) => (String -> m ()) -> AsyncException -> m () + onAsync out' e = out' (displayException e) >> C.throwM e + +ignoreIO :: C.MonadCatch m => m () -> m () +ignoreIO = C.handle ignore' where + ignore' :: Monad m => IOException -> m () + ignore' _ = return () + +class FromCmd a where + cmdP :: Parser a + +cmdJson :: String -> [A.Pair] -> Value +cmdJson nm ps = object $ ("command" .= nm) : ps + +guardCmd :: String -> Object -> A.Parser () +guardCmd nm obj = do + cmdName <- obj .:: "command" + guard (nm == cmdName) + +-- | Add help command to parser +withHelp :: Parser a -> Parser a +withHelp = (helper' <*>) where + helper' = abortOption ShowHelpText $ long "help" <> short '?' <> help "show help" <> hidden + +-- | Subcommand +cmd :: String -> String -> Parser a -> Mod CommandFields a +cmd n d p = command n (info (withHelp p) (progDesc d)) + +-- | Parse arguments or return help +parseArgs :: String -> ParserInfo a -> [String] -> Either String a +parseArgs nm p = handle' . execParserPure (prefs mempty) (p { infoParser = withHelp (infoParser p) }) where + handle' :: ParserResult a -> Either String a + handle' (Success r) = Right r + handle' (Failure f) = Left $ fst $ renderFailure f nm + handle' _ = Left "error: completion invoked result" + +-- instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where +-- askLog = lift Log.askLog + +-- | Get hsdev version as list of integers +version :: Maybe [Int] +version = mapM readMaybe $ split (== '.') $cabalVersion + +-- | Parse Distribution.Text +parseDT :: (Monad m, Distribution.Text.Text a) => String -> String -> m a +parseDT typeName v = maybe err return (simpleParse v) where + err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v + +-- | Measure time of action +timer :: MonadLog m => Text -> m a -> m a +timer msg act = do + s <- liftIO getPOSIXTime + r <- act + e <- liftIO getPOSIXTime + sendLog Trace $ "{}: {}" ~~ msg ~~ show (e - s) + return r diff --git a/src/HsDev/Version.hs b/src/HsDev/Version.hs --- a/src/HsDev/Version.hs +++ b/src/HsDev/Version.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE TemplateHaskell #-} - -module HsDev.Version ( - cabalVersion - ) where - -import Data.Char -import Data.List -import Data.Maybe -import Language.Haskell.TH - -cabalVersion :: ExpQ -cabalVersion = do - s <- runIO (readFile "hsdev.cabal") - let - version = listToMaybe $ map (dropWhile isSpace) $ mapMaybe (stripPrefix "version:") $ lines s - maybe (fail "Can't detect version") (\v -> [e| v |]) version +{-# LANGUAGE TemplateHaskell #-} + +module HsDev.Version ( + cabalVersion + ) where + +import Data.Char +import Data.List +import Data.Maybe +import Language.Haskell.TH + +cabalVersion :: ExpQ +cabalVersion = do + s <- runIO (readFile "hsdev.cabal") + let + version = listToMaybe $ map (dropWhile isSpace) $ mapMaybe (stripPrefix "version:") $ lines s + maybe (fail "Can't detect version") (\v -> [e| v |]) version diff --git a/src/HsDev/Watcher.hs b/src/HsDev/Watcher.hs --- a/src/HsDev/Watcher.hs +++ b/src/HsDev/Watcher.hs @@ -1,73 +1,73 @@ -module HsDev.Watcher ( - watchProject, watchModule, watchPackageDb, watchPackageDbStack, - unwatchProject, unwatchModule, unwatchPackageDb, - isSource, isCabal, isConf, - - module System.Directory.Watcher, - module HsDev.Watcher.Types - ) where - -import Control.Lens (view) -import System.FilePath (takeDirectory, takeExtension, ()) - -import System.Directory.Watcher hiding (Watcher) -import System.Directory.Paths -import HsDev.Project -import HsDev.Symbols -import HsDev.Watcher.Types -import HsDev.Util - --- | Watch for project sources changes -watchProject :: Watcher -> Project -> [String] -> IO () -watchProject w proj opts = do - mapM_ (\dir -> watchTree w dir isSource (WatchedProject proj opts)) dirs - watchDir w projDir isCabal (WatchedProject proj opts) - where - dirs = map ((projDir ) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj - projDir = view (projectPath . path) proj - --- | Watch for standalone source -watchModule :: Watcher -> ModuleLocation -> IO () -watchModule w (FileModule f Nothing) = watchDir w (takeDirectory $ view path f) isSource WatchedModule -watchModule w (FileModule _ (Just proj)) = watchProject w proj [] -watchModule _ _ = return () - --- | Watch for top of package-db stack -watchPackageDb :: Watcher -> PackageDbStack -> [String] -> IO () -watchPackageDb w pdbs opts = case topPackageDb pdbs of - GlobalDb -> return () -- TODO: Watch for global package-db - UserDb -> return () -- TODO: Watch for user package-db - (PackageDb pdb) -> watchTree w (view path pdb) isConf (WatchedPackageDb pdbs opts) - --- | Watch for package-db stack -watchPackageDbStack :: Watcher -> PackageDbStack -> [String] -> IO () -watchPackageDbStack w pdbs opts = mapM_ (\pdbs' -> watchPackageDb w pdbs' opts) $ packageDbStacks pdbs - -unwatchProject :: Watcher -> Project -> IO () -unwatchProject w proj = do - mapM_ (unwatchTree w) dirs - void $ unwatchDir w projDir - where - dirs = map ((projDir ) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj - projDir = view (projectPath . path) proj - -unwatchModule :: Watcher -> ModuleLocation -> IO () -unwatchModule w (FileModule f Nothing) = void $ unwatchDir w (takeDirectory $ view path f) -unwatchModule _ (FileModule _ (Just _)) = return () -unwatchModule _ InstalledModule{} = return () -unwatchModule _ _ = return () - --- | Unwatch package-db -unwatchPackageDb :: Watcher -> PackageDb -> IO () -unwatchPackageDb _ GlobalDb = return () -- TODO: Unwatch global package-db -unwatchPackageDb _ UserDb = return () -- TODO: Unwatch user package-db -unwatchPackageDb w (PackageDb pdb) = void $ unwatchTree w (view path pdb) - -isSource :: Event -> Bool -isSource = haskellSource . view eventPath - -isCabal :: Event -> Bool -isCabal = cabalFile . view eventPath - -isConf :: Event -> Bool -isConf (Event _ f _) = takeExtension f == ".conf" +module HsDev.Watcher ( + watchProject, watchModule, watchPackageDb, watchPackageDbStack, + unwatchProject, unwatchModule, unwatchPackageDb, + isSource, isCabal, isConf, + + module System.Directory.Watcher, + module HsDev.Watcher.Types + ) where + +import Control.Lens (view) +import System.FilePath (takeDirectory, takeExtension, ()) + +import System.Directory.Watcher hiding (Watcher) +import System.Directory.Paths +import HsDev.Project +import HsDev.Symbols +import HsDev.Watcher.Types +import HsDev.Util + +-- | Watch for project sources changes +watchProject :: Watcher -> Project -> [String] -> IO () +watchProject w proj opts = do + mapM_ (\dir -> watchTree w dir isSource (WatchedProject proj opts)) dirs + watchDir w projDir isCabal (WatchedProject proj opts) + where + dirs = map ((projDir ) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj + projDir = view (projectPath . path) proj + +-- | Watch for standalone source +watchModule :: Watcher -> ModuleLocation -> IO () +watchModule w (FileModule f Nothing) = watchDir w (takeDirectory $ view path f) isSource WatchedModule +watchModule w (FileModule _ (Just proj)) = watchProject w proj [] +watchModule _ _ = return () + +-- | Watch for top of package-db stack +watchPackageDb :: Watcher -> PackageDbStack -> [String] -> IO () +watchPackageDb w pdbs opts = case topPackageDb pdbs of + GlobalDb -> return () -- TODO: Watch for global package-db + UserDb -> return () -- TODO: Watch for user package-db + (PackageDb pdb) -> watchTree w (view path pdb) isConf (WatchedPackageDb pdbs opts) + +-- | Watch for package-db stack +watchPackageDbStack :: Watcher -> PackageDbStack -> [String] -> IO () +watchPackageDbStack w pdbs opts = mapM_ (\pdbs' -> watchPackageDb w pdbs' opts) $ packageDbStacks pdbs + +unwatchProject :: Watcher -> Project -> IO () +unwatchProject w proj = do + mapM_ (unwatchTree w) dirs + void $ unwatchDir w projDir + where + dirs = map ((projDir ) . view (entity . path)) $ maybe [] sourceDirs $ view projectDescription proj + projDir = view (projectPath . path) proj + +unwatchModule :: Watcher -> ModuleLocation -> IO () +unwatchModule w (FileModule f Nothing) = void $ unwatchDir w (takeDirectory $ view path f) +unwatchModule _ (FileModule _ (Just _)) = return () +unwatchModule _ InstalledModule{} = return () +unwatchModule _ _ = return () + +-- | Unwatch package-db +unwatchPackageDb :: Watcher -> PackageDb -> IO () +unwatchPackageDb _ GlobalDb = return () -- TODO: Unwatch global package-db +unwatchPackageDb _ UserDb = return () -- TODO: Unwatch user package-db +unwatchPackageDb w (PackageDb pdb) = void $ unwatchTree w (view path pdb) + +isSource :: Event -> Bool +isSource = haskellSource . view eventPath + +isCabal :: Event -> Bool +isCabal = cabalFile . view eventPath + +isConf :: Event -> Bool +isConf (Event _ f _) = takeExtension f == ".conf" diff --git a/src/HsDev/Watcher/Types.hs b/src/HsDev/Watcher/Types.hs --- a/src/HsDev/Watcher/Types.hs +++ b/src/HsDev/Watcher/Types.hs @@ -1,14 +1,14 @@ -module HsDev.Watcher.Types ( - Watched(..), - Watcher, - - PackageDbStack, Project - ) where - -import qualified System.Directory.Watcher as W -import HsDev.Project (Project) -import HsDev.PackageDb (PackageDbStack) - -data Watched = WatchedProject Project [String] | WatchedPackageDb PackageDbStack [String] | WatchedModule - -type Watcher = W.Watcher Watched +module HsDev.Watcher.Types ( + Watched(..), + Watcher, + + PackageDbStack, Project + ) where + +import qualified System.Directory.Watcher as W +import HsDev.Project (Project) +import HsDev.PackageDb (PackageDbStack) + +data Watched = WatchedProject Project [String] | WatchedPackageDb PackageDbStack [String] | WatchedModule + +type Watcher = W.Watcher Watched diff --git a/src/System/Directory/Paths.hs b/src/System/Directory/Paths.hs --- a/src/System/Directory/Paths.hs +++ b/src/System/Directory/Paths.hs @@ -1,94 +1,94 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - -module System.Directory.Paths ( - Path, path, fromFilePath, joinPaths, splitPaths, - normPath, subPath, relPathTo, - dirExists, fileExists, takeDir, - isParent, - Paths(..), - canonicalize, - absolutise, - relativise, - normalize - ) where - -import Control.Lens -import Data.List -import Data.Text (Text, pack) -import Data.Text.Lens (unpacked) -import System.Directory -import System.FilePath - --- | Takes much less memory than 'FilePath' -type Path = Text - -path :: Lens' Path FilePath -path = unpacked - -fromFilePath :: FilePath -> Path -fromFilePath = pack - -joinPaths :: [Path] -> Path -joinPaths = fromFilePath . joinPath . map (view path) - -splitPaths :: Path -> [Path] -splitPaths = map fromFilePath . splitDirectories . view path - -normPath :: Path -> Path -normPath = over path normalise - -subPath :: Path -> Path -> Path -subPath p ch = fromFilePath (view path p view path ch) - --- | Make path relative -relPathTo :: Path -> Path -> Path -relPathTo base p = fromFilePath $ makeRelative (view path base) (view path p) - -dirExists :: Path -> IO Bool -dirExists = doesDirectoryExist . view path - -fileExists :: Path -> IO Bool -fileExists = doesFileExist . view path - -takeDir :: Path -> Path -takeDir = over path takeDirectory - --- | Is one path parent of another -isParent :: Path -> Path -> Bool -isParent dir file = norm dir `isPrefixOf` norm file where - norm = dropDot . splitDirectories . normalise . view path - dropDot ("." : chs) = chs - dropDot chs = chs - --- | Something with paths inside -class Paths a where - paths :: Traversal' a FilePath - -instance Paths FilePath where - paths = id - -instance Paths Path where - paths = unpacked - --- | Canonicalize all paths -canonicalize :: Paths a => a -> IO a -canonicalize = paths canonicalizePath - --- | Absolutise paths -absolutise :: Paths a => Path -> a -> a -absolutise parent = over paths addRoot where - addRoot p - | isRelative p = (parent ^. path) p - | otherwise = p - --- | Relativise paths -relativise :: Paths a => Path -> a -> a -relativise parent = over paths (makeRelative (parent ^. path)) - --- | Normalize paths, with workaround for Windows drives -normalize :: Paths a => a -> a -normalize = over paths normalizePath' where - normalizePath' :: FilePath -> FilePath - normalizePath' = fixDrive . normalise - fixDrive :: FilePath -> FilePath - fixDrive = uncurry joinDrive . over _1 (addTrailingPathSeparator . dropWhileEnd isPathSeparator) . splitDrive +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module System.Directory.Paths ( + Path, path, fromFilePath, joinPaths, splitPaths, + normPath, subPath, relPathTo, + dirExists, fileExists, takeDir, + isParent, + Paths(..), + canonicalize, + absolutise, + relativise, + normalize + ) where + +import Control.Lens +import Data.List +import Data.Text (Text, pack) +import Data.Text.Lens (unpacked) +import System.Directory +import System.FilePath + +-- | Takes much less memory than 'FilePath' +type Path = Text + +path :: Lens' Path FilePath +path = unpacked + +fromFilePath :: FilePath -> Path +fromFilePath = pack + +joinPaths :: [Path] -> Path +joinPaths = fromFilePath . joinPath . map (view path) + +splitPaths :: Path -> [Path] +splitPaths = map fromFilePath . splitDirectories . view path + +normPath :: Path -> Path +normPath = over path normalise + +subPath :: Path -> Path -> Path +subPath p ch = fromFilePath (view path p view path ch) + +-- | Make path relative +relPathTo :: Path -> Path -> Path +relPathTo base p = fromFilePath $ makeRelative (view path base) (view path p) + +dirExists :: Path -> IO Bool +dirExists = doesDirectoryExist . view path + +fileExists :: Path -> IO Bool +fileExists = doesFileExist . view path + +takeDir :: Path -> Path +takeDir = over path takeDirectory + +-- | Is one path parent of another +isParent :: Path -> Path -> Bool +isParent dir file = norm dir `isPrefixOf` norm file where + norm = dropDot . splitDirectories . normalise . view path + dropDot ("." : chs) = chs + dropDot chs = chs + +-- | Something with paths inside +class Paths a where + paths :: Traversal' a FilePath + +instance Paths FilePath where + paths = id + +instance Paths Path where + paths = unpacked + +-- | Canonicalize all paths +canonicalize :: Paths a => a -> IO a +canonicalize = paths canonicalizePath + +-- | Absolutise paths +absolutise :: Paths a => Path -> a -> a +absolutise parent = over paths addRoot where + addRoot p + | isRelative p = (parent ^. path) p + | otherwise = p + +-- | Relativise paths +relativise :: Paths a => Path -> a -> a +relativise parent = over paths (makeRelative (parent ^. path)) + +-- | Normalize paths, with workaround for Windows drives +normalize :: Paths a => a -> a +normalize = over paths normalizePath' where + normalizePath' :: FilePath -> FilePath + normalizePath' = fixDrive . normalise + fixDrive :: FilePath -> FilePath + fixDrive = uncurry joinDrive . over _1 (addTrailingPathSeparator . dropWhileEnd isPathSeparator) . splitDrive diff --git a/src/System/Directory/Watcher.hs b/src/System/Directory/Watcher.hs --- a/src/System/Directory/Watcher.hs +++ b/src/System/Directory/Watcher.hs @@ -1,174 +1,174 @@ -{-# LANGUAGE PatternGuards, TemplateHaskell #-} - -module System.Directory.Watcher ( - EventType(..), Event(..), eventType, eventPath, eventTime, - Watcher(..), - withWatcher, - watchDir, watchDir_, unwatchDir, isWatchingDir, - watchTree, watchTree_, unwatchTree, isWatchingTree, - -- * Working with events - readEvent, eventGroup, onEvents, onEvents_ - ) where - -import Control.Lens (makeLenses) -import Control.Arrow -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Monad -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (isJust) -import Data.Ratio ((%)) -import Data.String (fromString) -import Data.Time.Clock (NominalDiffTime) -import Data.Time.Clock.POSIX -import System.FilePath (takeDirectory, isDrive) -import System.Directory -import qualified System.FSNotify as FS - -import HsDev.Util (uniqueBy) - --- | Event type -data EventType = Added | Modified | Removed deriving (Eq, Ord, Enum, Bounded, Read, Show) - --- | Event -data Event = Event { - _eventType :: EventType, - _eventPath :: FilePath, - _eventTime :: POSIXTime } - deriving (Eq, Ord, Show) - -makeLenses ''Event - --- | Directories watcher -data Watcher a = Watcher { - -- | Map from directory to watch stopper - watcherDirs :: MVar (Map FilePath (Bool, IO ())), - watcherMan :: FS.WatchManager, - watcherChan :: Chan (a, Event) } - --- | Create watcher -withWatcher :: (Watcher a -> IO b) -> IO b -withWatcher act = FS.withManager $ \man -> do - ch <- newChan - dirs <- newMVar M.empty - act $ Watcher dirs man ch - --- | Watch directory -watchDir :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO () -watchDir w f p v = do - e <- doesDirectoryExist f - when e $ do - f' <- canonicalizePath f - watching <- isWatchingDir w f' - unless watching $ do - stop <- FS.watchDir - (watcherMan w) - (fromString f') - (p . fromEvent) - (writeChan (watcherChan w) . (,) v . fromEvent) - modifyMVar_ (watcherDirs w) $ return . M.insert f' (False, stop) - -watchDir_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO () -watchDir_ w f p = watchDir w f p () - --- | Unwatch directory, return @False@, if not watched -unwatchDir :: Watcher a -> FilePath -> IO Bool -unwatchDir w f = do - f' <- canonicalizePath f - stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f') - maybe (return ()) snd stop - return $ isJust stop - --- | Check if we are watching dir -isWatchingDir :: Watcher a -> FilePath -> IO Bool -isWatchingDir w f = do - f' <- canonicalizePath f - dirs <- readMVar (watcherDirs w) - return $ isWatchingDir' dirs f' - --- | Watch directory tree -watchTree :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO () -watchTree w f p v = do - e <- doesDirectoryExist f - when e $ do - f' <- canonicalizePath f - watching <- isWatchingTree w f' - unless watching $ do - stop <- FS.watchTree - (watcherMan w) - (fromString f') - (p . fromEvent) - (writeChan (watcherChan w) . (,) v . fromEvent) - modifyMVar_ (watcherDirs w) $ return . M.insert f' (True, stop) - -watchTree_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO () -watchTree_ w f p = watchTree w f p () - --- | Unwatch directory tree -unwatchTree :: Watcher a -> FilePath -> IO Bool -unwatchTree w f = do - f' <- canonicalizePath f - stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f') - maybe (return ()) snd stop - return $ isJust stop - --- | Check if we are watching tree -isWatchingTree :: Watcher a -> FilePath -> IO Bool -isWatchingTree w f = do - f' <- canonicalizePath f - dirs <- readMVar (watcherDirs w) - return $ isWatchingTree' dirs f' - --- | Read next event -readEvent :: Watcher a -> IO (a, Event) -readEvent = readChan . watcherChan - --- | Get event group -eventGroup :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO () -eventGroup w tm onGroup = do - groupVar <- newTMVarIO [] - syncVar <- newEmptyTMVarIO - _ <- async $ forever $ do - ev <- readChan (watcherChan w) - _ <- atomically $ tryPutTMVar syncVar () - atomically $ do - evs <- takeTMVar groupVar - putTMVar groupVar (ev : evs) - forever $ do - _ <- atomically $ takeTMVar syncVar - threadDelay $ floor (tm * 1e6) - evs' <- atomically $ do - evs <- takeTMVar groupVar - putTMVar groupVar [] - _ <- tryTakeTMVar syncVar - return $ reverse evs - onGroup $ uniqueBy (\(_, ev') -> (_eventType ev', _eventPath ev')) evs' - --- | Process all events -onEvents :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO () -onEvents = eventGroup - --- | Process all events -onEvents_ :: Watcher a -> ([(a, Event)] -> IO ()) -> IO () -onEvents_ w = onEvents w (fromRational (1 % 5)) - -fromEvent :: FS.Event -> Event -fromEvent e = Event t (FS.eventPath e) (utcTimeToPOSIXSeconds $ FS.eventTime e) where - t = case e of - FS.Added{} -> Added - FS.Modified{} -> Modified - FS.Removed{} -> Removed - -isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool -isWatchingDir' m dir - | Just (_, _) <- M.lookup dir m = True - | isDrive dir = False - | otherwise = isWatchingTree' m (takeDirectory dir) - -isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool -isWatchingTree' m dir - | Just (True, _) <- M.lookup dir m = True - | isDrive dir = False - | otherwise = isWatchingTree' m (takeDirectory dir) +{-# LANGUAGE PatternGuards, TemplateHaskell #-} + +module System.Directory.Watcher ( + EventType(..), Event(..), eventType, eventPath, eventTime, + Watcher(..), + withWatcher, + watchDir, watchDir_, unwatchDir, isWatchingDir, + watchTree, watchTree_, unwatchTree, isWatchingTree, + -- * Working with events + readEvent, eventGroup, onEvents, onEvents_ + ) where + +import Control.Lens (makeLenses) +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (isJust) +import Data.Ratio ((%)) +import Data.String (fromString) +import Data.Time.Clock (NominalDiffTime) +import Data.Time.Clock.POSIX +import System.FilePath (takeDirectory, isDrive) +import System.Directory +import qualified System.FSNotify as FS + +import HsDev.Util (uniqueBy) + +-- | Event type +data EventType = Added | Modified | Removed deriving (Eq, Ord, Enum, Bounded, Read, Show) + +-- | Event +data Event = Event { + _eventType :: EventType, + _eventPath :: FilePath, + _eventTime :: POSIXTime } + deriving (Eq, Ord, Show) + +makeLenses ''Event + +-- | Directories watcher +data Watcher a = Watcher { + -- | Map from directory to watch stopper + watcherDirs :: MVar (Map FilePath (Bool, IO ())), + watcherMan :: FS.WatchManager, + watcherChan :: Chan (a, Event) } + +-- | Create watcher +withWatcher :: (Watcher a -> IO b) -> IO b +withWatcher act = FS.withManager $ \man -> do + ch <- newChan + dirs <- newMVar M.empty + act $ Watcher dirs man ch + +-- | Watch directory +watchDir :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO () +watchDir w f p v = do + e <- doesDirectoryExist f + when e $ do + f' <- canonicalizePath f + watching <- isWatchingDir w f' + unless watching $ do + stop <- FS.watchDir + (watcherMan w) + (fromString f') + (p . fromEvent) + (writeChan (watcherChan w) . (,) v . fromEvent) + modifyMVar_ (watcherDirs w) $ return . M.insert f' (False, stop) + +watchDir_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO () +watchDir_ w f p = watchDir w f p () + +-- | Unwatch directory, return @False@, if not watched +unwatchDir :: Watcher a -> FilePath -> IO Bool +unwatchDir w f = do + f' <- canonicalizePath f + stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f') + maybe (return ()) snd stop + return $ isJust stop + +-- | Check if we are watching dir +isWatchingDir :: Watcher a -> FilePath -> IO Bool +isWatchingDir w f = do + f' <- canonicalizePath f + dirs <- readMVar (watcherDirs w) + return $ isWatchingDir' dirs f' + +-- | Watch directory tree +watchTree :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO () +watchTree w f p v = do + e <- doesDirectoryExist f + when e $ do + f' <- canonicalizePath f + watching <- isWatchingTree w f' + unless watching $ do + stop <- FS.watchTree + (watcherMan w) + (fromString f') + (p . fromEvent) + (writeChan (watcherChan w) . (,) v . fromEvent) + modifyMVar_ (watcherDirs w) $ return . M.insert f' (True, stop) + +watchTree_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO () +watchTree_ w f p = watchTree w f p () + +-- | Unwatch directory tree +unwatchTree :: Watcher a -> FilePath -> IO Bool +unwatchTree w f = do + f' <- canonicalizePath f + stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f') + maybe (return ()) snd stop + return $ isJust stop + +-- | Check if we are watching tree +isWatchingTree :: Watcher a -> FilePath -> IO Bool +isWatchingTree w f = do + f' <- canonicalizePath f + dirs <- readMVar (watcherDirs w) + return $ isWatchingTree' dirs f' + +-- | Read next event +readEvent :: Watcher a -> IO (a, Event) +readEvent = readChan . watcherChan + +-- | Get event group +eventGroup :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO () +eventGroup w tm onGroup = do + groupVar <- newTMVarIO [] + syncVar <- newEmptyTMVarIO + _ <- async $ forever $ do + ev <- readChan (watcherChan w) + _ <- atomically $ tryPutTMVar syncVar () + atomically $ do + evs <- takeTMVar groupVar + putTMVar groupVar (ev : evs) + forever $ do + _ <- atomically $ takeTMVar syncVar + threadDelay $ floor (tm * 1e6) + evs' <- atomically $ do + evs <- takeTMVar groupVar + putTMVar groupVar [] + _ <- tryTakeTMVar syncVar + return $ reverse evs + onGroup $ uniqueBy (\(_, ev') -> (_eventType ev', _eventPath ev')) evs' + +-- | Process all events +onEvents :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO () +onEvents = eventGroup + +-- | Process all events +onEvents_ :: Watcher a -> ([(a, Event)] -> IO ()) -> IO () +onEvents_ w = onEvents w (fromRational (1 % 5)) + +fromEvent :: FS.Event -> Event +fromEvent e = Event t (FS.eventPath e) (utcTimeToPOSIXSeconds $ FS.eventTime e) where + t = case e of + FS.Added{} -> Added + FS.Modified{} -> Modified + FS.Removed{} -> Removed + +isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool +isWatchingDir' m dir + | Just (_, _) <- M.lookup dir m = True + | isDrive dir = False + | otherwise = isWatchingTree' m (takeDirectory dir) + +isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool +isWatchingTree' m dir + | Just (True, _) <- M.lookup dir m = True + | isDrive dir = False + | otherwise = isWatchingTree' m (takeDirectory dir) diff --git a/src/System/Win32/FileMapping/Memory.hs b/src/System/Win32/FileMapping/Memory.hs --- a/src/System/Win32/FileMapping/Memory.hs +++ b/src/System/Win32/FileMapping/Memory.hs @@ -1,53 +1,53 @@ -module System.Win32.FileMapping.Memory ( - createMap, openMap, mapFile, - withMapFile, readMapFile - ) where - -import Control.Monad.Catch -import Control.Monad.Cont -import Control.Monad.Except -import Data.ByteString.Char8 -import qualified Data.ByteString.Char8 as BS -import Foreign.Ptr -import System.Win32.File (closeHandle) -import System.Win32.FileMapping hiding (mapFile) -import System.Win32.Types -import System.Win32.Mem - -createMap :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> ExceptT String (ContT r IO) HANDLE -createMap mh pf sz mn = verify (/= iNVALID_HANDLE_VALUE) "Invalid handle" $ ContT $ bracket - (createFileMapping mh pf sz mn) - closeHandle - -openMap :: FileMapAccess -> Bool -> Maybe String -> ExceptT String (ContT r IO) HANDLE -openMap f i mn = verify (/= iNVALID_HANDLE_VALUE) "Invalid handle" $ ContT $ bracket - (openFileMapping f i mn) - closeHandle - -mapFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> ExceptT String IO (Ptr a) -mapFile h f off sz = verify (/= nullPtr) "null pointer" $ mapViewOfFile h f off sz - --- | Write data to named map view of file -withMapFile :: String -> ByteString -> IO a -> ExceptT String IO a -withMapFile name str act = mapExceptT (`runContT` return) $ do - p <- lift $ ContT $ BS.useAsCString str - h <- createMap Nothing pAGE_READWRITE (fromIntegral len) (Just name) - ptr <- mapExceptT lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0 - liftIO $ do - copyMemory ptr p (fromIntegral len) - unmapViewOfFile ptr - act - where - len = BS.length str + 1 - --- | Read data from named map view of file -readMapFile :: String -> ExceptT String IO ByteString -readMapFile name = mapExceptT (`runContT` return) $ do - h <- openMap fILE_MAP_ALL_ACCESS True (Just name) - ptr <- mapExceptT lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0 - liftIO $ BS.packCString ptr - -verify :: Monad m => (a -> Bool) -> String -> m a -> ExceptT String m a -verify p str act = do - x <- lift act - if p x then return x else throwError str +module System.Win32.FileMapping.Memory ( + createMap, openMap, mapFile, + withMapFile, readMapFile + ) where + +import Control.Monad.Catch +import Control.Monad.Cont +import Control.Monad.Except +import Data.ByteString.Char8 +import qualified Data.ByteString.Char8 as BS +import Foreign.Ptr +import System.Win32.File (closeHandle) +import System.Win32.FileMapping hiding (mapFile) +import System.Win32.Types +import System.Win32.Mem + +createMap :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> ExceptT String (ContT r IO) HANDLE +createMap mh pf sz mn = verify (/= iNVALID_HANDLE_VALUE) "Invalid handle" $ ContT $ bracket + (createFileMapping mh pf sz mn) + closeHandle + +openMap :: FileMapAccess -> Bool -> Maybe String -> ExceptT String (ContT r IO) HANDLE +openMap f i mn = verify (/= iNVALID_HANDLE_VALUE) "Invalid handle" $ ContT $ bracket + (openFileMapping f i mn) + closeHandle + +mapFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> ExceptT String IO (Ptr a) +mapFile h f off sz = verify (/= nullPtr) "null pointer" $ mapViewOfFile h f off sz + +-- | Write data to named map view of file +withMapFile :: String -> ByteString -> IO a -> ExceptT String IO a +withMapFile name str act = mapExceptT (`runContT` return) $ do + p <- lift $ ContT $ BS.useAsCString str + h <- createMap Nothing pAGE_READWRITE (fromIntegral len) (Just name) + ptr <- mapExceptT lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0 + liftIO $ do + copyMemory ptr p (fromIntegral len) + unmapViewOfFile ptr + act + where + len = BS.length str + 1 + +-- | Read data from named map view of file +readMapFile :: String -> ExceptT String IO ByteString +readMapFile name = mapExceptT (`runContT` return) $ do + h <- openMap fILE_MAP_ALL_ACCESS True (Just name) + ptr <- mapExceptT lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0 + liftIO $ BS.packCString ptr + +verify :: Monad m => (a -> Bool) -> String -> m a -> ExceptT String m a +verify p str act = do + x <- lift act + if p x then return x else throwError str diff --git a/src/System/Win32/FileMapping/NamePool.hs b/src/System/Win32/FileMapping/NamePool.hs --- a/src/System/Win32/FileMapping/NamePool.hs +++ b/src/System/Win32/FileMapping/NamePool.hs @@ -1,33 +1,33 @@ -{-# LANGUAGE LambdaCase #-} - -module System.Win32.FileMapping.NamePool ( - Pool(..), - createPool, withName - ) where - -import Control.Concurrent -import Control.Exception (bracket) -import Control.Monad (liftM, liftM2) -import System.Win32.FileMapping.Memory () - --- | Pool of names for memory mapped files -data Pool = Pool { - poolFreeNames :: MVar [String], - poolNewName :: IO String } - --- | Create pool of numbered names by base name -createPool :: String -> IO Pool -createPool baseName = liftM2 Pool (newMVar []) mkNewName where - mkNewName :: IO (IO String) - mkNewName = do - num <- newMVar (0 :: Integer) - return $ modifyMVar num $ \n -> do - return (succ n, baseName ++ show n) - --- | Use free name from pool -withName :: Pool -> (String -> IO a) -> IO a -withName p = bracket getName freeName where - getName = modifyMVar (poolFreeNames p) $ \case - [] -> liftM ((,) []) $ poolNewName p - (n : ns) -> return (ns, n) - freeName name = modifyMVar_ (poolFreeNames p) (return . (name:)) +{-# LANGUAGE LambdaCase #-} + +module System.Win32.FileMapping.NamePool ( + Pool(..), + createPool, withName + ) where + +import Control.Concurrent +import Control.Exception (bracket) +import Control.Monad (liftM, liftM2) +import System.Win32.FileMapping.Memory () + +-- | Pool of names for memory mapped files +data Pool = Pool { + poolFreeNames :: MVar [String], + poolNewName :: IO String } + +-- | Create pool of numbered names by base name +createPool :: String -> IO Pool +createPool baseName = liftM2 Pool (newMVar []) mkNewName where + mkNewName :: IO (IO String) + mkNewName = do + num <- newMVar (0 :: Integer) + return $ modifyMVar num $ \n -> do + return (succ n, baseName ++ show n) + +-- | Use free name from pool +withName :: Pool -> (String -> IO a) -> IO a +withName p = bracket getName freeName where + getName = modifyMVar (poolFreeNames p) $ \case + [] -> liftM ((,) []) $ poolNewName p + (n : ns) -> return (ns, n) + freeName name = modifyMVar_ (poolFreeNames p) (return . (name:)) diff --git a/src/System/Win32/PowerShell.hs b/src/System/Win32/PowerShell.hs --- a/src/System/Win32/PowerShell.hs +++ b/src/System/Win32/PowerShell.hs @@ -1,36 +1,36 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, LambdaCase #-} - -module System.Win32.PowerShell ( - -- * Escape functions - translate, translateArg, - quote, quoteDouble, - escape - ) where - -import Data.Char (isAlphaNum) - -translate :: String -> String -translate s - | all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s - | otherwise = '"' : snd (foldr escape' (True, "\"") s) - where - escape' '"' (_, s') = (True, '\\' : '"' : s') - escape' '\\' (True, s') = (True, '\\' : '\\' : s') - escape' '\\' (False, s') = (False, '\\' : s') - escape' c (_, s') = (False, c : s') - -translateArg :: String -> String -translateArg s - | all isAlphaNum s = s - | otherwise = "'" ++ translate s ++ "'" - -quote :: String -> String -quote s = "'" ++ concatMap (\case { '\'' -> "''"; ch -> [ch] }) s ++ "'" - -quoteDouble :: String -> String -quoteDouble s = "\"" ++ concatMap (\case { '"' -> "\"\""; ch -> [ch] }) s ++ "\"" - -escape :: (String -> String) -> String -> String -escape fn s - | all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s - | otherwise = fn s +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, LambdaCase #-} + +module System.Win32.PowerShell ( + -- * Escape functions + translate, translateArg, + quote, quoteDouble, + escape + ) where + +import Data.Char (isAlphaNum) + +translate :: String -> String +translate s + | all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s + | otherwise = '"' : snd (foldr escape' (True, "\"") s) + where + escape' '"' (_, s') = (True, '\\' : '"' : s') + escape' '\\' (True, s') = (True, '\\' : '\\' : s') + escape' '\\' (False, s') = (False, '\\' : s') + escape' c (_, s') = (False, c : s') + +translateArg :: String -> String +translateArg s + | all isAlphaNum s = s + | otherwise = "'" ++ translate s ++ "'" + +quote :: String -> String +quote s = "'" ++ concatMap (\case { '\'' -> "''"; ch -> [ch] }) s ++ "'" + +quoteDouble :: String -> String +quoteDouble s = "\"" ++ concatMap (\case { '"' -> "\"\""; ch -> [ch] }) s ++ "\"" + +escape :: (String -> String) -> String -> String +escape fn s + | all (\ch -> isAlphaNum ch || ch `elem` "-_") s = s + | otherwise = fn s diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,189 +1,189 @@ -{-# LANGUAGE OverloadedStrings, TypeApplications #-} - -module Main ( - main - ) where - -import Control.Lens -import Control.Exception (displayException) -import Data.Aeson hiding (Error) -import Data.Aeson.Lens -import Data.Default -import Data.List -import Data.Maybe -import Data.String (fromString) -import qualified Data.Set as S -import Data.Text (Text, unpack) -import qualified Data.Text as T -import System.FilePath -import System.Directory -import Test.Hspec - -import HsDev -import HsDev.Database.SQLite - -send :: Server -> [String] -> IO (Maybe Value) -send srv args = do - r <- sendServer_ srv args - case r of - Result v -> return $ Just v - Error e -> do - expectationFailure $ "command result error: " ++ displayException e - return Nothing - -exports :: Maybe Value -> S.Set Text -exports v = mkSet (v ^.. _Just . values . key "exports" . values . key "id" . key "name" . _String) - -imports :: Maybe Value -> S.Set Import -imports v = mkSet $ do - is <- v ^.. _Just . values . key "imports" . values - maybeToList $ Import <$> (is ^? key "pos" . _JSON) <*> (is ^? key "name" . _String) <*> (is ^? key "qualified" . _Bool) <*> pure (is ^? key "as" . _String) - -mkSet :: Ord a => [a] -> S.Set a -mkSet = S.fromList - - -main :: IO () -main = hspec $ do - describe "scan project" $ do - dir <- runIO getCurrentDirectory - s <- runIO $ startServer_ (def { serverSilent = True }) - - it "should load data" $ do - inserts <- fmap lines $ readFile (dir "tests/data/base.sql") - inServer s $ mapM_ (execute_ . fromString) inserts - - it "should scan project" $ do - void $ send s ["scan", "project", dir "tests/test-package", "--cabal", "--no-deps"] - - it "should resolve export list" $ do - one <- send s ["module", "ModuleOne", "--exact"] - exports one `shouldBe` mkSet ["Ctor", "ctor", "test", "newChan", "untypedFoo"] - two <- send s ["module", "ModuleTwo", "--exact"] - exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings"] - - it "should return cached warnings on sequential checks without file modifications" $ do - firstCheck <- send s ["check", "--file", dir "tests/test-package/ModuleOne.hs"] - secondCheck <- send s ["check", "--file", dir "tests/test-package/ModuleOne.hs"] - firstCheck `shouldNotSatisfy` null - firstCheck `shouldBe` secondCheck - - it "should not lose warnings that comes while loading module for inferring types" $ do - void $ send s ["infer", "--file", dir "tests/test-package/ModuleThree.hs"] - checks <- send s ["check", "--file", dir "tests/test-package/ModuleThree.hs"] - checks `shouldNotSatisfy` null - - it "should return module imports" $ do - three <- send s ["module", "ModuleThree", "--exact"] - imports three `shouldBe` mkSet [ - Import (Position 8 1) "Control.Concurrent.Chan" False Nothing, - Import (Position 10 1) "ModuleOne" False Nothing, - Import (Position 11 1) "ModuleTwo" False (Just "T")] - - it "should pass extensions when checks" $ do - checks <- send s ["check", "--file", dir "tests/test-package/ModuleTwo.hs"] - (checks ^.. _Just . values . key "level" . _String) `shouldSatisfy` (("error" :: Text) `notElem`) - - it "should return types and docs" $ do - test' <- send s ["whois", "test", "--file", dir "tests/test-package/ModuleOne.hs"] - let - testType :: Maybe Text - testType = test' ^? _Just . values . key "info" . key "type" . _String - testType `shouldBe` Just "IO ()" - - it "should infer types" $ do - ts <- send s ["types", "--file", dir "tests/test-package/ModuleOne.hs"] - let - untypedFooRgn = Region (Position 15 1) (Position 15 11) - exprs :: [(Region, Text)] - exprs = do - note' <- ts ^.. _Just . values - rgn' <- maybeToList $ note' ^? key "region" . _JSON - ty' <- maybeToList $ note' ^? key "note" . key "type" . _String - return (rgn', ty') - lookup untypedFooRgn exprs `shouldBe` Just "a -> a -> a" -- FIXME: Where's Num constraint? - - it "should return symbol under location" $ do - _ <- send s ["infer", "--file", dir "tests/test-package/ModuleTwo.hs"] - who' <- send s ["whoat", "13", "15", "--file", dir "tests/test-package/ModuleTwo.hs"] - let - whoName :: Maybe Text - whoName = who' ^? _Just . values . key "id" . key "name" . _String - whoType :: Maybe Text - whoType = who' ^? _Just . values . key "info" . key "type" . _String - whoName `shouldBe` Just "f" - whoType `shouldBe` Just "a -> a" - - it "should distinguish between constructor and data" $ do - whoData <- send s ["whoat", "20", "9", "--file", dir "tests/test-package/ModuleOne.hs"] - whoCtor <- send s ["whoat", "21", "8", "--file", dir "tests/test-package/ModuleOne.hs"] - (whoData ^? _Just . values . key "info" . key "what" . _String) `shouldBe` Just "data" - (whoCtor ^? _Just . values . key "info" . key "what" . _String) `shouldBe` Just "ctor" - - it "should use modified file contents" $ do - modifiedContents <- fmap unpack $ readFileUtf8 $ dir "tests/data/ModuleTwo.modified.hs" - void $ send s ["set-file-contents", "--file", dir "tests/test-package/ModuleTwo.hs", "--contents", modifiedContents] - -- Call scan to wait until file updated - void $ send s ["scan", "--file", dir "tests/test-package/ModuleTwo.hs"] - - it "should rescan module with modified contents" $ do - two <- send s ["module", "ModuleTwo", "--exact"] - exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"] - - it "should use modified source in `check` command" $ do - checks <- send s ["check", "--file", dir "tests/test-package/ModuleTwo.hs"] - (checks ^.. _Just . values . key "note" . key "message" . _String) `shouldSatisfy` (any ("Defined but not used" `T.isPrefixOf`)) - - it "should get usages of symbol" $ do - -- Note, that source was modified - us <- send s ["usages", "2", "2", "--file", dir "tests/test-package/ModuleTwo.hs"] - let - locs :: [(Text, Region)] - locs = do - n <- us ^.. _Just . values - nm <- maybeToList $ n ^? key "in" . key "name" . _String - p <- maybeToList $ n ^? key "at" . _JSON - return (nm, p) - S.fromList locs `shouldBe` S.fromList [ - ("ModuleOne", Position 4 2 `region` Position 4 12), - ("ModuleOne", Position 15 1 `region` Position 15 11), - ("ModuleTwo", Position 2 2 `region` Position 2 12), - ("ModuleTwo", Position 8 19 `region` Position 8 29), - ("ModuleTwo", Position 25 21 `region` Position 25 31), - ("ModuleTwo", Position 25 35 `region` Position 25 45)] - - it "should get usages of local symbols" $ do - us <- send s ["usages", "14", "15", "--file", dir "tests/test-package/ModuleTwo.hs"] - let - locs :: [Region] - locs = do - n <- us ^.. _Just . values - maybeToList $ n ^? key "at" . _JSON - S.fromList locs `shouldBe` S.fromList [ - Position 14 7 `region` Position 14 8, - Position 14 11 `region` Position 14 12, - Position 14 15 `region` Position 14 16] - - it "should evaluate expression in context of module" $ do - vals <- send s ["ghc", "eval", "smth [1,2,3]", "--file", dir "tests/test-package/ModuleThree.hs"] - vals ^.. _Just . values . key "ok" . _String `shouldBe` ["[3,4]"] - - it "should return type of expression in context of module" $ do - tys <- send s ["ghc", "type", "twice twice", "--file", dir "tests/test-package/ModuleTwo.hs"] - tys ^.. _Just . values . key "ok" . _String `shouldBe` ["(a -> a) -> a -> a"] - - it "shouldn't lose module info if unsaved source is broken" $ do - brokenContents <- fmap unpack $ readFileUtf8 $ dir "tests/data/ModuleTwo.broken.hs" - void $ send s ["set-file-contents", "--file", dir "tests/test-package/ModuleTwo.hs", "--contents", brokenContents] - -- Call scan to wait until file updated - void $ send s ["scan", "--file", dir "tests/test-package/ModuleTwo.hs"] - - two <- send s ["module", "ModuleTwo", "--exact"] - exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"] - - it "should complete qualified names" $ do - comps <- send s ["complete", "T.o", "--file", dir "tests/test-package/ModuleThree.hs"] - comps ^.. _Just . values . key "id" . key "name" . _String `shouldBe` ["overloadedStrings"] - - _ <- runIO $ send s ["exit"] - return () +{-# LANGUAGE OverloadedStrings, TypeApplications #-} + +module Main ( + main + ) where + +import Control.Lens +import Control.Exception (displayException) +import Data.Aeson hiding (Error) +import Data.Aeson.Lens +import Data.Default +import Data.List +import Data.Maybe +import Data.String (fromString) +import qualified Data.Set as S +import Data.Text (Text, unpack) +import qualified Data.Text as T +import System.FilePath +import System.Directory +import Test.Hspec + +import HsDev +import HsDev.Database.SQLite + +send :: Server -> [String] -> IO (Maybe Value) +send srv args = do + r <- sendServer_ srv args + case r of + Result v -> return $ Just v + Error e -> do + expectationFailure $ "command result error: " ++ displayException e + return Nothing + +exports :: Maybe Value -> S.Set Text +exports v = mkSet (v ^.. _Just . values . key "exports" . values . key "id" . key "name" . _String) + +imports :: Maybe Value -> S.Set Import +imports v = mkSet $ do + is <- v ^.. _Just . values . key "imports" . values + maybeToList $ Import <$> (is ^? key "pos" . _JSON) <*> (is ^? key "name" . _String) <*> (is ^? key "qualified" . _Bool) <*> pure (is ^? key "as" . _String) + +mkSet :: Ord a => [a] -> S.Set a +mkSet = S.fromList + + +main :: IO () +main = hspec $ do + describe "scan project" $ do + dir <- runIO getCurrentDirectory + s <- runIO $ startServer_ (def { serverSilent = True }) + + it "should load data" $ do + inserts <- fmap lines $ readFile (dir "tests/data/base.sql") + inServer s $ mapM_ (execute_ . fromString) inserts + + it "should scan project" $ do + void $ send s ["scan", "project", dir "tests/test-package", "--cabal", "--no-deps"] + + it "should resolve export list" $ do + one <- send s ["module", "ModuleOne", "--exact"] + exports one `shouldBe` mkSet ["Ctor", "ctor", "test", "newChan", "untypedFoo"] + two <- send s ["module", "ModuleTwo", "--exact"] + exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings"] + + it "should return cached warnings on sequential checks without file modifications" $ do + firstCheck <- send s ["check", "--file", dir "tests/test-package/ModuleOne.hs"] + secondCheck <- send s ["check", "--file", dir "tests/test-package/ModuleOne.hs"] + firstCheck `shouldNotSatisfy` null + firstCheck `shouldBe` secondCheck + + it "should not lose warnings that comes while loading module for inferring types" $ do + void $ send s ["infer", "--file", dir "tests/test-package/ModuleThree.hs"] + checks <- send s ["check", "--file", dir "tests/test-package/ModuleThree.hs"] + checks `shouldNotSatisfy` null + + it "should return module imports" $ do + three <- send s ["module", "ModuleThree", "--exact"] + imports three `shouldBe` mkSet [ + Import (Position 8 1) "Control.Concurrent.Chan" False Nothing, + Import (Position 10 1) "ModuleOne" False Nothing, + Import (Position 11 1) "ModuleTwo" False (Just "T")] + + it "should pass extensions when checks" $ do + checks <- send s ["check", "--file", dir "tests/test-package/ModuleTwo.hs"] + (checks ^.. _Just . values . key "level" . _String) `shouldSatisfy` (("error" :: Text) `notElem`) + + it "should return types and docs" $ do + test' <- send s ["whois", "test", "--file", dir "tests/test-package/ModuleOne.hs"] + let + testType :: Maybe Text + testType = test' ^? _Just . values . key "info" . key "type" . _String + testType `shouldBe` Just "IO ()" + + it "should infer types" $ do + ts <- send s ["types", "--file", dir "tests/test-package/ModuleOne.hs"] + let + untypedFooRgn = Region (Position 15 1) (Position 15 11) + exprs :: [(Region, Text)] + exprs = do + note' <- ts ^.. _Just . values + rgn' <- maybeToList $ note' ^? key "region" . _JSON + ty' <- maybeToList $ note' ^? key "note" . key "type" . _String + return (rgn', ty') + lookup untypedFooRgn exprs `shouldBe` Just "a -> a -> a" -- FIXME: Where's Num constraint? + + it "should return symbol under location" $ do + _ <- send s ["infer", "--file", dir "tests/test-package/ModuleTwo.hs"] + who' <- send s ["whoat", "13", "15", "--file", dir "tests/test-package/ModuleTwo.hs"] + let + whoName :: Maybe Text + whoName = who' ^? _Just . values . key "id" . key "name" . _String + whoType :: Maybe Text + whoType = who' ^? _Just . values . key "info" . key "type" . _String + whoName `shouldBe` Just "f" + whoType `shouldBe` Just "a -> a" + + it "should distinguish between constructor and data" $ do + whoData <- send s ["whoat", "20", "9", "--file", dir "tests/test-package/ModuleOne.hs"] + whoCtor <- send s ["whoat", "21", "8", "--file", dir "tests/test-package/ModuleOne.hs"] + (whoData ^? _Just . values . key "info" . key "what" . _String) `shouldBe` Just "data" + (whoCtor ^? _Just . values . key "info" . key "what" . _String) `shouldBe` Just "ctor" + + it "should use modified file contents" $ do + modifiedContents <- fmap unpack $ readFileUtf8 $ dir "tests/data/ModuleTwo.modified.hs" + void $ send s ["set-file-contents", "--file", dir "tests/test-package/ModuleTwo.hs", "--contents", modifiedContents] + -- Call scan to wait until file updated + void $ send s ["scan", "--file", dir "tests/test-package/ModuleTwo.hs"] + + it "should rescan module with modified contents" $ do + two <- send s ["module", "ModuleTwo", "--exact"] + exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"] + + it "should use modified source in `check` command" $ do + checks <- send s ["check", "--file", dir "tests/test-package/ModuleTwo.hs"] + (checks ^.. _Just . values . key "note" . key "message" . _String) `shouldSatisfy` (any ("Defined but not used" `T.isPrefixOf`)) + + it "should get usages of symbol" $ do + -- Note, that source was modified + us <- send s ["usages", "2", "2", "--file", dir "tests/test-package/ModuleTwo.hs"] + let + locs :: [(Text, Region)] + locs = do + n <- us ^.. _Just . values + nm <- maybeToList $ n ^? key "in" . key "name" . _String + p <- maybeToList $ n ^? key "at" . _JSON + return (nm, p) + S.fromList locs `shouldBe` S.fromList [ + ("ModuleOne", Position 4 2 `region` Position 4 12), + ("ModuleOne", Position 15 1 `region` Position 15 11), + ("ModuleTwo", Position 2 2 `region` Position 2 12), + ("ModuleTwo", Position 8 19 `region` Position 8 29), + ("ModuleTwo", Position 25 21 `region` Position 25 31), + ("ModuleTwo", Position 25 35 `region` Position 25 45)] + + it "should get usages of local symbols" $ do + us <- send s ["usages", "14", "15", "--file", dir "tests/test-package/ModuleTwo.hs"] + let + locs :: [Region] + locs = do + n <- us ^.. _Just . values + maybeToList $ n ^? key "at" . _JSON + S.fromList locs `shouldBe` S.fromList [ + Position 14 7 `region` Position 14 8, + Position 14 11 `region` Position 14 12, + Position 14 15 `region` Position 14 16] + + it "should evaluate expression in context of module" $ do + vals <- send s ["ghc", "eval", "smth [1,2,3]", "--file", dir "tests/test-package/ModuleThree.hs"] + vals ^.. _Just . values . key "ok" . _String `shouldBe` ["[3,4]"] + + it "should return type of expression in context of module" $ do + tys <- send s ["ghc", "type", "twice twice", "--file", dir "tests/test-package/ModuleTwo.hs"] + tys ^.. _Just . values . key "ok" . _String `shouldBe` ["(a -> a) -> a -> a"] + + it "shouldn't lose module info if unsaved source is broken" $ do + brokenContents <- fmap unpack $ readFileUtf8 $ dir "tests/data/ModuleTwo.broken.hs" + void $ send s ["set-file-contents", "--file", dir "tests/test-package/ModuleTwo.hs", "--contents", brokenContents] + -- Call scan to wait until file updated + void $ send s ["scan", "--file", dir "tests/test-package/ModuleTwo.hs"] + + two <- send s ["module", "ModuleTwo", "--exact"] + exports two `shouldBe` mkSet ["untypedFoo", "twice", "overloadedStrings", "useUntypedFoo"] + + it "should complete qualified names" $ do + comps <- send s ["complete", "T.o", "--file", dir "tests/test-package/ModuleThree.hs"] + comps ^.. _Just . values . key "id" . key "name" . _String `shouldBe` ["overloadedStrings"] + + _ <- runIO $ send s ["exit"] + return () diff --git a/tests/data/ModuleTwo.broken.hs b/tests/data/ModuleTwo.broken.hs --- a/tests/data/ModuleTwo.broken.hs +++ b/tests/data/ModuleTwo.broken.hs @@ -1,29 +1,29 @@ -module ModuleTwo ( - untypedFoo, - twice, - overloadedStrings, - useUntypedFoo - ) where - -import ModuleOne (untypedFoo) - -import Data.String - -broken :: IO () -broken = do - s <- - --- | Apply function twice -twice :: (a -> a) -> a -> a -twice f = f . f - -data MyString = MyString String - -instance IsString MyString where - fromString = MyString - -overloadedStrings :: MyString -overloadedStrings = "Hello" - -useUntypedFoo :: Int -> Int -> Int -useUntypedFoo x y = untypedFoo x (untypedFoo x x) +module ModuleTwo ( + untypedFoo, + twice, + overloadedStrings, + useUntypedFoo + ) where + +import ModuleOne (untypedFoo) + +import Data.String + +broken :: IO () +broken = do + s <- + +-- | Apply function twice +twice :: (a -> a) -> a -> a +twice f = f . f + +data MyString = MyString String + +instance IsString MyString where + fromString = MyString + +overloadedStrings :: MyString +overloadedStrings = "Hello" + +useUntypedFoo :: Int -> Int -> Int +useUntypedFoo x y = untypedFoo x (untypedFoo x x) diff --git a/tests/data/ModuleTwo.modified.hs b/tests/data/ModuleTwo.modified.hs --- a/tests/data/ModuleTwo.modified.hs +++ b/tests/data/ModuleTwo.modified.hs @@ -1,25 +1,25 @@ -module ModuleTwo ( - untypedFoo, - twice, - overloadedStrings, - useUntypedFoo - ) where - -import ModuleOne (untypedFoo) - -import Data.String - --- | Apply function twice -twice :: (a -> a) -> a -> a -twice f = f . f - -data MyString = MyString String - -instance IsString MyString where - fromString = MyString - -overloadedStrings :: MyString -overloadedStrings = "Hello" - -useUntypedFoo :: Int -> Int -> Int -useUntypedFoo x y = untypedFoo x (untypedFoo x x) +module ModuleTwo ( + untypedFoo, + twice, + overloadedStrings, + useUntypedFoo + ) where + +import ModuleOne (untypedFoo) + +import Data.String + +-- | Apply function twice +twice :: (a -> a) -> a -> a +twice f = f . f + +data MyString = MyString String + +instance IsString MyString where + fromString = MyString + +overloadedStrings :: MyString +overloadedStrings = "Hello" + +useUntypedFoo :: Int -> Int -> Int +useUntypedFoo x y = untypedFoo x (untypedFoo x x) diff --git a/tests/data/base.sql b/tests/data/base.sql --- a/tests/data/base.sql +++ b/tests/data/base.sql @@ -1,4 +1,4 @@ -insert into package_dbs values ('global-db', 'base', '4.9.0.0'); -insert into modules values (1, null, null, json('[]'), 'base', '4.9.0.0', 'Control.Concurrent.Chan', 1, null, 'Control.Concurrent.Chan', null, json('[]'), json('{}'), null, null, json('[]')); -insert into symbols values (1, 'newChan', 1, null, null, null, 'function', 'IO (Chan a)', null, null, null, null, null, null, null); -insert into exports values (1, 1); +insert into package_dbs values ('global-db', 'base', '4.9.0.0'); +insert into modules values (1, null, null, json('[]'), 'base', '4.9.0.0', 'Control.Concurrent.Chan', 1, null, 'Control.Concurrent.Chan', null, json('[]'), json('{}'), null, null, json('[]')); +insert into symbols values (1, 'newChan', 1, null, null, null, 'function', 'IO (Chan a)', null, null, null, null, null, null, null); +insert into exports values (1, 1); diff --git a/tests/test-package/ModuleOne.hs b/tests/test-package/ModuleOne.hs --- a/tests/test-package/ModuleOne.hs +++ b/tests/test-package/ModuleOne.hs @@ -1,21 +1,21 @@ -module ModuleOne ( - test, - newChan, - untypedFoo, - Ctor(..), ctor, - ) where - -import Control.Concurrent.Chan (newChan) - --- | Some test function -test :: IO () -test = return () - --- | Some function without type -untypedFoo x y = x + y - --- | Same name of type and ctor -data Ctor a = Ctor a - -ctor :: Ctor Int -ctor = Ctor 10 +module ModuleOne ( + test, + newChan, + untypedFoo, + Ctor(..), ctor, + ) where + +import Control.Concurrent.Chan (newChan) + +-- | Some test function +test :: IO () +test = return () + +-- | Some function without type +untypedFoo x y = x + y + +-- | Same name of type and ctor +data Ctor a = Ctor a + +ctor :: Ctor Int +ctor = Ctor 10 diff --git a/tests/test-package/ModuleThree.hs b/tests/test-package/ModuleThree.hs --- a/tests/test-package/ModuleThree.hs +++ b/tests/test-package/ModuleThree.hs @@ -1,15 +1,15 @@ -module ModuleThree ( - smth, - - module ModuleOne, - module T - ) where - -import Control.Concurrent.Chan - -import ModuleOne (test) -import ModuleTwo as T hiding (twice) - -smth :: [Int] -> [Int] -smth [] = [1] -smth (x:xs) = map (+x) xs +module ModuleThree ( + smth, + + module ModuleOne, + module T + ) where + +import Control.Concurrent.Chan + +import ModuleOne (test) +import ModuleTwo as T hiding (twice) + +smth :: [Int] -> [Int] +smth [] = [1] +smth (x:xs) = map (+x) xs diff --git a/tests/test-package/ModuleTwo.hs b/tests/test-package/ModuleTwo.hs --- a/tests/test-package/ModuleTwo.hs +++ b/tests/test-package/ModuleTwo.hs @@ -1,21 +1,21 @@ -module ModuleTwo ( - untypedFoo, - twice, - overloadedStrings - ) where - -import ModuleOne (untypedFoo) - -import Data.String - --- | Apply function twice -twice :: (a -> a) -> a -> a -twice f = f . f - -data MyString = MyString String - -instance IsString MyString where - fromString = MyString - -overloadedStrings :: MyString -overloadedStrings = "Hello" +module ModuleTwo ( + untypedFoo, + twice, + overloadedStrings + ) where + +import ModuleOne (untypedFoo) + +import Data.String + +-- | Apply function twice +twice :: (a -> a) -> a -> a +twice f = f . f + +data MyString = MyString String + +instance IsString MyString where + fromString = MyString + +overloadedStrings :: MyString +overloadedStrings = "Hello" diff --git a/tests/test-package/test-package.cabal b/tests/test-package/test-package.cabal --- a/tests/test-package/test-package.cabal +++ b/tests/test-package/test-package.cabal @@ -1,25 +1,25 @@ -name: test-package -version: 0.1.0.0 -synopsis: hsdev test package --- description: --- license: -author: voidex -maintainer: voidex@live.com --- copyright: --- category: -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 - -library - exposed-modules: - ModuleOne - ModuleTwo - ModuleThree - -- other-modules: - -- other-extensions: - build-depends: base >=4.8 - hs-source-dirs: . - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-tabs - default-extensions: OverloadedStrings +name: test-package +version: 0.1.0.0 +synopsis: hsdev test package +-- description: +-- license: +author: voidex +maintainer: voidex@live.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: + ModuleOne + ModuleTwo + ModuleThree + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 + hs-source-dirs: . + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-tabs + default-extensions: OverloadedStrings diff --git a/tools/hsdev.hs b/tools/hsdev.hs --- a/tools/hsdev.hs +++ b/tools/hsdev.hs @@ -1,36 +1,36 @@ -module Main ( - main - ) where - -import Control.Exception -import Data.List -import Network.Socket (withSocketsDo) -import Options.Applicative -import System.Environment (getArgs) -import System.IO - -import HsDev.Server.Commands (runServerCommand) -import HsDev.Server.Types -import HsDev.Util - -main :: IO () -main = handle logErr' $ withSocketsDo $ do - hSetBuffering stdout LineBuffering - hSetEncoding stdout utf8 - as <- prepareArgs - case parseArgs "hsdev" (info cmdP (progDesc "hsdev tool")) as of - Left e -> putStrLn e - Right scmd -> runServerCommand scmd - where - logErr' (SomeException e) = putStrLn $ "exception " ++ show e - --- | Get args with '--stdin' flag replaced and 'help' command changed to flag -prepareArgs :: IO [String] -prepareArgs = getArgs >>= prepare where - prepare [] = return [] - prepare ("help" : as) = prepare $ as ++ ["-?"] - prepare as - | "--stdin" `elem` as = do - input <- getContents - return $ delete "--stdin" as ++ ["--data", input] - | otherwise = return as +module Main ( + main + ) where + +import Control.Exception +import Data.List +import Network.Socket (withSocketsDo) +import Options.Applicative +import System.Environment (getArgs) +import System.IO + +import HsDev.Server.Commands (runServerCommand) +import HsDev.Server.Types +import HsDev.Util + +main :: IO () +main = handle logErr' $ withSocketsDo $ do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 + as <- prepareArgs + case parseArgs "hsdev" (info cmdP (progDesc "hsdev tool")) as of + Left e -> putStrLn e + Right scmd -> runServerCommand scmd + where + logErr' (SomeException e) = putStrLn $ "exception " ++ show e + +-- | Get args with '--stdin' flag replaced and 'help' command changed to flag +prepareArgs :: IO [String] +prepareArgs = getArgs >>= prepare where + prepare [] = return [] + prepare ("help" : as) = prepare $ as ++ ["-?"] + prepare as + | "--stdin" `elem` as = do + input <- getContents + return $ delete "--stdin" as ++ ["--data", input] + | otherwise = return as