diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright 2008, Thomas Schilling +Copyright 2008, Simon Marlow +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 name of the author nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE 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 UNIVERSITY +COURT OF THE UNIVERSITY OF GLASGOW OR THE 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/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,353 @@ + +Introduction +============ + +[Scion][home] is a Haskell library that aims to implement those parts +of a Haskell IDE which are independent of the particular front-end. +Scion is based on the GHC API and Cabal. It provides both a Haskell +API and a server for non-Haskell clients such as Emacs and Vim. + + [home]: http://code.google.com/p/scion-lib/ + + +Installation +============ + +(For developer builds see section "Hacking" below.) + +Scion requires [GHC 6.10.1][ghc] or later. All other dependencies +should be on [Hackage][hackage] and can be installed using +[cabal-install][ci]. Scion consists of a library and a server which +is used by front-ends that are not written in Haskell. + +To install the library and server use: + + $ cd dir/to/scion + $ cabal install + +This will install the executable `scion_server` in the `bin` directory +of `cabal-install`, typically `$HOME/.cabal/bin`. + +If you do not want to install the server (and its dependencies), turn +off the "server" flag which is enabled by default: + + $ cabal install -f-server + +In order to use scion with your favourite front-end, see the specific +instructions for the front-end below. The Emacs and Vim front-ends +are included with Scion and their installation instruction follow +below. The necessary files are installed with Scion by default and +there is currently no option to turn this off. + + [ghc]: http://haskell.org/ghc/download.html + [hackage]: http://hackage.haskell.org/packages/hackage.html + [ci]: http://hackage.haskell.org/trac/hackage/wiki/CabalInstall + + +Bug Reports +=========== + +Please send bug reports or feature requests to the [Issue tracker][issues]. + + [issues]: http://code.google.com/p/scion-lib/issues/list + + +Usage +===== + +Since Scion is a library, you should consult the haddock documentation +for how to use it. However, you may look at the Emacs frontend for +inspiration. + +Emacs +===== + +Scion's Emacs mode should be seen as complimentary to the existing +Haskell mode. To use it install the Scion server as described +above. In the following we'll assume that the server has been install +as: + + $ ~/.cabal/bin/scion-server + +Add the following to your emacs configuration (typically "~/.emacs"): + + ;; Substitute the desired version for + (add-to-list 'load-path "~/.cabal/share/scion-/emacs") + (require 'scion) + + ;; if ./cabal/bin is not in your $PATH + (setq scion-program "~/.cabal/bin/scion-server") + + (defun my-haskell-hook () + ;; Whenever we open a file in Haskell mode, also activate Scion + (scion-mode 1) + ;; Whenever a file is saved, immediately type check it and + ;; highlight errors/warnings in the source. + (scion-flycheck-on-save 1)) + + (add-hook 'haskell-mode-hook 'my-haskell-hook) + +Scion mode needs to communicate with the external server. By default +the server will be started automatically when needed. See "Manually +Connecting to Scion" below for how to connect to the server manually. + +Scion uses Cabal as a library which in turn might look for external +programs such as [happy][] or [alex][]. In order to find these, the +`PATH` environment variable has to be set up correctly. + + [happy]: http://www.haskell.org/happy/ + [alex]: http://www.haskell.org/alex/ + +The scion server process inherits the environment variables from the +Emacs process. Depending on your system this may be different than +what you would get if you started the server from the shell. To +adjust the `PATH` environment variable from within Emacs, add +something like the following to your `.emacs`: + + ;; add ~/usr/bin to the PATH + (setenv "PATH" "$HOME/usr/bin:$PATH" t) + +Once you have a running and connected Scion server, you can use the +commands provided by scion-mode: + + * `C-c C-x C-l` (`scion-load`) load the current file with Scion. If + the file is within a Cabal project this will prompt to use the + settings from one of the components in the package description + file. You can still choose to load only the current file. + + * `C-c C-o` (`scion-open-cabal-project`) configures a Cabal project + and loads the meta-data from a Cabal file. Note that this + does not type check or load anything. If you change the Cabal + file of a project, call this function to update the session with + the new settings. + +If loading generates any errors or warnings, a buffer will appear and +list them all. Pressing `RET` on a note will jump to its source +location. Pressing `q` closes the buffer, and `C-c C-n` +(`scion-list-compiler-notes`) brings it back. Use `M-n` +(`scion-next-note-in-buffer`) and `M-p` +(`scion-previous-note-in-buffer`) to navigate within the notes of one +buffer. + +## Completion + +The following commands offer completion for a few things. + + * `C-c i l` (`haskell-insert-language`) asks for a `LANGUAGE` pragma + and adds it to the top of the file. + + * `C-c i p` (`haskell-insert-pragma`) inserts a pragma at the + current cursor position. (At the moment this doesn't try to make + sense of the selected pragma, however.) + + * `C-c i m` (`haskell-insert-module-name`) inserts the name of an + external module (external), i.e., a module _not_ from the current + package. + + * `C-c i f` (`haskell-insert-flag`) insert (GHC) command line flag + at point. (Really only makes sense within an `OPTIONS_GHC` pragma.) + +## Experimental features + +The following should work most of the cases. + + * `C-c C-.` (`scion-goto-definition`) jumps to the definition of the + identifier at point. If there is no identifier at point, offers a + list to complete on a particular identifier. This currently only + works for identifiers defined within the same project. + + * `C-c C-t` shows type of identifier at point. This only works if + the current file typechecks, but then it also works for local + identifiers. For polymorphic function it will show the type to + which they are _instantiated_, e.g., + + f x = x + (1::Int) + + Calling this command on `+` will print `Int -> Int -> Int` instead + of `Num a => a -> a -> a`. + + +# Manually Connecting to Scion + +If you set the variable `scion-auto-connect` to `'ask` (the default is +`'always`), Scion will ask whether to start the server. If you set it +to `nil` you need to manually connect to the server. + +You can start the server manually on the command line and then use + + M-x scion-connect + +to connect to that server. However, most of the time it will be more +convenient to start the server from within Emacs: + + M-x scion + + +Vim +=== + +## Installation + +Vim mode requires Python support (version 2.4 or later). Vim 7.2 or +later have Python support enabled by default. However, not every +distribution of Vim includes a recent enough version of Python. +Notably, MacVim is only linked against version 2.3.5 to be compatible +with OS X 10.4. You will need to build it from source, which is +however reasonably fast. + +To check for python support the following should return `1`: + + :echo has('python') + +To find out the version use: + + :py import sys + :py print sys.version + +Add the following to your `~/.vimrc` (or only `~/.gvimrc` if you have +different Vim versions). If Vim should start the Scion server itself +(recommended): + + " recommended: vim spawns a scion instance itself: + let g:scion_connection_setting = [ 'scion', "~/.cabal/bin/scion-server"] + +If you want to connect to a running instance of the server via TCP, +add (where `4005` is the port number used by the scion server): + + " use socket or TCP/IP connection instead: + let g:scion_connection_setting = [ 'socket', ["localhost", 4005] ] + +Add the following independently of which connection mode you prefer: + + set runtimepath+=~/.cabal/share/scion-/vim_runtime_path/ + +Depending on your Vim config you will need to add the following lines +as well: + + :filetype plugin on + :source ~/.cabal/share/scion-/vim_runtime_path/plugin/haskell_scion.vim + +You store certain settings in a configuration file. (Note: This +feature is currently experimental and details may change in future +Scion releases.) To generate an initial configuration file run + + :WriteSampleConfigScion + +Keep only these lines: + + {"type":"build-configuration", "dist-dir":"dist-scion", "extra-args": []} + {"scion-default-cabal-config":"dist-scion"} + +## Usage + +To load a component (a Cabal library or executable, or just a single +file) use one of: + + :LoadComponentScion library + :LoadComponentScion executable:cabal_executable_name + :LoadComponentScion file:cabal_executable_name + :LoadComponentScion + +The last one is a shortcut for `file:`. You can use completion. + +At this point you should already get some compilation errors. After +modifying the file, use + + :BackgroundTypecheckFileScion + +to re-typecheck just the current file. + +If the file typechecks you can move the cursor onto an identifier and +use the command + + :ThingAtPointScion + +You should see something like this, which is the (instantiated) type +of the identifier at the point: + + {'Just': 'print :: [Char] -> IO ()'} + +Have a look at `vim_runtime_path/ftplugin/haskell.vim` to see a list of all +commands which are implemented yet. + +`BackgroundTypecheckFileScion` should be called automatically after +buf write. If you don't like this set `g:dont_check_on_buf_write` or +overwrite `g:haskell_qf_hook` to change open/close quickfix and jump to +first *error* behaviour. + +Discussion +========== + +For discussions about Scion use the [scion-lib-devel][ml] mailing list. + + [ml]: http://groups.google.com/group/scion-lib-devel + + +Hacking +======= + +The main repository for Scion is hosted on [Github][gh]. Get it via + + $ git clone git://github.com/nominolo/scion + +Send patches or pull requests to nominolo (email address at googlemail +dot com). Note that, if you fork the project on Github your fork +won't take up additional space on your account. + + [gh]: http://github.com + + +Building +-------- + +For development it is probably easier to use the GNU Make than Cabal +directly. The makefile includes a file called `config.mk` which is +not present by default. You can use the provided `config.mk.sample` +and edit it: + + $ cp config.mk.sample config.mk + $ edit config.mk + +After that, the makefile takes care of the rest. + + $ make # configure and build + $ make install # configure, build, and install + + +Using an in-place GHC +--------------------- + +GHC 6.10.1 has a couple of problems. For example, not all error +messages are reported using the GHC API but instead are printed to +stdout/stderr. Some parts also call `exitWith` directly. GHC's HEAD +branch has some of these bugs fixed and may contain new features not +present in the stable branch. If you want to compile against an +inplace GHC, the following steps should work: + + 1. On Windows, make sure that Cabal finds the inplace gcc + + $ cd /path/to/ghc + $ cp `which gcc` ghc/ + + (Adjust to version of GCC that GHC was compiled with.) + + 2. Set the `GHC_PATH` variable to the correct path to for your + system. Make sure *not* to set `HC`, `PKG`, or `HADDOCK`, they + will automatically be set to point to the inplace versions. + + 3. Use `make`. + + +License +======= + +The parts of Scion written in Haskell are licensed under the BSD +license. The Emacs lisp parts are licensed under the GPL license +version 2 or (at your option) any later version. + + +Known Pitfalls +============== +If you get an error message like this: + "scion_server: mkTopLevEnv: not interpreted main:Main" +then you should rm [Ss]etup.hi [Ss]etup.o in the project directory. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/emacs/scion.el b/emacs/scion.el new file mode 100644 --- /dev/null +++ b/emacs/scion.el @@ -0,0 +1,2414 @@ +;;; scion.el --- Haskell Minor Mode for Interacting with the Scion Library +;; +;;;; License +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2008 Thomas Schilling +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + +;;;; Dependencies and setup + +(eval-and-compile + (require 'cl) + (require 'json) + (unless (fboundp 'define-minor-mode) + (require 'easy-mmode) + (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))) +(require 'hideshow) +(require 'thingatpt) +(require 'comint) +(require 'ido) +(eval-when (compile) + (require 'apropos) + (require 'outline) + ;; (require 'etags) + ) + + +;;;--------------------------------------------------------------------------- +;;;; Customize groups +;; +;;;;; scion + +(defgroup scion nil + "Interaction with the Scion Server." + :prefix "scion-" + :group 'applications) + +;;;;; scion-ui + +(defgroup scion-ui nil + "Interaction with the Scion Server." + :prefix "scion-" + :group 'scion) + +(defcustom scion-kill-without-query-p nil + "If non-nil, kill SCION processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'scion-ui) + +;;;;; scion-haskell + +(defgroup scion-haskell nil + "Haskell server configuration." + :prefix "scion-" + :group 'scion) + +(defcustom scion-connected-hook nil + "List of functions to call when SCION connects to Haskell." + :type 'hook + :group 'scion-haskell) + +(defcustom scion-haskell-host "127.0.0.1" + "The default hostname (or IP address) to connect to." + :type 'string + :group 'scion-haskell) + +(defcustom scion-port 4005 + "Port to use as the default for `scion-connect'." + :type 'integer + :group 'scion-haskell) + +(make-variable-buffer-local + (defvar scion-modeline-string nil + "The string that should be displayed in the modeline if +`scion-extended-modeline' is true, and which indicates the +current connection, package and state of a Lisp buffer. +The string is periodically updated by an idle timer.")) + +;;;--------------------------------------------------------------------------- + +;;;; Macros + +(defmacro* when-let ((var value) &rest body) + "Evaluate VALUE, and if the result is non-nil bind it to VAR and +evaluate BODY. + +\(fn (VAR VALUE) &rest BODY)" + `(let ((,var ,value)) + (when ,var ,@body))) + +(defmacro destructure-case (value &rest patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (destructuring-bind ((op &rest rands) &rest body) clause + `(,op (destructuring-bind ,rands ,operands + . ,body))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "Elisp destructure-case failed: %S" ,tmp)))))))) + +(put 'destructure-case 'lisp-indent-function 1) + +;;;; Temporary Popup Buffers + +;; Interface +(defmacro* scion-with-popup-buffer ((name &optional package + connection emacs-snapshot) + &body body) + "Similar to `with-output-to-temp-buffer'. +Bind standard-output and initialize some buffer-local variables. +Restore window configuration when closed. + +NAME is the name of the buffer to be created. +PACKAGE is the value `scion-buffer-package'. +CONNECTION is the value for `scion-buffer-connection'. +If nil, no explicit connection is associated with +the buffer. If t, the current connection is taken. + +If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous +state of Emacs after closing the temporary buffer. Otherwise, the +current state will be saved and later restored." + `(let* ((vars% (list ,(if (eq package t) '(scion-current-package) package) + ,(if (eq connection t) '(scion-connection) connection) + ;; Defer the decision for NILness until runtime. + (or ,emacs-snapshot (scion-current-emacs-snapshot)))) + (standard-output (scion-popup-buffer ,name vars%))) + (with-current-buffer standard-output + (prog1 (progn ,@body) + (assert (eq (current-buffer) standard-output)) + (setq buffer-read-only t) + (scion-init-popup-buffer vars%))))) + +(put 'scion-with-popup-buffer 'lisp-indent-function 1) + +(defmacro* with-struct ((conc-name &rest slots) struct &body body) + "Like with-slots but works only for structs. +\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)" + (flet ((reader (slot) (intern (concat (symbol-name conc-name) + (symbol-name slot))))) + (let ((struct-var (gensym "struct"))) + `(let ((,struct-var ,struct)) + (symbol-macrolet + ,(mapcar (lambda (slot) + (etypecase slot + (symbol `(,slot (,(reader slot) ,struct-var))) + (cons `(,(first slot) (,(reader (second slot)) + ,struct-var))))) + slots) + . ,body))))) + +(put 'with-struct 'lisp-indent-function 2) + +(defmacro scion-define-keys (keymap &rest key-command) + "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)." + `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) + key-command))) + +(put 'slime-define-keys 'lisp-indent-function 1) + +(defun aquamacs-p () + (string-match "Aquamacs" (emacs-version))) + +(defun scion-completing-read (prompt collection &optional predicate require-match + initial-input hist def inherit-input-method) + (cond + ;; for some reason ido-completing-read is broken in Aquamacs + ((not (aquamacs-p)) + (ido-completing-read prompt collection predicate + require-match initial-input hist def)) + (t + (completing-read prompt collection predicate require-match initial-input + hist def inherit-input-method)))) + +;;;--------------------------------------------------------------------------- +;;;;;; Tree View Widget + +(defstruct (scion-tree (:conc-name scion-tree.)) + item + (print-fn #'scion-tree-default-printer :type function) + (kids '() :type list) + (collapsed-p t :type boolean) + (prefix "" :type string) + (start-mark nil) + (end-mark nil) + (plist '() :type list)) + +(defun scion-tree-leaf-p (tree) + (not (scion-tree.kids tree))) + +(defun scion-tree-default-printer (tree) + (princ (scion-tree.item tree) (current-buffer))) + +(defun scion-tree-decoration (tree) + (cond ((scion-tree-leaf-p tree) "-- ") + ((scion-tree.collapsed-p tree) "[+] ") + (t "-+ "))) + +(defun scion-tree-insert-list (list prefix) + "Insert a list of trees." + (loop for (elt . rest) on list + do (cond (rest + (insert prefix " |") + (scion-tree-insert elt (concat prefix " |")) + (insert "\n")) + (t + (insert prefix " `") + (scion-tree-insert elt (concat prefix " ")))))) + +(defun scion-tree-insert-decoration (tree) + (insert (scion-tree-decoration tree))) + +(defun scion-tree-indent-item (start end prefix) + "Insert PREFIX at the beginning of each but the first line. +This is used for labels spanning multiple lines." + (save-excursion + (goto-char end) + (beginning-of-line) + (while (< start (point)) + (insert-before-markers prefix) + (forward-line -1)))) + +(defun scion-tree-insert (tree prefix) + "Insert TREE prefixed with PREFIX at point." + (with-struct (scion-tree. print-fn kids collapsed-p start-mark end-mark) tree + (let ((line-start (line-beginning-position))) + (setf start-mark (point-marker)) + (scion-tree-insert-decoration tree) + (funcall print-fn tree) + (scion-tree-indent-item start-mark (point) (concat prefix " ")) + (add-text-properties line-start (point) (list 'scion-tree tree)) + (set-marker-insertion-type start-mark t) + (when (and kids (not collapsed-p)) + (terpri (current-buffer)) + (scion-tree-insert-list kids prefix)) + (setf (scion-tree.prefix tree) prefix) + (setf end-mark (point-marker))))) + +(defun scion-tree-at-point () + (cond ((get-text-property (point) 'scion-tree)) + (t (error "No tree at point")))) + +(defun scion-tree-delete (tree) + "Delete the region for TREE." + (delete-region (scion-tree.start-mark tree) + (scion-tree.end-mark tree))) + +(defun scion-tree-toggle (tree) + "Toggle the visibility of TREE's children." + (with-struct (scion-tree. collapsed-p start-mark end-mark prefix) tree + (setf collapsed-p (not collapsed-p)) + (scion-tree-delete tree) + (insert-before-markers " ") ; move parent's end-mark + (backward-char 1) + (scion-tree-insert tree prefix) + (delete-char 1) + (goto-char start-mark))) + + +;;;--------------------------------------------------------------------------- + +(defvar scion-program "scion_server" + "Program name of the Scion server.") + +(defvar scion-last-compilation-result nil + "The result of the most recently issued compilation.") + + +(make-variable-buffer-local + (defvar scion-mode-line " Scion")) + +(define-minor-mode scion-mode + "\\\ +Scion: Smart Haskell mode. +\\{scion-mode-map}" + nil + scion-mode-line + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'self-insert-command)) + (when scion-last-compilation-result + (scion-highlight-notes (scion-compiler-notes) (current-buffer)))) + +(define-key scion-mode-map " " 'self-insert-command) + +;; dummy definitions for the compiler +(defvar scion-net-coding-system) +(defvar scion-net-processes) +(defvar scion-default-connection) + +(defun scion (&optional command) + "Start a Scion server and connect to it." + (interactive) + (let ((server-program (or command scion-program))) + (scion-start :program server-program))) + +(defun* scion-start (&key (program scion-program) + program-args + env + directory + name + (buffer "*scion-server*")) + (let ((proc (scion-maybe-start-server program program-args env + directory buffer))) + )) + +(defun scion-maybe-start-server (program program-args env directory buffer) + (cond + ((not (comint-check-proc buffer)) + (scion-start-server program program-args env directory buffer)) + (t + (message "Scion server is already running") + nil))) + +(defvar scion-connect-buffer nil + "Buffer that is currently trying to connect to a Scion server.") + +(defun scion-start-server (program program-args env directory buffer) + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (delete-region (point-min) (point-max)) + (comint-mode) + (setq scion-connect-buffer (current-buffer)) + (message "Connecting... (Abort with `M-x scion-abort-connect`.)") + (add-hook 'comint-output-filter-functions + 'scion-check-server-ready nil t) + (let ((process-environment (append env process-environment))) + (comint-exec (current-buffer) "scion-emacs" program nil program-args)) + (let ((proc (get-buffer-process (current-buffer)))) + ; (scion-set-query-on-exit-flag proc) + proc))) + +(defun scion-check-server-ready (server-output) + "Watches the server's output for the port number to connect to." + (let* ((regexp "^=== Listening on port: \\([0-9]+\\)$") + (port (save-excursion + (goto-char (point-min)) + (when (re-search-forward regexp nil t) + (read (match-string 1)) )))) + (when port + (remove-hook 'comint-output-filter-functions + 'scion-check-server-ready t) + (setq scion-connect-buffer nil) + (sleep-for 0.1) ;; give the server some time to get connected + (scion-connect "127.0.0.1" port)))) + +(defun scion-abort-connect () + "Abort the current connection attempt." + (interactive) + (cond (scion-connect-buffer + (kill-buffer scion-connect-buffer) + (message "Connection attempt aborted.")) + (t + (error "Not connecting.")))) + +(defun scion-connect (host port &optional coding-system) + "Connect to a running Swank server." + (interactive (list (read-from-minibuffer "Host: " scion-haskell-host) + (read-from-minibuffer "Port: " (format "%d" scion-port) + nil t))) + (when (and (interactive-p) scion-net-processes + (y-or-n-p "Close old connections first? ")) + (scion-disconnect)) + (message "Connecting to Scion Server on port %S.." port) + (let ((coding-system (or coding-system scion-net-coding-system))) + (scion-check-coding-system coding-system) + (message "Connecting to Scion Server on port %S.." port) + (let* ((process (scion-net-connect host port coding-system)) + (scion-dispatching-connection process)) + (scion-setup-connection process)))) + +;;;--------------------------------------------------------------------------- +;;;; Networking +;;;--------------------------------------------------------------------------- +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SCION protocol message begins with a 3-byte length header +;;; followed by an S-expression as text. [XXX: The sexp must be readable +;;; both by Emacs and by Common Haskell, so if it contains any embedded +;;; code fragments they should be sent as strings.] +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in Scion/Server/Emacs.hs. + +(defvar scion-net-processes nil + "List of processes (sockets) connected to Haskell.") + +(defvar scion-net-process-close-hooks '() + "List of functions called when a scion network connection closes. +The functions are called with the process as their argument.") + +(defun scion-secret () + "Finds the magic secret from the user's home directory. +Returns nil if the file doesn't exist or is empty; otherwise the first +line of the file." + nil) ; disable for now + +;;;--------------------------------------------------------------------------- +;;; Interface + +(defun scion-net-connect (host port coding-system) + "Establish a connection with a Scion Server. + + -> " + (let* ((inhibit-quit nil) + (proc (open-network-stream "Scion Server" nil host port)) + (buffer (scion-make-net-buffer " *scion-connection*"))) + (push proc scion-net-processes) + (set-process-buffer proc buffer) + (set-process-filter proc 'scion-net-filter) + (set-process-sentinel proc 'scion-net-sentinel) + (scion-set-query-on-exit-flag proc) + (when (fboundp 'set-process-coding-system) + (scion-check-coding-system coding-system) + (set-process-coding-system proc coding-system coding-system)) + (when-let (secret (scion-secret)) + (scion-net-send secret proc)) + proc)) + +(defun scion-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo)) + buffer)) + +(defun scion-set-query-on-exit-flag (process) + "Set PROCESS's query-on-exit-flag to `scion-kill-without-query-p'." + (when scion-kill-without-query-p + ;; avoid byte-compiler warnings + (let ((fun (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query))) + (funcall fun process nil)))) + + +;;;--------------------------------------------------------------------------- +;;;;; Coding system madness + +(defvar scion-net-valid-coding-systems + '((iso-latin-1-unix nil "iso-latin-1-unix") + (iso-8859-1-unix nil "iso-latin-1-unix") + (binary nil "iso-latin-1-unix") + (utf-8-unix t "utf-8-unix") +;; (emacs-mule-unix t "emacs-mule-unix") +;; (euc-jp-unix t "euc-jp-unix") + ) + "A list of valid coding systems. +Each element is of the form: (NAME MULTIBYTEP CL-NAME)") + +(defun scion-find-coding-system (name) + "Return the coding system for the symbol NAME. +The result is either an element in `scion-net-valid-coding-systems' +or NIL." + (let* ((probe (assq name scion-net-valid-coding-systems))) + (if (and probe (if (fboundp 'check-coding-system) + (ignore-errors (check-coding-system (car probe))) + (eq (car probe) 'binary))) + probe))) + +(defvar scion-net-coding-system + (find-if 'scion-find-coding-system + '(iso-latin-1-unix iso-8859-1-unix binary)) + "*Coding system used for network connections. +See also `scion-net-valid-coding-systems'.") + +(defun scion-check-coding-system (coding-system) + "Signal an error if CODING-SYSTEM isn't a valid coding system." + (interactive) + (let ((props (scion-find-coding-system coding-system))) + (unless props + (error "Invalid scion-net-coding-system: %s. %s" + coding-system (mapcar #'car scion-net-valid-coding-systems))) + (when (and (second props) (boundp 'default-enable-multibyte-characters)) + (assert default-enable-multibyte-characters)) + t)) + +(defcustom scion-repl-history-file-coding-system + (cond ((scion-find-coding-system 'utf-8-unix) 'utf-8-unix) + (t scion-net-coding-system)) + "*The coding system for the history file." + :type 'symbol + :group 'scion-repl) + +(defun scion-coding-system-mulibyte-p (coding-system) + (second (scion-find-coding-system coding-system))) + +(defun scion-coding-system-cl-name (coding-system) + (third (scion-find-coding-system coding-system))) + +;;;--------------------------------------------------------------------------- +;;; Interface + +(defun scion-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((json-object-type 'plist) + (json-key-type 'keyword) + (json-array-type 'list) + (string (concat (json-encode sexp) "\n")) + ;; (string (concat (scion-net-encode-length (length msg)) msg)) + (coding-system (cdr (process-coding-system proc)))) + (scion-log-event sexp) + (cond ((scion-safe-encoding-p coding-system string) + (process-send-string proc string)) + (t (error "Coding system %s not suitable for %S" + coding-system string))))) + +(defun scion-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (if (featurep 'xemacs) + ;; FIXME: XEmacs encodes non-encodeable chars as ?~ automatically + t + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (scion-coding-system-mulibyte-p coding-system)))))) + +(defun scion-net-close (process &optional debug) + (setq scion-net-processes (remove process scion-net-processes)) + (when (eq process scion-default-connection) + (setq scion-default-connection nil)) + (cond (debug + (set-process-sentinel process 'ignore) + (set-process-filter process 'ignore) + (delete-process process)) + (t + (run-hook-with-args 'scion-net-process-close-hooks process) + ;; killing the buffer also closes the socket + (kill-buffer (process-buffer process))))) + +(defun scion-net-sentinel (process message) + (message "Connection to Scion server closed unexpectedly: %s" message) + (scion-net-close process)) + +;;; Socket input is handled by `scion-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun scion-net-filter (process string) + "Accept output from the socket and process all complete messages." + (condition-case ex + (progn + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (scion-process-available-input process)) + ('error + (message "Error in process filter: %s" ex) + nil))) + +(defun scion-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (scion-net-have-input-p) + (let ((event (scion-net-read-or-lose process)) + (ok nil)) + (scion-log-event event) + (unwind-protect + (save-current-buffer + (scion-dispatch-event event process) + (setq ok t)) + (unless ok + (scion-run-when-idle 'scion-process-available-input process))))))) + +(defun scion-net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (if (= 0 (forward-line 1)) + t + nil)) + +(defun scion-run-when-idle (function &rest args) + "Call FUNCTION as soon as Emacs is idle." + (apply #'run-at-time + (if (featurep 'xemacs) itimer-short-interval 0) + nil function args)) + +(defun scion-net-read-or-lose (process) + (condition-case net-read-error + (scion-net-read) + (net-read-error + ;; (debug) + (scion-net-close process t) + (error "net-read error: %S" net-read-error)))) + +(defun scion-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let ((json-object-type 'plist) + (json-key-type 'keyword) + (json-array-type 'list)) + (let* ((start (point)) + (message (json-read)) + (end (min (1+ (point)) (point-max)))) + ;; TODO: handle errors somehow + (delete-region start end) + message))) + +(defun scion-net-decode-length () + "Read a 24-bit hex-encoded integer from buffer." + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16)) + +(defun scion-net-encode-length (n) + "Encode an integer into a 24-bit hex string." + (format "%06x" n)) + +(defun scion-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (with-temp-buffer + (let (print-escape-nonascii + print-escape-newlines + print-length + print-level) + (prin1 sexp (current-buffer)) + (buffer-string)))) + +;;;--------------------------------------------------------------------------- + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `scion-dispatching-connection' if dynamically bound, or +;;; `scion-buffer-connection' if this is set buffer-local, or +;;; `scion-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `scion-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `scion-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `scion-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and scion hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar scion-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `scion-buffer-connection' and `scion-default-connection'.") + +(make-variable-buffer-local + (defvar scion-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `scion-default-connection'.")) + +(defvar scion-default-connection nil + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`scion-dispatching-connection' or `scion-buffer-connection'.") + +(defun scion-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or scion-dispatching-connection + scion-buffer-connection + scion-default-connection)) + +(defun scion-connection () + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (scion-current-connection))) + (cond ((and (not conn) scion-net-processes) + (or (scion-auto-select-connection) + (error "No default connection selected."))) + ((not conn) + (or (scion-auto-connect) + (error "Not connected."))) + ((not (eq (process-status conn) 'open)) + (error "Connection closed.")) + (t conn)))) + +(defvar scion-auto-connect 'always) + +(defun scion-auto-connect () + (cond ((or (eq scion-auto-connect 'always) + (and (eq scion-auto-connect 'ask) + (y-or-n-p "No connection. Start Scion? "))) + (save-window-excursion + (scion) ; XXX + (while (not (scion-current-connection)) + (sleep-for 1)) + (scion-connection))) + (t nil))) + +(defvar scion-auto-select-connection 'ask) + +(defun scion-auto-select-connection () + (let* ((c0 (car scion-net-processes)) + (c (cond ((eq scion-auto-select-connection 'always) c0) + ((and (eq scion-auto-select-connection 'ask) + (y-or-n-p + (format "No default connection selected. %s %s? " + "Switch to" (scion-connection-name c0)))) + c0)))) + (when c + (scion-select-connection c) + (message "Switching to connection: %s" (scion-connection-name c)) + c))) + +(defun scion-select-connection (process) + "Make PROCESS the default connection." + (setq scion-default-connection process)) + +(defun scion-cycle-connections () + "Change current scion connection, and make it buffer local." + (interactive) + (let* ((tail (or (cdr (member (scion-current-connection) + scion-net-processes)) + scion-net-processes)) + (p (car tail))) + (scion-select-connection p) + (unless (eq major-mode 'scion-repl-mode) + (setq scion-buffer-connection p)) + (message "Lisp: %s %s" (scion-connection-name p) (process-contact p)))) + +(defmacro* scion-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `scion-connection' is used. + +\(fn (&optional PROCESS) &body BODY))" + `(with-current-buffer + (process-buffer (or ,process (scion-connection) + (error "No connection"))) + ,@body)) + +(put 'scion-with-connection-buffer 'lisp-indent-function 1) + +(defun scion-connected-p () + "Return true if the Swank connection is open." + (not (null scion-net-processes))) + +(defun scion-compute-connection-state (conn) + (cond ((null conn) :disconnected) + ;((scion-stale-connection-p conn) :stale) + ;((scion-debugged-connection-p conn) :debugged) + ((and (scion-use-sigint-for-interrupt conn) + (scion-busy-p conn)) :busy) + ((eq scion-buffer-connection conn) :local) + (t :connected))) + +(defun scion-connection-state-as-string (state) + (case state + (:connected "") + (:disconnected "not connected") + (:busy "busy..") + (:debugged "debugged..") + (:stale "stale") + (:local "local") + )) + +;;; Connection-local variables: + +(defmacro scion-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `scion-connection'." + (let ((real-var (intern (format "%s:connlocal" varname)))) + `(progn + ;; Variable + (make-variable-buffer-local + (defvar ,real-var ,@initial-value-and-doc)) + ;; Accessor + (defun ,varname (&optional process) + (scion-with-connection-buffer (process) ,real-var)) + ;; Setf + (defsetf ,varname (&optional process) (store) + `(scion-with-connection-buffer (,process) + (setq (\, (quote (\, real-var))) (\, store)) + (\, store))) + '(\, varname)))) + +(put 'scion-def-connection-var 'lisp-indent-function 2) + +;; Let's indulge in some pretty colours. +(unless (featurep 'xemacs) + (font-lock-add-keywords + 'emacs-lisp-mode + '(("(\\(scion-def-connection-var\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +(scion-def-connection-var scion-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(scion-def-connection-var scion-pid nil + "The process id of the Haskell process.") + +(scion-def-connection-var scion-connection-name nil + "The short name for connection.") + +;;;;; Connection setup + +(defvar scion-connection-counter 0 + "The number of SCION connections made. For generating serial numbers.") + +;;; Interface +(defun scion-setup-connection (process) + "Make a connection out of PROCESS." + (let ((scion-dispatching-connection process)) + (scion-init-connection-state process) + (scion-select-connection process) + process)) + +(defun scion-init-connection-state (proc) + "Initialize connection state in the process-buffer of PROC." + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal scion-net-processes (list proc)) + (setq scion-connection-counter 0)) + (scion-with-connection-buffer () + (setq scion-buffer-connection proc)) + (setf (scion-connection-number proc) (incf scion-connection-counter)) + ;; We do the rest of our initialization asynchronously. The current + ;; function may be called from a timer, and if we setup the REPL + ;; from a timer then it mysteriously uses the wrong keymap for the + ;; first command. + (scion-eval-async '("connection-info") + (scion-curry #'scion-set-connection-info proc))) + +(defun scion-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (let ((scion-dispatching-connection connection)) + (destructuring-bind (&key pid version + &allow-other-keys) info + (scion-check-version version connection) + (setf (scion-pid) pid + (scion-connection-name) (format "%d" pid))) + (let ((args nil)) + (run-hooks 'scion-connected-hook)) + (message "Connected."))) + +(defvar scion-protocol-version 1) + +(defun scion-check-version (version conn) + (or (equal version scion-protocol-version) + (equal scion-protocol-version 'ignore) + (y-or-n-p + (format "Versions differ: %s (scion client) vs. %s (scion server). Continue? " + scion-protocol-version version)) + (scion-net-close conn) + (top-level))) + +(defun scion-generate-connection-name (lisp-name) + (loop for i from 1 + for name = lisp-name then (format "%s<%d>" lisp-name i) + while (find name scion-net-processes + :key #'scion-connection-name :test #'equal) + finally (return name))) + +(defun scion-connection-close-hook (process) + (when (eq process scion-default-connection) + (when scion-net-processes + (scion-select-connection (car scion-net-processes)) + (message "Default connection closed; switched to #%S (%S)" + (scion-connection-number) + (scion-connection-name))))) + +(add-hook 'scion-net-process-close-hooks 'scion-connection-close-hook) + +;;;;; Commands on connections + +(defun scion-disconnect () + "Disconnect all connections." + (interactive) + (mapc #'scion-net-close scion-net-processes)) + +(defun scion-connection-port (connection) + "Return the remote port number of CONNECTION." + (if (featurep 'xemacs) + (car (process-id connection)) + (cadr (process-contact connection)))) + +(defun scion-process (&optional connection) + "Return the Lisp process for CONNECTION (default `scion-connection'). +Can return nil if there's no process object for the connection." + nil + ;; (let ((proc (scion-inferior-process connection))) +;; (if (and proc +;; (memq (process-status proc) '(run stop))) +;; proc)) + ) + +;; Non-macro version to keep the file byte-compilable. +;; (defun scion-set-inferior-process (connection process) +;; (setf (scion-inferior-process connection) process)) + +(defvar scion-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun scion-background-activities-enabled-p () + nil) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`scion-eval-async') for +;;; most things. Reserve synchronous evaluations (`scion-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `scion-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `scion-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar scion-current-thread t + "The id of the current thread on the Lisp side. +t means the \"current\" thread; +:repl-thread the thread that executes REPL requests; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar scion-buffer-package nil + "The Lisp package associated with the current buffer. +This is set only in buffers bound to specific packages.")) + + +(defun scion-current-package () + nil) + +(defvar scion-accept-process-output-supports-floats + (ignore-errors (accept-process-output nil 0.0) t)) + +(defun scion-accept-process-output (&optional process timeout) + "Like `accept-process-output' but the TIMEOUT argument can be a float." + (cond (scion-accept-process-output-supports-floats + (accept-process-output process timeout)) + (t + (accept-process-output process + (if timeout (truncate timeout)) + ;; Emacs 21 uses microsecs; Emacs 22 millisecs + (if timeout (truncate (* timeout 1000000))))))) + +;;; Synchronous requests are implemented in terms of asynchronous +;;; ones. We make an asynchronous request with a continuation function +;;; that `throw's its result up to a `catch' and then enter a loop of +;;; handling I/O until that happens. + +(defvar scion-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + +;;; `scion-rex' is the RPC primitive which is used to implement both +;;; `scion-eval' and `scion-eval-async'. You can use it directly if +;;; you need to, but the others are usually more convenient. + +(defmacro* scion-rex ((&rest saved-vars) + (sexp &optional + (package '(scion-current-package)) + (thread 'scion-current-thread)) + &rest continuations) + "(scion-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +VARs are a list of saved variables visible in the other forms. Each +VAR is either a symbol or a list (VAR INIT-VALUE). + +SEXP is evaluated and the printed version is sent to Lisp. + +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. +The default value is (scion-current-package). + +CLAUSES is a list of patterns with same syntax as +`destructure-case'. The result of the evaluation of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because Emacs20 cannot +deal with that." + (let ((result (gensym)) + (gsexp (gensym))) + `(lexical-let ,(loop for var in saved-vars + collect (etypecase var + (symbol (list var var)) + (cons var))) + (let ((,gsexp ,sexp)) + (scion-dispatch-event + (list :method (car ,gsexp) + :params (cdr ,gsexp) + :package ,package + :continuation (lambda (,result) + (destructure-case ,result + ,@continuations)))))))) + +(defun scion-eval (sexp &optional package) + "Evaluate EXPR on the Scion server and return the result." + (when (null package) (setq package (scion-current-package))) + (let* ((tag (gensym (format "scion-result-%d-" + (1+ (scion-continuation-counter))))) + (scion-stack-eval-tags (cons tag scion-stack-eval-tags))) + (apply + #'funcall + (catch tag + (scion-rex (tag sexp) + (sexp package) + ((:ok value) + (unless (member tag scion-stack-eval-tags) + (error "Reply to canceled synchronous eval request tag=%S sexp=%S" + tag sexp)) + (throw tag (list #'identity value))) + ((:error msg) + (throw tag (list #'error (format "Scion Eval Error: %s" msg)))) + ((:abort) + (throw tag (list #'error "Synchronous Remote Evaluation aborted")))) + (let ((debug-on-quit t) + (inhibit-quit nil) + (conn (scion-connection))) + (while t + (unless (eq (process-status conn) 'open) + (error "Server connection closed unexpectedly")) + (scion-accept-process-output nil 0.01))))))) + +(defun scion-eval-async (sexp &optional cont package) + "Evaluate EXPR on the server and call CONT with the result." + (scion-rex (cont (buffer (current-buffer))) + (sexp (or package (scion-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (funcall cont result))) + ((:error msg) + (message "Scion Eval Async: %s" msg)) + ((:abort) + (message "Evaluation aborted.")))) + +(put 'scion-eval-async 'lisp-indent-function 1) + +;;;;; Protocol event handler (the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(scion-def-connection-var scion-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(scion-def-connection-var scion-continuation-counter 0 + "Continuation serial number counter.") + +(defvar scion-event-hooks) + +(defun scion-dispatch-event (event &optional process) + (let ((scion-dispatching-connection (or process (scion-connection)))) + (or (run-hook-with-args-until-success 'scion-event-hooks event) + (destructuring-bind (&key method error (result nil result-p) params id + continuation package + &allow-other-keys) + event + (cond + ((and method) + ;; we're trying to send a message + (when (and (scion-use-sigint-for-interrupt) (scion-busy-p)) + (scion-display-oneliner "; pipelined request... %S" form)) + (let ((id (incf (scion-continuation-counter)))) + (push (cons id continuation) (scion-rex-continuations)) + (scion-send `(:method ,method + :params ,params + :id ,id)))) + ((and (or error result-p) id) + (let ((value nil)) + (if error + (destructuring-bind (&key name message) error + (if (string= name "MalformedRequest") + (progn + (scion-with-popup-buffer ("*Scion Error*") + (princ (format "Invalid protocol message:\n%s" + event)) + (goto-char (point-min))) + (error "Invalid protocol message")) + (setq value (list :error message)))) + (setq value (list :ok result))) + + ;; we're receiving the result of a remote call + (let ((rec (assq id (scion-rex-continuations)))) + (cond (rec (setf (scion-rex-continuations) + (remove rec (scion-rex-continuations))) + (funcall (cdr rec) value)) + (t + (error "Unexpected reply: %S %S" id value))))))))))) + +(defun scion-send (sexp) + "Send SEXP directly over the wire on the current connection." + (scion-net-send sexp (scion-connection))) + +(defun scion-stop-server () + "Stop the server we are currently connected to." + (interactive) + (scion-eval '(quit)) + (scion-disconnect)) + +(defun scion-use-sigint-for-interrupt (&optional connection) + nil) + +(defun scion-busy-p (&optional conn) + "True if Haskell has outstanding requests. +Debugged requests are ignored." + nil) + +(defun scion-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (scion-oneliner msg))))) + +(defun scion-oneliner (string) + "Return STRING truncated to fit in a single echo-area line." + (substring string 0 (min (length string) + (or (position ?\n string) most-positive-fixnum) + (1- (frame-width))))) + +(defun scion-curry (fun &rest args) + `(lambda (&rest more) (apply ',fun (append ',args more)))) + +(defun scion-rcurry (fun &rest args) + `(lambda (&rest more) (apply ',fun (append more ',args)))) + +(defsubst scion-makehash (&optional test) + (if (fboundp 'make-hash-table) + (if test (make-hash-table :test test) (make-hash-table)) + (with-no-warnings + (makehash test)))) + +;;;;; Snapshots of current Emacs state + +;;; Window configurations do not save (and hence not restore) +;;; any narrowing that could be applied to a buffer. +;;; +;;; For this purpose, we introduce a superset of a window +;;; configuration that does include the necessary information to +;;; properly restore narrowing. +;;; +;;; We call this superset an Emacs Snapshot. + +(defstruct (scion-narrowing-configuration + (:conc-name scion-narrowing-configuration.)) + narrowedp beg end) + +(defstruct (scion-emacs-snapshot (:conc-name scion-emacs-snapshot.)) + ;; We explicitly store the value of point even though it's implicitly + ;; stored in the window-configuration because Emacs provides no + ;; way to access the things stored in a window configuration. + window-configuration narrowing-configuration point-marker) + +(defun scion-current-narrowing-configuration (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (make-scion-narrowing-configuration :narrowedp (scion-buffer-narrowed-p) + :beg (point-min-marker) + :end (point-max-marker)))) + +(defun scion-set-narrowing-configuration (narrowing-cfg) + (when (scion-narrowing-configuration.narrowedp narrowing-cfg) + (narrow-to-region (scion-narrowing-configuration.beg narrowing-cfg) + (scion-narrowing-configuration.end narrowing-cfg)))) + +(defun scion-current-emacs-snapshot (&optional frame) + "Returns a snapshot of the current state of FRAME, or the +currently active frame if FRAME is not given respectively." + (with-current-buffer + (if frame + (window-buffer (frame-selected-window (selected-frame))) + (current-buffer)) + (make-scion-emacs-snapshot + :window-configuration (current-window-configuration frame) + :narrowing-configuration (scion-current-narrowing-configuration) + :point-marker (point-marker)))) + +(defun scion-set-emacs-snapshot (snapshot) + "Restores the state of Emacs according to the information saved +in SNAPSHOT." + (let ((window-cfg (scion-emacs-snapshot.window-configuration snapshot)) + (narrowing-cfg (scion-emacs-snapshot.narrowing-configuration snapshot)) + (marker (scion-emacs-snapshot.point-marker snapshot))) + (set-window-configuration window-cfg) ; restores previously current buffer. + (scion-set-narrowing-configuration narrowing-cfg) + (goto-char (marker-position marker)))) + +(defun scion-current-emacs-snapshot-fingerprint (&optional frame) + "Return a fingerprint of the current emacs snapshot. +Fingerprints are `equalp' if and only if they represent window +configurations that are very similar (same windows and buffers.) + +Unlike real window-configuration objects, fingerprints are not +sensitive to the point moving and they can't be restored." + (mapcar (lambda (window) (list window (window-buffer window))) + (scion-frame-windows frame))) + +(defun scion-frame-windows (&optional frame) + "Return the list of windows in FRAME." + (loop with last-window = (previous-window (frame-first-window frame)) + for window = (frame-first-window frame) then (next-window window) + collect window + until (eq window last-window))) + +;;;;; Temporary popup buffers + +(make-variable-buffer-local + (defvar scion-popup-buffer-saved-emacs-snapshot nil + "The snapshot of the current state in Emacs before the popup-buffer +was displayed, so that this state can be restored later on. +Buffer local in popup-buffers.")) + +(make-variable-buffer-local + (defvar scion-popup-buffer-saved-fingerprint nil + "The emacs snapshot \"fingerprint\" after displaying the buffer.")) + + + +(defun scion-popup-buffer (name buffer-vars) + "Return a temporary buffer called NAME. +The buffer also uses the minor-mode `scion-popup-buffer-mode'. +Pressing `q' in the buffer will restore the window configuration +to the way it is when the buffer was created, i.e. when this +function was called." + (when (and (get-buffer name) (kill-buffer (get-buffer name)))) + (with-current-buffer (get-buffer-create name) + (set-syntax-table lisp-mode-syntax-table) + (prog1 (pop-to-buffer (current-buffer)) + (scion-init-popup-buffer buffer-vars)))) + +(defun scion-init-popup-buffer (buffer-vars) + (scion-popup-buffer-mode 1) + (setq scion-popup-buffer-saved-fingerprint + (scion-current-emacs-snapshot-fingerprint)) + (multiple-value-setq (scion-buffer-package + scion-buffer-connection + scion-popup-buffer-saved-emacs-snapshot) + buffer-vars)) + +(define-minor-mode scion-popup-buffer-mode + "Mode for displaying read only stuff" + nil + (" Scion-Tmp" scion-modeline-string) + '(("q" . scion-popup-buffer-quit-function) + ;("\C-c\C-z" . scion-switch-to-output-buffer) + ;; ("\M-." . scion-edit-definition) + )) + +(make-variable-buffer-local + (defvar scion-popup-buffer-quit-function 'scion-popup-buffer-quit + "The function that is used to quit a temporary popup buffer.")) + +(defun scion-popup-buffer-quit-function (&optional kill-buffer-p) + "Wrapper to invoke the value of `scion-popup-buffer-quit-function'." + (interactive) + (funcall scion-popup-buffer-quit-function kill-buffer-p)) + +;; Interface +(defun scion-popup-buffer-quit (&optional kill-buffer-p) + "Get rid of the current (temp) buffer without asking. +Restore the window configuration unless it was changed since we +last activated the buffer." + (interactive) + (let ((buffer (current-buffer))) + (when (scion-popup-buffer-snapshot-unchanged-p) + (scion-popup-buffer-restore-snapshot)) + (with-current-buffer buffer + (setq scion-popup-buffer-saved-emacs-snapshot nil) ; buffer-local var! + (cond (kill-buffer-p (kill-buffer nil)) + (t (bury-buffer)))))) + +(defun scion-popup-buffer-snapshot-unchanged-p () + (equalp (scion-current-emacs-snapshot-fingerprint) + scion-popup-buffer-saved-fingerprint)) + +(defun scion-popup-buffer-restore-snapshot () + (let ((snapshot scion-popup-buffer-saved-emacs-snapshot)) + (assert snapshot) + (scion-set-emacs-snapshot snapshot))) + + +;;;;; Event logging to *scion-events* +;;; +;;; The *scion-events* buffer logs all protocol messages for debugging +;;; purposes. Optionally you can enable outline-mode in that buffer, +;;; which is convenient but slows things down significantly. + +(defvar scion-log-events t + "*Log protocol events to the *scion-events* buffer.") + +(defvar scion-outline-mode-in-events-buffer nil + "*Non-nil means use outline-mode in *scion-events*.") + +(defvar scion-event-buffer-name "*scion-events*" + "The name of the scion event buffer.") + +(defun scion-log-event (event) + "Record the fact that EVENT occurred." + (when scion-log-events + (with-current-buffer (scion-events-buffer) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (save-excursion + (scion-pprint-event event (current-buffer))) + (when (and (boundp 'outline-minor-mode) + outline-minor-mode) + (hide-entry)) + (goto-char (point-max))))) + +(defun scion-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + (pp event buffer))) + +(defun scion-events-buffer () + (or (get-buffer scion-event-buffer-name) + (let ((buffer (get-buffer-create scion-event-buffer-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'outline-regexp) "^(") + (set (make-local-variable 'comment-start) ";") + (set (make-local-variable 'comment-end) "") + (when scion-outline-mode-in-events-buffer + (outline-minor-mode))) + buffer))) + +;;;;; Buffer related + +(defun scion-buffer-narrowed-p (&optional buffer) + "Returns T if BUFFER (or the current buffer respectively) is narrowed." + (with-current-buffer (or buffer (current-buffer)) + (let ((beg (point-min)) + (end (point-max)) + (total (buffer-size))) + (or (/= beg 1) (/= end (1+ total)))))) + +(defun scion-column-max () + (save-excursion + (goto-char (point-min)) + (loop for column = (prog2 (end-of-line) (current-column) (forward-line)) + until (= (point) (point-max)) + maximizing column))) + +;;;--------------------------------------------------------------------------- + +;;;;; scion-mode-faces + +(defgroup scion-mode-faces nil + "Faces in scion-mode source code buffers." + :prefix "scion-" + :group 'scion-mode) + +(defun scion-underline-color (color) + "Return a legal value for the :underline face attribute based on COLOR." + ;; In XEmacs the :underline attribute can only be a boolean. + ;; In GNU it can be the name of a colour. + (if (featurep 'xemacs) + (if color t nil) + color)) + +(defface scion-error-face + `((((class color) (background light)) + (:underline ,(scion-underline-color "red"))) + (((class color) (background dark)) + (:underline ,(scion-underline-color "red"))) + (t (:underline t))) + "Face for errors from the compiler." + :group 'scion-mode-faces) + +(defface scion-warning-face + `((((class color) (background light)) + (:underline ,(scion-underline-color "orange"))) + (((class color) (background dark)) + (:underline ,(scion-underline-color "coral"))) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'scion-mode-faces) + +(defun scion-face-inheritance-possible-p () + "Return true if the :inherit face attribute is supported." + (assq :inherit custom-face-attributes)) + +(defface scion-highlight-face + (if (scion-face-inheritance-possible-p) + '((t (:inherit highlight :underline nil))) + '((((class color) (background light)) + (:background "darkseagreen2")) + (((class color) (background dark)) + (:background "darkolivegreen")) + (t (:inverse-video t)))) + "Face for compiler notes while selected." + :group 'scion-mode-faces) + +;;;--------------------------------------------------------------------------- +;;;; Overlays for compiler messages and other things + +(defstruct (scion-compilation-result + (:type list) + (:conc-name scion-compilation-result.) + (:constructor nil) + (:copier nil)) + tag successp notes duration) + + +(defvar scion-project-root-dir nil + "The root directory of the current project. + +This is used, for example, to translate relative path names from +error messages into absolute path names.") + +(defun scion-compiler-notes () + "Return all compiler notes, warnings, and errors." + (scion-compilation-result.notes scion-last-compilation-result)) + +;;; TODO: notes should be sorted by filename (using a hashtable) + +(defun scion-highlight-notes (notes &optional buffer) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (scion-compiler-notes))) + (with-temp-message (if (not buffer) "Highlighting notes..." nil) + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (scion-remove-old-overlays buffer) + (let ((buffers (if buffer + (list buffer) + (scion-filter-buffers (lambda () scion-mode))))) + (loop for b in buffers do + (with-current-buffer b + (save-excursion + (save-restriction + (widen) + (loop for note in (scion-notes-for-buffer notes b) do + (scion-overlay-note note b)))))))))) + nil) + +(defun scion-notes-for-buffer (notes buffer) + "Return only the notes that relate to BUFFER." + (let ((fname (buffer-file-name buffer))) + (if fname + (gethash fname notes nil) + nil))) + +(defun scion-remove-old-overlays (&optional buffer) + "Delete the existing Scion overlays in the current buffer." + (dolist (buffer (if buffer + (list buffer) + (scion-filter-buffers (lambda () scion-mode)))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) ; remove overlays within the whole buffer. + (goto-char (point-min)) + (while (not (eobp)) + (dolist (o (overlays-at (point))) + (when (overlay-get o 'scion) + (delete-overlay o))) + (goto-char (next-overlay-change (point))))))))) + +(defun scion-filter-buffers (predicate) + "Return a list of buffers where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + +(defun scion-flash-region (start end &optional timeout) + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'face 'secondary-selection) + (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay))) + +;;; The node representation +;;; +;;; See Scion server JSON instances for details. + +(defun scion-note.message (note) + (plist-get note :message)) + +(defun scion-note.filename (note) + (let ((loc (scion-note.location note))) + (plist-get loc :file))) + +(defun scion-note.line (note) + (when-let (region (plist-get (scion-note.location note) :region)) + (destructuring-bind (sl sc el ec) region + sl))) + +(defun scion-note.col (note) + (when-let (region (plist-get (scion-note.location note) :region)) + (destructuring-bind (sl sc el ec) region + sc))) + +(defun scion-note.region (note buffer) + (when-let (region (plist-get (scion-note.location note) :region)) + (let ((filename (scion-note.filename note))) + (when (equal (buffer-file-name buffer) filename) + (destructuring-bind (sl sc el ec) region + (scion-location-to-region sl sc el ec buffer)))))) + +(defun scion-note.severity (note) + (let ((k (plist-get note :kind))) + (cond + ((string= k "warning") :warning) + ((string= k "error") :error) + (t :other)))) + +(defun scion-note.location (note) + (plist-get note :location)) + +(defun scion-location-to-region (start-line start-col end-line end-col + &optional buffer) + "Translate a Haskell (line,col) region into an Emacs region. + +TODO: Fix up locations if buffer has been modified in between." + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (save-restriction + (widen) ; look in whole buffer + (goto-char 1) + (forward-line (1- start-line)) + (move-to-column start-col) + (let ((start (point))) + (forward-line (- end-line start-line)) + (move-to-column end-col) + (let ((end (point))) + (cond + ((< end start) + (list end start)) + ((= start end) ; span would be invisible + (list start (progn ; a bit of a hack, but well + (goto-char start) + (forward-word) + (point)))) + (t + (list start end))))))))) + +(defun scion-canonicalise-note-location (note) + "Translate the note's location into absolute path names. +Modifies input note." + ;; This should be done on the server now. + note) + +;;;;; Adding a single compiler note + +(defun scion-overlay-note (note buffer) + "Add a compiler note to the buffer as an overlay." + (multiple-value-bind (start end) (scion-note.region note buffer) + (when start + (goto-char start) + (let ((severity (scion-note.severity note)) + (message (scion-note.message note))) + (scion-create-note-overlay note start end severity message))))) + +(defun scion-create-note-overlay (note start end severity message) + "Create an overlay representing a compiler note. +The overlay has several properties: + FACE - to underline the relevant text. + SEVERITY - for future reference, :NOTE, :STYLE-WARNING, :WARNING, or :ERROR. + MOUSE-FACE - highlight the note when the mouse passes over. + HELP-ECHO - a string describing the note, both for future reference + and for display as a tooltip (due to the special + property name)." + (let ((overlay (make-overlay start end))) + (flet ((putp (name value) (overlay-put overlay name value))) + (putp 'scion note) + (putp 'face (scion-severity-face severity)) + ;(putp 'severity severity) + (unless (scion-emacs-20-p) + (putp 'mouse-face 'highlight)) + (putp 'help-echo message) + overlay))) + +(defun scion-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (ecase severity + (:error 'scion-error-face) + (:warning 'scion-warning-face))) + +(defun scion-make-notes (notes0 &optional keep-existing-notes) + (let ((notes (if keep-existing-notes + (scion-compiler-notes) + (scion-makehash #'equal)))) + (loop for note in notes0 + do (progn + (scion-canonicalise-note-location note) + (let* ((fname (scion-note.filename note)) + (old-notes (gethash fname notes))) + (puthash fname (cons note old-notes) notes)))) + notes)) + +(defun scion-next-note-in-buffer () + "Goto next note in current buffer." + (interactive) + (scion-next-note-in-buffer-aux nil)) + +(defun scion-previous-note-in-buffer () + "Goto previous note in current buffer if any." + (interactive) + (scion-next-note-in-buffer-aux t)) + +(defun scion-next-note-in-buffer-aux (&optional backwards) + (flet ((my-next-overlay-change (p) (if backwards + (previous-overlay-change p) + (next-overlay-change p))) + (my-eobp () (if backwards (bobp) (eobp)))) + (let ((note0 (scion-note-at-point))) + (let ((next-note + (save-excursion + (block found-sth + (while (not (my-eobp)) + (dolist (o (overlays-at (point))) + (let ((note (overlay-get o 'scion))) + (when (and note (not (equal note note0))) + (return-from found-sth (cons (point) note))))) + (goto-char (my-next-overlay-change (point)))))))) + (if next-note + (progn + (goto-char (car next-note)) + (message "%s" (scion-note.message (cdr next-note)))) + (message "No more notes in this buffer.")))))) + +(defun scion-note-at-point (&optional pt) + (block nil + (let ((pt (or pt (point)))) + (dolist (o (overlays-at pt)) + (let ((note (overlay-get o 'scion))) + (when note + (return note))))))) + +;;;--------------------------------------------------------------------------- +;;; The buffer that shows the compiler notes + +(defvar scion-compiler-notes-mode-map) + +(define-derived-mode scion-compiler-notes-mode fundamental-mode + "Compiler-Notes" + "\\\ +\\{scion-compiler-notes-mode-map} +\\{scion-popup-buffer-mode-map} +" + ;(scion-set-truncate-lines) + ) + +(scion-define-keys scion-compiler-notes-mode-map + ((kbd "RET") 'scion-compiler-notes-default-action-or-show-details) + ([return] 'scion-compiler-notes-default-action-or-show-details) + ([mouse-2] 'scion-compiler-notes-default-action-or-show-details/mouse) + ((kbd "q") 'scion-popup-buffer-quit-function)) + +(defun scion-compiler-notes-default-action-or-show-details/mouse (event) + "Invoke the action pointed at by the mouse, or show details." + (interactive "e") + (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) + 'scion-compiler-notes-default-action))) + (if fn (funcall fn) (scion-compiler-notes-show-details)))))) + +(defun scion-compiler-notes-default-action-or-show-details () + "Invoke the action at point, or show details." + (interactive) + (let ((fn (get-text-property (point) 'scion-compiler-notes-default-action))) + (if fn (funcall fn) (scion-compiler-notes-show-details)))) + +(defun scion-compiler-notes-show-details () + (interactive) + (let* ((tree (scion-tree-at-point)) + (note (plist-get (scion-tree.plist tree) 'note)) + (inhibit-read-only t)) + (cond ((not (scion-tree-leaf-p tree)) + (scion-tree-toggle tree)) + (t + (scion-show-source-location note t))))) + +(defun scion-show-source-location (note &optional no-highlight-p) + (save-selected-window ; show the location, but don't hijack focus. + (scion-goto-source-location note) + ;(unless no-highlight-p (sldb-highlight-sexp)) + ;(scion-show-buffer-position (point)) + )) + +(defun scion-goto-source-location (note) + (let ((file (scion-note.filename note))) + (when file + (let ((buff (find-buffer-visiting file))) + (if buff + (let ((buff-window (get-buffer-window buff))) + (if buff-window + (select-window buff-window) + (display-buffer buff))) + (progn + (find-file-other-window file) + (setq buff (find-buffer-visiting file)))) + (goto-line (scion-note.line note)) + (move-to-column (scion-note.col note)) + (let ((r (scion-note.region note buff))) + (with-current-buffer buff + (scion-flash-region (car r) (cadr r) 0.5))))))) + +(defun scion-list-compiler-notes (notes &optional no-popup) + "Show the compiler notes NOTES in tree view. + +If NO-POPUP is non-NIL, only show the buffer if it is already visible." + (interactive (list (scion-compiler-notes))) + (labels ((fill-out-buffer () + (erase-buffer) + (scion-compiler-notes-mode) + (when (null notes) + (insert "[no notes]")) + (let ((collapsed-p)) + (dolist (tree (scion-compiler-notes-to-tree notes)) + (when (scion-tree.collapsed-p tree) (setf collapsed-p t)) + (scion-tree-insert tree "") + (insert "\n")) + (goto-char (point-min))))) + (with-temp-message "Preparing compiler note tree..." + (if no-popup + (with-current-buffer (get-buffer-create "*SCION Compiler-Notes*") + (setq buffer-read-only nil) + (fill-out-buffer) + (setq buffer-read-only t)) + (scion-with-popup-buffer ("*SCION Compiler-Notes*") + (fill-out-buffer)))))) + +(defvar scion-tree-printer 'scion-tree-default-printer) + +(defun scion-compiler-notes-to-tree (notes) + (let ((warns nil) + (errs nil)) + (maphash (lambda (file notes) + (loop for note in notes + do (case (scion-note.severity note) + (:warning (setq warns (cons note warns))) + (:error (setq errs (cons note errs)))))) + notes) + (let ((alist (list (cons :error errs) + (cons :warning warns)))) + (loop for (severity . sev-notes) in alist + collect (scion-tree-for-severity severity sev-notes nil))))) + +(defun scion-tree-for-severity (severity notes collapsed-p) + (make-scion-tree :item (format "%s (%d)" + (case severity + (:warning "Warnings") + (:error "Errors") + (t (print severity))) + (length notes)) + :kids (mapcar #'scion-tree-for-note notes) + :collapsed-p collapsed-p)) + +(defun scion-tree-for-note (note) + (make-scion-tree :item (format "%s:\n%s" + (scion-note.filename note) + (scion-note.message note)) + :plist (list 'note note) + :print-fn scion-tree-printer)) + + +;;;--------------------------------------------------------------------------- + +(defmacro* scion-handling-failure ((res-var) &body body) + (let ((x (gensym)) + (val (gensym))) + `(lambda (,x) + (destructure-case ,x + ((:ok ,val) + (let ((,res-var ,val)) + ,@body)) + ((:error ,val) + (message "Remote command failed: %s" ,val) + nil))))) + +(put 'scion-handling-failure 'lisp-indent-function 1) + +(defun scion-cabal-root-dir (&optional start-directory) + "Look for a .cabal file from START-DIRECTORY upwards." + (let ((dir (or start-directory + default-directory + (error "No start directory given")))) + (if (car (directory-files dir t ".cabal$")) + dir + (let ((next-dir (file-name-directory (directory-file-name + (file-truename dir))))) + (unless (or (equal dir next-dir) (null next-dir)) + (scion-cabal-root-dir next-dir)))))) + +(defun scion-cabal-file (dir) + "Return the only Cabal file in the given directory. +Returns NIL if the directory does not contain such file, and +signals an error if multiple files are present." + (let ((cabal-files (directory-files dir t ".cabal$"))) + (if (car cabal-files) + (if (cadr cabal-files) + (error "Multiple .cabal files in directory: %s" dir) + (car cabal-files)) + nil))) + +(defun scion-open-cabal-project (root-dir rel-dist-dir extra-args) + "Load project metadata from a Cabal description. + +This does not load the project but merely loads the metadata. + +ROOT-DIR is the project root directory \(the directory +which contains the .cabal file\). + +REL-DIST-DIR is the directory name relative to the project root. +By default Scion uses \".scion-dist\" to avoid interfering with +command line tools. + +EXTRA-ARGS is a string of command line flags." + (interactive (scion-interactive-configure-args)) + (lexical-let ((root-dir root-dir)) + (scion-eval-async `(open-cabal-project :root-dir ,(expand-file-name root-dir) + :dist-dir ,rel-dist-dir + :extra-args ,(split-string extra-args)) + (lambda (x) + (setq scion-project-root-dir root-dir) + (message (format "Cabal project loaded: %s" x))))) + (message "Loading Cabal project.")) + +(defun scion-interactive-configure-args () + (let ((root (scion-cabal-root-dir))) + (list (funcall (if (fboundp 'read-directory-name) + 'read-directory-name + 'read-file-name) + "Directory: " root root) + (read-from-minibuffer "Dist directory: " ".dist-scion") + (read-from-minibuffer "Configure Flags: " "")))) + +(defun scion-configure-cabal-project (root-dir rel-dist-dir extra-args) + "Configure/Reconfigure a Cabal project. + +This does not load the project but merely loads the metadata and +pre-processes files. + +ROOT-DIR is the project root directory \(the directory +which contains the .cabal file\). + +REL-DIST-DIR is the directory name relative to the project root. +By default Scion uses \".scion-dist\" to avoid interfering with +command line tools. + +EXTRA-ARGS is a string of command line flags." + (interactive (scion-interactive-configure-args)) + (lexical-let ((root-dir root-dir)) + (scion-eval-async `(configure-cabal-project :root-dir ,(expand-file-name root-dir) + :dist-dir ,rel-dist-dir + :extra-args ,(split-string extra-args)) + (lambda (x) + (setq scion-project-root-dir root-dir) + (message (format "Cabal project loaded: %s" x)))))) + +(defun scion-load-library () + "Load the library of the current cabal project. + +Sets the GHC flags for the library from the current Cabal project and loads it." + (interactive) + (message "Loading library...") + (scion-eval-async `(load-component :component (:library nil)) + (lambda (result) + (scion-report-compilation-result result)))) + +(defun scion-count-notes (notes) + (let ((warns 0) + (errs 0)) + (loop for n in notes + when (eq (scion-note.severity n) :warning) do (incf warns) + when (eq (scion-note.severity n) :error) do (incf errs)) + (list warns errs))) + + +(defun scion-report-compilation-result (result &optional buf) + (destructuring-bind (&key succeeded notes duration) result + (let ((tag 'compilation-result) + (successp (if (eq succeeded json-false) nil t))) + (multiple-value-bind (nwarnings nerrors) + (scion-count-notes notes) + (let ((notes (scion-make-notes notes))) + (setq scion-last-compilation-result + (list tag successp notes duration)) + (scion-highlight-notes notes buf) + (if (not buf) + (progn + (scion-show-note-counts successp nwarnings nerrors duration) + (when (< 0 (+ nwarnings nerrors)) + (scion-list-compiler-notes notes))) + (scion-update-compilater-notes-buffer)) + (scion-report-status (format ":%d/%d" nerrors nwarnings)) + nil))))) + +(defun scion-update-compilater-notes-buffer () + "Update the contents of the compilation notes buffer if it is open somewhere." + (interactive) + ;; XXX: background typechecking currently does not keep notes from + ;; other files + (when (get-buffer "*SCION Compiler-Notes*") + (scion-list-compiler-notes (scion-compiler-notes) t))) + +;; ((:ok warns) +;; (setq scion-last-compilation-result +;; (list 42 (mapc #'scion-canonicalise-note-location +;; warns) t nil)) +;; (scion-highlight-notes warns) +;; (scion-show-note-counts t warns nil)) +;; ((:error errs warns) +;; (let ((notes (mapc #'scion-canonicalise-note-location +;; (append errs warns)))) +;; (setq scion-last-compilation-result +;; (list 42 notes nil nil)) +;; (scion-highlight-notes notes)) +;; (scion-show-note-counts nil warns errs)))) + +(defun scion-show-note-counts (successp nwarnings nerrors secs) + (message "Compilation %s: %s%s%s" + (if successp "finished" "FAILED") + (scion-note-count-string "error" nerrors) + (scion-note-count-string "warning" nwarnings) + (if secs (format "[%.2f secs]" secs) ""))) + +(defun scion-note-count-string (category count &optional suppress-if-zero) + (cond ((and (zerop count) suppress-if-zero) + "") + (t (format "%2d %s%s " count category (if (= count 1) "" "s"))))) + +(defun scion-supported-languages () + ;; TODO: cache result + (scion-eval '(list-supported-languages))) + +(defun haskell-insert-language (lang) + "Insert a LANGUAGE pragma at the top of the file." + ;; TODO: automatically jump to or insert LANGUAGE pragma + (interactive + (let ((langs (scion-supported-languages))) + (list (scion-completing-read "Language: " langs)))) + (save-excursion + (goto-char (point-min)) + (insert "{-# LANGUAGE " lang " #-}\n")) + (message "Added language %s" lang)) + +(defun scion-supported-pragmas () + ;; TODO: cache result + (scion-eval '(list-supported-pragmas))) + +(defun haskell-insert-pragma (pragma) + "Insert a pragma at the current point." + (interactive (let ((choices (scion-supported-pragmas))) + ;; standard completing-read cannot even deal properly + ;; with upper-case words. + (list (scion-completing-read "Pragma: " choices)))) + (insert "{-# " (upcase pragma) " #-}") + (backward-char 4)) + +(defun scion-supported-flags () + ;; TODO: cache result + (scion-eval '(list-supported-flags))) + +(defun haskell-insert-flag (flag) + "Insert a command line flag at the curretn point." + ;; TODO: automatically insert/add OPTIONS pragma + (interactive + (let ((flags (scion-supported-flags))) + (list (scion-completing-read "Flag: " flags)))) + (insert flag)) + +(defun scion-set-command-line-flag (flag) + (interactive "sCommand Line Flag: ") + (scion-eval `(add-command-line-flag :flag ,flag))) + +(defun scion-exposed-modules () + (scion-eval '(list-exposed-modules))) + +(defun haskell-insert-module-name (mod) + "Insert a module name at the current point. + +When called interactively tries to complete to modules of all +installed packages (However, not of the current project.)" + (interactive + (let ((mods (scion-exposed-modules))) + (list (scion-completing-read "Module: " mods)))) + (insert mod)) + +(define-key scion-mode-map "\C-cil" 'haskell-insert-language) +(define-key scion-mode-map "\C-cip" 'haskell-insert-pragma) +(define-key scion-mode-map "\C-cif" 'haskell-insert-flag) +(define-key scion-mode-map "\C-cim" 'haskell-insert-module-name) + +(define-key scion-mode-map "\C-c\C-o" 'scion-open-cabal-project) +(define-key scion-mode-map "\C-c\C-x\C-l" 'scion-load) +(define-key scion-mode-map "\M-n" 'scion-next-note-in-buffer) +(define-key scion-mode-map "\M-p" 'scion-previous-note-in-buffer) +(define-key scion-mode-map "\C-c\C-n" 'scion-list-compiler-notes) +(define-key scion-mode-map [(control ?c) (control ?\.)] 'scion-goto-definition) + +(defun haskell-insert-module-header (module-name &optional + author + email) + (interactive (list (read-from-minibuffer "Module name: ") + (read-from-minibuffer "Author name: " user-full-name) + (read-from-minibuffer "Author email: " user-mail-address))) + (insert "-- |" + "\n-- Module : " module-name + "\n-- Copyright : (c) " author " " (substring (current-time-string) -4) + "\n-- License : BSD-style\n--" ;; TODO: extract from .cabal file + "\n-- Maintainer : " email + "\n-- Stability : experimental" + "\n-- Portability : portable\n--\n")) + +(defun scion-set-ghc-verbosity (n) + (interactive "nLevel [0-5]: ") + (scion-eval `(set-ghc-verbosity :level ,n))) + +;;;--------------------------------------------------------------------------- + +(defun scion-emacs-20-p () + (and (not (featurep 'xemacs)) + (= emacs-major-version 20))) + +;;;--------------------------------------------------------------------------- + +(defalias 'scion-float-time + (if (fboundp 'float-time) + 'float-time + (if (featurep 'xemacs) + (lambda () + (multiple-value-bind (s0 s1 s2) (current-time) + (+ (* (float (ash 1 16)) s0) (float s1) (* 0.0000001 s2))))))) + +;;;--------------------------------------------------------------------------- +;;;; Flycheck (background type checking) + +(make-variable-buffer-local + (defvar scion-flycheck-timer nil + "The timer for starting background compilation")) + +(make-variable-buffer-local +;; TODO: hm, maybe this should be global (due to single-threadedness) +(defvar scion-flycheck-is-running nil + "If t, the (single-threaded) background typechecker is running.")) + +(make-variable-buffer-local + (defvar scion-flycheck-last-change-time nil + "Time of last buffer change.")) + +(defcustom scion-flycheck-no-changes-timeout 2.0 + "Time to wait after last change before starting compilation." + :group 'scion + :type 'number) + +(defun scion-turn-on-flycheck () + "Turn on flycheck in current buffer" + (interactive) + (if (not scion-mode) + (message "Background typechecking only supported inside scion-mode.") + (add-hook 'after-change-functions 'scion-flycheck-after-change-function nil t) + (add-hook 'kill-buffer-hook 'scion-kill-buffer-hook nil t) + + (scion-flycheck-on-save 1) + + ;; TODO: update modeline + + (setq scion-flycheck-timer + (run-at-time nil 1 'scion-flycheck-on-timer-event (current-buffer))))) + +(defun scion-turn-off-flycheck () + (interactive) + + (remove-hook 'after-change-functions 'scion-flycheck-after-change-function t) + (remove-hook 'kill-buffer-hook 'scion-kill-buffer-hook t) + + (scion-flycheck-on-save -1) + ;; TODO: delete overlays? + (when scion-flycheck-timer + (cancel-timer scion-flycheck-timer) + (setq scion-flycheck-timer nil)) + (setq scion-flycheck-is-running nil)) + +(make-variable-buffer-local + (defvar scion-flycheck-on-save-state nil + "Non-nil iff type checking should be performed when the file is saved.")) + +(defun scion-flycheck-on-save (&optional arg) + "Toggle type checking the current file when it is saved. + +A positive argument forces type checking to be on, a negative +forces it to be off. NIL toggles the current state." + (interactive "P") + (if (not scion-mode) + (message "Background typechecking only supported inside scion-mode.") + (let ((new-state + (cond + ((null arg) (not scion-flycheck-on-save-state)) + ((consp arg) nil) + ((numberp arg) (>= arg 0))))) + (when (not (eq (not new-state) + (not scion-flycheck-on-save-state))) + (if new-state + (add-hook 'after-save-hook 'scion-after-save-hook nil t) + (remove-hook 'after-save-hook 'scion-after-save-hook t)) + + (setq scion-flycheck-on-save-state new-state) + (message (format "Typecheck-on-save has been turned %s" + (if new-state "ON" "OFF"))))))) + +(defun scion-flycheck-after-change-function (start stop len) + ;; TODO: be more smarter about which parts need updating. + ;; + ;; flymake (optionally) supports syntax/typechecking if a newline was inserted + (setq scion-flycheck-last-change-time (scion-float-time))) + +(defun scion-after-save-hook () + (when (and scion-mode + (not scion-flycheck-is-running)) + (setq scion-flycheck-last-change-time nil) + (scion-flycheck-start-check))) + +(defun scion-kill-buffer-hook () + (when scion-flycheck-timer + (cancel-timer scion-flycheck-timer) + (setq scion-flycheck-timer nil))) + +(defun scion-flycheck-on-timer-event (buffer) + "Start a syntax check for buffer BUFFER if necessary." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (and (not scion-flycheck-is-running) + scion-flycheck-last-change-time + (> (- (scion-float-time) scion-flycheck-last-change-time) + scion-flycheck-no-changes-timeout)) + (setq scion-flycheck-last-change-time nil) + ;; HACK: prevent scion-after-save-hook from running a typecheck + (setq scion-flycheck-is-running t) + (save-buffer buffer) + (scion-flycheck-start-check))))) + +(defun scion-flycheck-start-check () + (interactive) + (when (scion-connected-p) + (let ((filename (buffer-file-name))) + (setq scion-flycheck-is-running t) + (scion-report-status ":-/-") + (scion-eval-async `(background-typecheck-file :file ,filename) + (lambda (result) + (setq scion-flycheck-is-running nil) + (destructuring-bind (ok comp-rslt) result + (if (not (eq ok :json-false)) + (scion-report-compilation-result comp-rslt + (current-buffer)) + (scion-report-status "[?]"))) + nil))))) + +(make-variable-buffer-local + (defvar scion-mode-line-notes nil)) + +(defun scion-report-status (status) + (let ((stats-str (concat " Scion" status))) + (setq scion-mode-line stats-str) + (force-mode-line-update))) + +;;;--------------------------------------------------------------------------- +;;;; To be sorted + +(defun scion-thing-at-point () + (interactive) + (let ((filename (buffer-file-name)) + (line (line-number-at-pos)) + (col (current-column))) + (message + (let ((rslt (scion-eval `(thing-at-point :file ,filename + :line ,line + :column ,col)))) + (funcall (lambda (r) (format "%s" (cadr r))) rslt))))) + +(defun scion-dump-sources () + (interactive) + (scion-eval '(dump-sources))) + +(defun scion-dump-defined-names () + (interactive) + (scion-eval '(dump-defined-names))) + +(define-key scion-mode-map "\C-c\C-t" 'scion-thing-at-point) + +(provide 'scion) + +(defun scion-load (comp) + "Load current file or Cabal project. + +If the file is within a Cabal project, prompts the user which +component to load, or whether only the current file should be +loaded." + (interactive (list (scion-select-component))) + (cond + ((null comp) + (error "Invalid component")) + + ((scion-cabal-component-p comp) + (let* ((curr-cabal-file (scion-eval '(current-cabal-file))) + ;; (current-component (scion-eval '(current-component)) + (root-dir (scion-cabal-root-dir)) + (new-cabal-file (ignore-errors (scion-cabal-file root-dir)))) + ;; if we have a component + (assert (not (null new-cabal-file))) + (if (equal curr-cabal-file new-cabal-file) + ;; Same Cabal project, just load the component + (scion-load-component% comp) + + ;; Different Cabal project, we must configure it first. + (let ((rel-dist-dir (read-from-minibuffer "Dist directory: " ".dist-scion")) + (extra-args (read-from-minibuffer "Configure Flags: " ""))) + (lexical-let ((root-dir root-dir) + (comp comp)) + (scion-eval-async `(open-cabal-project :root-dir ,(expand-file-name root-dir) + :dist-dir ,rel-dist-dir + :extra-args ,extra-args) + (lambda (x) + (setq scion-project-root-dir root-dir) + (message (format "Cabal project loaded: %s" x)) + (scion-load-component% comp)))))))) + + ((eq (car comp) :file) + (scion-load-component% comp)))) + +(defun scion-load-component% (comp) + (message "Loading %s..." (scion-format-component comp)) + (scion-eval-async `(load :component ,comp) + (lambda (result) + (scion-report-compilation-result result)))) + +(defun scion-cabal-component-p (comp) + (cond + ((eq (car comp) :library) + t) + ((and (consp comp) + (eq (car comp) + :executable)) + t) + (t + nil))) + +(defun scion-select-component () + (let* ((cabal-dir (scion-cabal-root-dir)) + (cabal-file (ignore-errors (scion-cabal-file cabal-dir))) + (cabal-components (ignore-errors (scion-cabal-components cabal-file))) + (options (nconc cabal-components + `((:file ,(buffer-file-name)))))) + (if (null (cdr options)) + (car options) + ;; TODO: abstract this kludge into `scion-completing-read` + (let* ((disp->comp (scion-makehash #'equal)) + (opts (loop for c in options + do (puthash (scion-format-component c) c disp->comp) + collect (scion-format-component c)))) + (gethash (scion-completing-read "Load Component: " + opts + nil + t) + disp->comp))))) + +(defun scion-format-component (comp) + (cond + ((eq (car comp) :library) + "Library") + ((eq (car comp) :executable) + (format "Executable %s" (cadr comp))) + ((eq (car comp) :file) + (format "File %s" (cadr comp))) + (t + (format "%s" comp)))) + + +(defun scion-cabal-components (cabal-file) + "Return list of components in CABAL-FILE. +The result is a list where each element is either the symbol +LIBRARY or (EXECUTABLE )." + (let ((comps (scion-eval `(list-cabal-components :cabal-file ,cabal-file)))) + comps)) + +(defun scion-get-verbosity () + "Return the verbosity of the Scion server." + (interactive) + (scion-eval '(get-verbosity))) + +(defun scion-set-verbosity (v) + (interactive "nVerbosity[0-3]: ") + (scion-eval `(set-verbosity :level ,v))) + +(defun scion-defined-names () + (scion-eval '(defined-names))) + +(defun scion-ident-at-point () + ;; TODO: recognise proper haskell symbols + (let ((s (thing-at-point 'symbol))) + (if s + (substring-no-properties s) + nil))) + +(defun scion-goto-definition (name) + (interactive + (let ((names (scion-defined-names)) + (dflt (scion-ident-at-point))) + (if (find dflt names :test #'string=) + (list dflt) + (list (scion-completing-read "Goto Definition: " names nil nil dflt))))) + (let ((sites (scion-eval `(name-definitions :name ,name)))) + (if (not sites) + (message "No definition site known") + (let* ((loc (car sites)) ;; XXX: deal with multiple locations + (dummy-note (list :kind "warning" :location loc :message "definition"))) + (scion-goto-source-location dummy-note))))) + +;; Local Variables: +;; outline-regexp: ";;;;+" +;; End: +;; indent-tabs-mode: nil diff --git a/lib/Scion.hs b/lib/Scion.hs new file mode 100644 --- /dev/null +++ b/lib/Scion.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Scion +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Scion is a library on top of the GHC API to provide IDE-like functionality. +-- +module Scion + ( ScionM + , liftIO, MonadIO + , module Scion -- re-export full module at least for now + , module Scion.Session + , module Scion.Utils + , module Scion.Configure + ) where + +import Scion.Types +import Scion.Session +import Scion.Configure +import Scion.Utils + +import GHC +import FastString ( fsLit ) +import Outputable ( printSDoc, defaultErrStyle, ppr, (<+>), text ) +import GHC.Paths ( libdir ) + +import Control.Monad ( forM_ ) + +-- | Run the 'ScionM' monad. +runScion :: ScionM a -> IO a +runScion m = do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + r <- liftIO $ mkSessionState dflags + setSessionDynFlags (initialScionDynFlags dflags) + unScionM m r + +-- | Run the session with the given static flags. +-- +-- Static flags cannot be changed during a session and can only be set once +-- per /process/. That is, any session running in the same process +-- (i.e. program) must not attempt to set the static flags again. +-- +-- Which flags are static flags depends on the version of GHC. +runScion' :: [String] -> ScionM a -> IO a +runScion' static_flags act = do + let fname = fsLit "" + lflags = [ L (mkSrcSpan (mkSrcLoc fname line 0) (mkSrcLoc fname line (length s))) s + | (s,line) <- zip static_flags [1..] ] + (_leftovers, warnings) <- parseStaticFlags lflags + forM_ warnings $ \(L region msg) -> + printSDoc (ppr region <+> text msg) defaultErrStyle + runScion act diff --git a/lib/Scion/Configure.hs b/lib/Scion/Configure.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Configure.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +-- | +-- Module : Scion.Configure +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@googlemail.com +-- Stability : experimental +-- Portability : portable +-- +module Scion.Configure where + +import Scion.Types +import Scion.Session + +import GHC hiding ( load ) +import DynFlags ( dopt_set ) +import GHC.Paths ( ghc, ghc_pkg ) +import Exception +import Data.Typeable +import Outputable + +import System.Directory +import System.FilePath +import System.IO ( openTempFile, hPutStr, hClose ) +import Control.Monad +import Control.Exception ( IOException ) + +import Distribution.Simple.Configure +import Distribution.PackageDescription.Parse ( readPackageDescription ) +import qualified Distribution.Verbosity as V ( normal, deafening ) +import Distribution.Simple.Program ( defaultProgramConfiguration, userSpecifyPaths ) +import Distribution.Simple.Setup ( defaultConfigFlags, ConfigFlags(..), Flag(..) ) + +------------------------------------------------------------------------------ + +-- | Open or configure a Cabal project using the Cabal library. +-- +-- Tries to open an existing Cabal project or configures it if opening +-- failed. +-- +-- Throws: +-- +-- * 'CannotOpenCabalProject' if configuration failed. +-- +openOrConfigureCabalProject :: + FilePath -- ^ The project root. (Where the .cabal file resides) + -> FilePath -- ^ dist dir, i.e., directory where to put generated files. + -> [String] -- ^ command line arguments to "configure". + -> ScionM () +openOrConfigureCabalProject root_dir dist_dir extra_args = + openCabalProject root_dir dist_dir + `gcatch` (\(_ :: CannotOpenCabalProject) -> + configureCabalProject root_dir dist_dir extra_args) + +-- | Configure a Cabal project using the Cabal library. +-- +-- This is roughly equivalent to calling "./Setup configure" on the command +-- line. The difference is that this makes sure to use the same version of +-- Cabal and the GHC API that Scion was built against. This is important to +-- avoid compatibility problems. +-- +-- If configuration succeeded, sets it as the current project. +-- +-- TODO: Figure out a way to report more helpful error messages. +-- +-- Throws: +-- +-- * 'CannotOpenCabalProject' if configuration failed. +-- +configureCabalProject :: + FilePath -- ^ The project root. (Where the .cabal file resides) + -> FilePath -- ^ dist dir, i.e., directory where to put generated files. + -> [String] -- ^ command line arguments to "configure". [XXX: currently + -- ignored!] + -> ScionM () +configureCabalProject root_dir dist_dir _extra_args = do + cabal_file <- find_cabal_file + gen_pkg_descr <- liftIO $ readPackageDescription V.normal cabal_file + let prog_conf = + userSpecifyPaths [("ghc", ghc), ("ghc-pkg", ghc_pkg)] + defaultProgramConfiguration + let config_flags = + (defaultConfigFlags prog_conf) + { configDistPref = Flag dist_dir + , configVerbosity = Flag V.deafening + , configUserInstall = Flag True + -- TODO: parse flags properly + } + setWorkingDir root_dir + ghandle (\(_ :: IOError) -> + liftIO $ throwIO $ + CannotOpenCabalProject "Failed to configure") $ do + lbi <- liftIO $ configure (Left gen_pkg_descr, (Nothing, [])) config_flags + liftIO $ writePersistBuildConfig dist_dir lbi + openCabalProject root_dir dist_dir + + where + find_cabal_file = do + fs <- liftIO $ getDirectoryContents root_dir + case [ f | f <- fs, takeExtension f == ".cabal" ] of + [f] -> return $ root_dir f + [] -> liftIO $ throwIO $ CannotOpenCabalProject "no .cabal file" + _ -> liftIO $ throwIO $ CannotOpenCabalProject "Too many .cabal files" + +-- | Something went wrong during "cabal configure". +-- +-- TODO: Add more detail. +data ConfigException = ConfigException deriving (Show, Typeable) +instance Exception ConfigException + +-- | Do the equivalent of @runghc Setup.hs @ using the GHC API. +-- +-- Instead of "runghc", this function uses the GHC API so that the correct +-- version of GHC and package database is used. +-- +-- TODO: Return exception or error message in failure case. +cabalSetupWithArgs :: + FilePath -- ^ Path to .cabal file. TODO: ATM, we only need the + -- directory + -> [String] -- ^ Command line arguments. + -> ScionM Bool +cabalSetupWithArgs cabal_file args = + ghandle (\(_ :: ConfigException) -> return False) $ do + ensureCabalFileExists + let dir = dropFileName cabal_file + (setup, delete_when_done) <- findSetup dir + liftIO $ putStrLn $ "Using setup file: " ++ setup + _mainfun <- compileMain setup + when (delete_when_done) $ + liftIO (removeFile setup) + return True + where + ensureCabalFileExists = do + ok <- liftIO (doesFileExist cabal_file) + unless ok (liftIO $ throwIO ConfigException) + + findSetup dir = do + let candidates = map ((dir "Setup.")++) ["lhs", "hs"] + existing <- mapM (liftIO . doesFileExist) candidates + case [ f | (f,ok) <- zip candidates existing, ok ] of + f:_ -> return (f, False) + [] -> liftIO $ do + ghandle (\(_ :: IOException) -> throwIO $ ConfigException) $ do + tmp_dir <- getTemporaryDirectory + (fp, hdl) <- openTempFile tmp_dir "Setup.hs" + hPutStr hdl (unlines default_cabal_setup) + hClose hdl + return (fp, True) + + default_cabal_setup = + ["#!/usr/bin/env runhaskell", + "import Distribution.Simple", + "main :: IO ()", + "main = defaultMain"] + + compileMain file = do + resetSessionState + + dflags <- getSessionDynFlags + setSessionDynFlags $ + dopt_set (dflags { hscTarget = HscInterpreted + , ghcLink = LinkInMemory + }) + Opt_ForceRecomp -- to avoid picking up Setup.{hi,o} + + t <- guessTarget file Nothing + liftIO $ putStrLn $ "target: " ++ (showSDoc $ ppr t) + setTargets [t] + load LoadAllTargets + m <- findModule (mkModuleName "Main") Nothing + env <- findModule (mkModuleName "System.Environment") Nothing + GHC.setContext [m] [env] + mainfun <- runStmt ("System.Environment.withArgs " + ++ show args + ++ "(main)") + RunToCompletion + return mainfun diff --git a/lib/Scion/Inspect.hs b/lib/Scion/Inspect.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Inspect.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE PatternGuards, CPP, + FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, + TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} +-- | +-- Module : Scion.Inspect +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Functionality to inspect Haskell programs. +-- +module Scion.Inspect + ( typeOfResult, prettyResult + , typeDecls, classDecls, familyDecls + , toplevelNames + , module Scion.Inspect.Find + , module Scion.Inspect.TypeOf + ) where + +import Scion.Utils() +import Scion.Inspect.Find +import Scion.Inspect.TypeOf + +import GHC +import Bag +import Var ( varType ) +import DataCon ( dataConUserType ) +import Type ( tidyType ) +import VarEnv ( emptyTidyEnv ) + +import Data.Generics.Biplate +import Data.Generics.UniplateStr hiding ( Str (..) ) +import qualified Data.Generics.Str as U +import Outputable +import GHC.SYB.Utils + +#ifdef DEBUG +--import FastString +import Test.QuickCheck() +import Test.GHC.Gen() +--import Debug.Trace +--import StaticFlags ( initStaticOpts ) +#endif +------------------------------------------------------------------------------ + +typeOfResult :: SearchResult Id -> Maybe Type +typeOfResult (FoundId i) = Just $ tidyType emptyTidyEnv $ varType i +typeOfResult (FoundCon _ c) = Just $ dataConUserType c +typeOfResult _ = Nothing + +prettyResult :: OutputableBndr id => SearchResult id -> SDoc +prettyResult (FoundId i) = ppr i +prettyResult (FoundName n) = ppr n +prettyResult (FoundCon _ c) = ppr c +prettyResult r = ppr r + +------------------------------------------------------------------------------ + +typeDecls :: TypecheckedMod m => m -> [LTyClDecl Name] +typeDecls m | Just (grp, _, _, _, _) <- renamedSource m = + [ t | t <- hs_tyclds grp + , isDataDecl (unLoc t) + || isTypeDecl (unLoc t) + || isSynDecl (unLoc t) ] + -- XXX: include families? +typeDecls _ = error "typeDecls: No renamer information available." + +classDecls :: RenamedSource -> [LTyClDecl Name] +classDecls (grp, _, _, _, _) = + [ t | t <- hs_tyclds grp + , isClassDecl (unLoc t) ] + +familyDecls :: RenamedSource -> [LTyClDecl Name] +familyDecls (grp, _, _, _, _) = + [ t | t <- hs_tyclds grp + , isFamilyDecl (unLoc t) ] + +toplevelNames :: TypecheckedMod m => m -> [Name] +toplevelNames m | Just (grp, _imps, _exps, _doc, _hmi) <- renamedSource m = + [ n | L _ tycld <- hs_tyclds grp + , L _ n <- tyClDeclNames tycld + ] + ++ + let ValBindsOut bind_grps _sigs = hs_valds grp + in [ n | (_, binds0) <- bind_grps + , L _ bind <- bagToList binds0 + , n <- case bind of + FunBind {fun_id = L _ n} -> [n] + PatBind {pat_lhs = L _ p} -> pat_names p + _ -> [] + ] + where + -- return names bound by pattern + pat_names :: Pat Name -> [Name] + pat_names pat = + [ n | Just n <- map pat_bind_name + (trace (showData Renamer 2 (pat, universe pat)) (universe pat)) ] + + pat_bind_name :: Pat Name -> Maybe Name + pat_bind_name (VarPat id) = Just id + pat_bind_name (AsPat (L _ id) _) = Just id + pat_bind_name _ = Nothing +toplevelNames _ = [] + +------------------------------------------------------------------------------ + + +instance Uniplate a => Biplate a a where + biplate = uniplate + +instance Uniplate (Pat n) where + uniplate pat = case pat of + WildPat _ -> (Zero, \Zero -> pat) + VarPat _ -> (Zero, \Zero -> pat) + VarPatOut _n _ -> (Zero, \Zero -> pat) --down binds (VarPatOut n) + LazyPat (L s p) -> (One p, \(One p') -> LazyPat (L s p')) + AsPat n (L s p) -> (One p, \(One p') -> AsPat n (L s p')) + ParPat (L s p) -> (One p, \(One p') -> ParPat (L s p')) + BangPat (L s p) -> (One p, \(One p') -> BangPat (L s p')) + ListPat ps t -> down ps (\ps' -> ListPat ps' t) + TuplePat ps b t -> down ps (\ps' -> TuplePat ps' b t) + PArrPat ps t -> down ps (\ps' -> PArrPat ps' t) + ConPatIn c details -> down details (ConPatIn c) + ConPatOut dcon tvs pds binds args ty -> -- also look inside binds? + down args (\args' -> ConPatOut dcon tvs pds binds args' ty) + ViewPat e (L s p) t -> (One p, \(One p') -> ViewPat e (L s p') t) + QuasiQuotePat _ -> (Zero, \Zero -> pat) + LitPat _ -> (Zero, \Zero -> pat) + NPat _ _ _ -> (Zero, \Zero -> pat) + NPlusKPat _ _ _ _ -> (Zero, \Zero -> pat) + TypePat _ -> (Zero, \Zero -> pat) + SigPatIn (L s p) t -> (One p, \(One p') -> SigPatIn (L s p') t) + SigPatOut (L s p) t -> (One p, \(One p') -> SigPatOut (L s p') t) + CoPat w p t -> (One p, \(One p') -> CoPat w p' t) + +instance Biplate (HsConDetails (LPat id) (HsRecFields id (LPat id))) (Pat id) where + biplate (PrefixCon ps) = down ps PrefixCon + biplate (RecCon fs) = down fs RecCon + biplate (InfixCon (L sl l) (L sr r)) = + (Two (One l) (One r), + \(Two (One l') (One r')) -> InfixCon (L sl l') (L sr r')) + +instance (Uniplate arg) => Biplate (HsRecFields id (Located arg)) arg where + biplate (HsRecFields flds dotdot) = + down flds (\flds' -> HsRecFields flds' dotdot) + +instance (Uniplate arg) => Biplate (HsRecField id (Located arg)) arg where + biplate (HsRecField lid (L sl arg) b) = + (One arg, \(One arg') -> HsRecField lid (L sl arg') b) + +instance Biplate b a => Biplate (Bag b) a where + biplate = uniplateOnBag biplate + +--instance Biplate (HsBindLr n n) + +uniplateOnBag :: (a -> (U.Str b, U.Str b -> a)) + -> Bag a -> (U.Str b, U.Str b -> Bag a) +uniplateOnBag f bag = (as, \ns -> listToBag (bs ns)) + where (as, bs) = uniplateOnList f (bagToList bag) + +down :: Biplate from to => from -> (from -> c) -> (U.Str to, U.Str to -> c) +down b f = (ps, \ps' -> f (set ps')) + where (ps, set) = biplate b + +-- BiplateType from to = (Str to, Str to -> from) + +instance Biplate b a => Biplate (Located b) a where + biplate (L s b) = down b (L s) +{- +instance Uniplate a => Biplate (Located a) a where + biplate (L s a) = (One a, \(One a') -> L s a') +-} +instance Biplate b a => Biplate [b] a where + biplate = uniplateOnList biplate +{- +fmap (fst . biplate) (listStr bs), + strList . fmap (snd . biplate)) +-} +{- + -- biplate :: (Str a, Str a -> [b]) + -- biplate :: (Str a, Str a -> b) +-} +{- +instance Biplate [(Located a)] a where + biplate las = (unLoc `fmap` listStr las, + zipWith (\(L s _) a -> L s a) las . strList) +-} +{- +instance Biplate a b => Biplate (Bag a) b where + biplate b = (foldBag +-} diff --git a/lib/Scion/Inspect/DefinitionSite.hs b/lib/Scion/Inspect/DefinitionSite.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Inspect/DefinitionSite.hs @@ -0,0 +1,116 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +-- | +-- Module : Scion.Inspect.DefinitionSite +-- Copyright : (c) Thomas Schilling 2009 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Collecting and finding the definition site of an identifier. +-- +-- This module analyses Haskell code to find the definition sites of +-- identifiers within. +-- +module Scion.Inspect.DefinitionSite where + +import Scion.Types +import Scion.Types.Notes + +import GHC +import Name ( getOccString, getSrcSpan ) +import Outputable ( showSDoc, ppr, Outputable, (<+>) ) +import PprTyThing ( pprTyThingInContext ) +import TyCon ( isCoercionTyCon, isFamInstTyCon ) +import Var ( globalIdVarDetails ) +import IdInfo ( GlobalIdDetails(..) ) +import HscTypes ( isBootSummary ) + +import qualified Data.Map as M +import Data.List ( foldl' ) +import Data.Monoid +import Control.Monad ( foldM ) + +------------------------------------------------------------------------ +-- * Intended Interface + +-- | Construct a 'DefSiteDB' for a complete module graph. +-- +-- Note: All the modules mentioned in the module graph must have been +-- loaded. This is done either by a successful call to 'GHC.load' or by a +-- call to 'GHC.loadModule' for each module (in dependency order). +moduleGraphDefSiteDB :: + FilePath -- ^ Base path (see 'ghcSpanToLocation') + -> ModuleGraph + -> ScionM DefSiteDB +moduleGraphDefSiteDB base_dir mg = do + let mg' = filter (not . isBootSummary) mg + foldM go emptyDefSiteDB mg' + where + go db modsum = do + db1 <- moduleSiteDB (base_dir, ms_mod modsum) + return (db1 `mappend` db) + +-- | Construct a 'DefSiteDB' for a single module only. +moduleSiteDB :: (FilePath, Module) + -- ^ Base path (see 'ghcSpanToLocation') and module. + -> ScionM DefSiteDB +moduleSiteDB (base_dir, mdl) = do + mb_mod_info <- getModuleInfo mdl + case mb_mod_info of + Nothing -> return emptyDefSiteDB + Just mod_info -> do + return $ mkSiteDB base_dir (modInfoTyThings mod_info) + +-- ** Internal Stuff + +-- | Construct a 'SiteDB' from a base directory and a list of 'TyThing's. +mkSiteDB :: FilePath -> [TyThing] -> DefSiteDB +mkSiteDB base_dir ty_things = foldl' go emptyDefSiteDB ty_things + where + -- TODO: there's probably more stuff to ignore + go db (ATyCon tycon) | is_boring_tycon tycon = db -- ignore + go db (ADataCon datacon) | is_boring_datacon datacon = db + go db (AnId nm) + | isDictonaryId nm || not (is_interesting_id nm) = db + go db ty_thing = + addToDB (getOccString ty_thing) + (ghcSpanToLocation base_dir (getSrcSpan ty_thing)) + ty_thing db + + is_interesting_id ident = + case globalIdVarDetails ident of + VanillaGlobal -> True + ClassOpId _ -> True + RecordSelId {} -> True + NotGlobalId -> True -- global but not exported + _ -> False + + is_boring_tycon tycon = + isClassTyCon tycon || isCoercionTyCon tycon || isFamInstTyCon tycon + + is_boring_datacon datacon = + is_boring_tycon (dataConTyCon datacon) + +addToDB :: String -> Location -> TyThing -> DefSiteDB -> DefSiteDB +addToDB nm loc ty_thing (DefSiteDB m) = + DefSiteDB (M.insertWith (++) nm [(loc,ty_thing)] m) + + +-- | Dump a definition site DB to stdout. (For debugging purposes.) +dumpDefSiteDB :: DefSiteDB -> String +dumpDefSiteDB (DefSiteDB m) = unlines (map pp (M.assocs m)) + where + pp (s, l_ty_things) = show s ++ ":\n" ++ unlines + [ " " ++ show (viewLoc l) ++ ", " ++ pp_ty_thing t + | (l, t) <- l_ty_things ] + + pp_ty_thing tt@(AnId ident) = + showSDoc (pprTyThingInContext False tt <+> ppr (globalIdVarDetails ident)) + + pp_ty_thing (ADataCon dcon) = + showSDoc (ppr dcon <+> ppr (dataConType dcon)) + + pp_ty_thing tt = showSDoc (ppr tt) diff --git a/lib/Scion/Inspect/Find.hs b/lib/Scion/Inspect/Find.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Inspect/Find.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE UndecidableInstances, FunctionalDependencies, FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards, FlexibleInstances, CPP #-} +-- | +-- Module : Scion.Inspect.Search +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Find things in a syntax tree. +-- +module Scion.Inspect.Find + ( findHsThing, SearchResult(..), SearchResults + , PosTree(..), PosForest, deepestLeaf, pathToDeepest + , surrounds, overlaps +#ifdef DEBUG + , prop_invCmpOverlap +#endif + ) +where + +import Scion.Utils() + +import GHC +import BasicTypes ( IPName(..) ) +import Bag +import Var ( varName ) +import Outputable + +import Data.Monoid ( mempty, mappend, mconcat ) +import Data.Foldable as F ( toList, maximumBy ) +import Data.Ord ( comparing ) +import qualified Data.Set as S + +------------------------------------------------------------------------------ + +data PosTree a = Node { val :: a, children :: PosForest a } + deriving (Eq, Ord) +type PosForest a = S.Set (PosTree a) + +-- | Lookup all the things in a certain region. +findHsThing :: Search id a => (SrcSpan -> Bool) -> a -> SearchResults id +findHsThing p a = search p noSrcSpan a + +deepestLeaf :: Ord a => PosTree a -> a +deepestLeaf t = snd $ go (0::Int) t + where + go n (Node x xs) + | S.null xs = (n,x) + | otherwise = maximumBy (comparing fst) (S.map (go (n+1)) xs) + +-- | Returns the deepest leaf, together with the path to this leaf. For +-- example, for the following tree with root @A@: +-- @ +-- A -+- B --- C +-- '- D --- E --- F +-- @ +-- this function will return: +-- @ +-- (F, [E, D, A]) +-- @ +-- If @F@ were missing the result is either @(C, [B,A])@ or @(E, [D,A])@. +-- +pathToDeepest :: Ord a => PosForest a -> Maybe (a, [a]) +pathToDeepest forest + | S.null forest = Nothing + | otherwise = Just $ ptl3 $ go_many (0::Int) [] forest + where + go n path (Node x xs) + | S.null xs = (n, x, path) + | otherwise = go_many (n+1) (x:path) xs + go_many n path xs = + maximumBy (comparing fst3) (S.map (go n path) xs) + fst3 (x,_,_) = x + ptl3 (_,x,y) = (x,y) + + +data SearchResult id + = FoundBind SrcSpan (HsBind id) + | FoundPat SrcSpan (Pat id) + | FoundType SrcSpan (HsType id) + | FoundExpr SrcSpan (HsExpr id) + | FoundStmt SrcSpan (Stmt id) + | FoundId Id + | FoundName Name + | FoundCon SrcSpan DataCon + | FoundLit SrcSpan HsLit + +resLoc :: SearchResult id -> SrcSpan +resLoc (FoundId i) = nameSrcSpan (varName i) +resLoc (FoundName n) = nameSrcSpan n +resLoc (FoundBind s _) = s +resLoc (FoundPat s _) = s +resLoc (FoundType s _) = s +resLoc (FoundExpr s _) = s +resLoc (FoundStmt s _) = s +resLoc (FoundCon s _) = s +resLoc (FoundLit s _) = s + +instance Eq (SearchResult id) where + a == b = resLoc a == resLoc b -- TODO: sufficient? + +instance Ord (SearchResult id) where + compare a b = compare (resLoc a) (resLoc b) + +type SearchResults id = PosForest (SearchResult id) + +-- | Given two good SrcSpans (see 'SrcLoc.isGoodSrcSpan'), returns 'EQ' if the +-- spans overlap or, if not, the relative ordering of both. +cmpOverlap :: SrcSpan -> SrcSpan -> Ordering +cmpOverlap sp1 sp2 + | not (isGoodSrcSpan sp1) = LT + | not (isGoodSrcSpan sp2) = GT + | end1 < start2 = LT + | end2 < start1 = GT + | otherwise = EQ + where + -- At this point we assume that both spans are good. We also ignore the + -- file names since faststrings seem to be rather unreliable. + start1 = (srcSpanStartLine sp1, srcSpanStartCol sp1) + end1 = (srcSpanEndLine sp1, srcSpanEndCol sp1) + start2 = (srcSpanStartLine sp2, srcSpanStartCol sp2) + end2 = (srcSpanEndLine sp2, srcSpanEndCol sp2) + +surrounds :: SrcSpan -> SrcSpan -> Bool +surrounds outer inner = start1 <= start2 && end2 <= end1 + where + start1 = srcSpanStart outer + end1 = srcSpanEnd outer + start2 = srcSpanStart inner + end2 = srcSpanEnd inner + +overlaps :: SrcSpan -> SrcSpan -> Bool +overlaps sp1 sp2 = cmpOverlap sp1 sp2 == EQ + + +#ifdef DEBUG + +prop_invCmpOverlap :: SrcSpan -> SrcSpan -> Bool +prop_invCmpOverlap s1 s2 = + case cmpOverlap s1 s2 of + LT -> cmpOverlap s2 s1 == GT + EQ -> cmpOverlap s2 s1 == EQ + GT -> cmpOverlap s2 s1 == LT + +-- prop_sane : if overlap -> there is some point which is in both spans + +#endif + + +------------------------------------------------------------------------------ + +instance (OutputableBndr id, Outputable id) + => Outputable (SearchResult id) where + ppr (FoundBind s b) = text "bind:" <+> ppr s $$ nest 4 (ppr b) + ppr (FoundPat s b) = text "pat: " <+> ppr s $$ nest 4 (ppr b) + ppr (FoundType s t) = text "type:" <+> ppr s $$ nest 4 (ppr t) + ppr (FoundExpr s e) = text "expr:" <+> ppr s $$ nest 4 (ppr e) + ppr (FoundStmt s t) = text "stmt:" <+> ppr s $$ nest 4 (ppr t) + ppr (FoundId i) = text "id: " <+> ppr i + ppr (FoundName n) = text "name:" <+> ppr n + ppr (FoundCon s c) = text "con: " <+> ppr s $$ nest 4 (ppr c) + ppr (FoundLit s l) = text "lit: " <+> ppr s $$ nest 4 (ppr l) + +instance Outputable a => Outputable (PosTree a) where + ppr (Node v cs) = ppr v $$ nest 2 (vcat (map ppr (S.toList cs))) + +class Search id a | a -> id where + search :: (SrcSpan -> Bool) -> SrcSpan -> a -> SearchResults id + +only :: SearchResult id -> SearchResults id +only r = S.singleton (Node r S.empty) + +above :: SearchResult id -> SearchResults id -> SearchResults id +above r rest = S.singleton (Node r rest) + +instance Search Id Id where + search _ _ i = only (FoundId i) + +instance Search Name Name where + search _ _ i = only (FoundName i) + +instance Search id DataCon where + search _ s d = only (FoundCon s d) + +instance Search id HsLit where + search _ s l = only (FoundLit s l) + +instance Search id id => Search id (IPName id) where + search p s (IPName i) = search p s i + +instance Search id a => Search id (Located a) where + search p _ (L s a) + | p s = search p s a + | otherwise = mempty + +instance Search id a => Search id (Bag a) where + search p s bs = mconcat $ fmap (search p s) (F.toList bs) + +instance Search id a => Search id [a] where + search p s bs = mconcat $ fmap (search p s) bs + +instance Search id a => Search id (Maybe a) where + search _ _ Nothing = mempty + search p s (Just a) = search p s a + +instance (Search id id) => Search id (HsGroup id) where + search p s grp = + search p s (hs_valds grp) + -- TODO + +instance (Search id id) => Search id (HsBindLR id id) where + search p s b = FoundBind s b `above` search_inside + where + search_inside = + case b of + FunBind { fun_id = i, fun_matches = ms } -> + search p s i `mappend` search p s ms + AbsBinds { abs_binds = bs } -> search p s bs + PatBind { pat_lhs = lhs, pat_rhs = rhs } -> + search p s lhs `mappend` search p s rhs + _ -> mempty + +instance (Search id id) => Search id (MatchGroup id) where + search p s (MatchGroup ms _) = search p s ms + +instance (Search id id) => Search id (Match id) where + search p s (Match pats tysig rhss) = + search p s pats `mappend` search p s tysig `mappend` search p s rhss + +instance (Search id id) => Search id (Pat id) where + search p s pat0 = FoundPat s pat0 `above` search_inside + where + search_inside = + case pat0 of + VarPat i -> search p s i + VarPatOut i _ -> search p s i + LazyPat pat -> search p s pat + AsPat i pat -> search p s i `mappend` search p s pat + ParPat pat -> search p s pat + BangPat pat -> search p s pat + ListPat ps _ -> search p s ps + TuplePat ps _ _ -> search p s ps + PArrPat ps _ -> search p s ps + ConPatIn i d -> search p s i `mappend` search p s d + ConPatOut c _ _ _ d _ -> search p s c `mappend` search p s d + ViewPat e pt _ -> search p s e `mappend` search p s pt + TypePat t -> search p s t + SigPatIn pt t -> search p s pt `mappend` search p s t + SigPatOut pt _ -> search p s pt + NPlusKPat n _ _ _ -> search p s n + _ -> mempty + +-- type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) +instance (Search id arg, Search id rec) => Search id (HsConDetails arg rec) where + search p s (PrefixCon args) = search p s args + search p s (RecCon rec) = search p s rec + search p s (InfixCon a1 a2) = search p s a1 `mappend` search p s a2 + +instance (Search id id) => Search id (HsType id) where + search _ s t = only (FoundType s t) + +instance (Search id id) => Search id (GRHSs id) where + search p s (GRHSs rhss local_binds) = + search p s rhss `mappend` search p s local_binds + +instance (Search id id) => Search id (GRHS id) where + search p s (GRHS _guards rhs) = + -- guards look like statements, but we should probably treat them + -- differently + search p s rhs + +instance (Search id id) => Search id (HsExpr id) where + search p s e0 = FoundExpr s e0 `above` search_inside + where + search_inside = + case e0 of + HsVar i -> search p s i + HsIPVar i -> search p s i + HsLit l -> search p s l + ExprWithTySigOut e _t -> search p s e --`mappend` search p s t + HsBracketOut _b _ -> mempty -- search p s b + HsLam mg -> search p s mg + HsApp l r -> search p s l `mappend` search p s r + OpApp l o _ r -> search p s l `mappend` search p s o + `mappend` search p s r + NegApp e n -> search p s e `mappend` search p s n + HsPar e -> search p s e + SectionL e o -> search p s e `mappend` search p s o + SectionR o e -> search p s o `mappend` search p s e + HsCase e mg -> search p s e `mappend` search p s mg + HsIf c t e -> search p s c `mappend` search p s t + `mappend` search p s e + HsLet bs e -> search p s bs `mappend` search p s e + HsDo _ ss e _ -> search p s ss `mappend` search p s e + ExplicitList _ es -> search p s es + ExplicitPArr _ es -> search p s es + ExplicitTuple es _ -> search p s es + RecordCon _ _ bs -> search p s bs + RecordUpd es bs _ _ _ -> search p s es `mappend` search p s bs + ExprWithTySig e t -> search p s e `mappend` search p s t + --ExprWithTySigOut e t -> mempty + ArithSeq _ i -> search p s i + PArrSeq _ i -> search p s i + HsSCC _ e -> search p s e + HsCoreAnn _ e -> search p s e + HsBracket b -> search p s b + --HsBracketOut b _ -> search p s b -- + HsSpliceE sp -> search p s sp + HsQuasiQuoteE _ -> mempty + HsProc pat ct -> search p s pat `mappend` search p s ct + HsArrApp f arg _ _ _ -> search p s f `mappend` search p s arg + HsArrForm e _ cmds -> search p s e `mappend` search p s cmds + HsTick _ _ e -> search p s e + HsBinTick _ _ e -> search p s e + HsTickPragma _ e -> search p s e + HsWrap _ e -> search p s e + _ -> mempty + +instance (Search id id) => Search id (HsLocalBindsLR id id) where + search p s (HsValBinds val_binds) = search p s val_binds + search _ _ _ = mempty + +instance (Search id id) => Search id (HsValBindsLR id id) where + search p s (ValBindsOut rec_binds _) = + mconcat $ fmap (search p s . snd) rec_binds + search _ _ _ = mempty + +instance (Search id id) => Search id (HsCmdTop id) where + search p s (HsCmdTop c _ _ _) = search p s c + +instance (Search id id) => Search id (StmtLR id id) where + search p s st + | RecStmt _ _ _ _ _ <- st = search_inside -- see Note [SearchRecStmt] + | otherwise = FoundStmt s st `above` search_inside + where + search_inside = + case st of + BindStmt pat e _ _ -> search p s pat `mappend` search p s e + ExprStmt e _ _ -> search p s e + LetStmt bs -> search p s bs + ParStmt ss -> search p s (concatMap fst ss) + TransformStmt (ss,_) f e -> search p s ss `mappend` search p s f + `mappend` search p s e + GroupStmt (ss, _) g -> search p s ss `mappend` search p s g + RecStmt ss _ _ _ _ -> search p s ss + +-- +-- Note [SearchRecStmt] +-- -------------------- +-- +-- We only return children of a RecStmt but not the RecStmt itself, even +-- though a RecStmt may occur in the source code (under very rare +-- circumstances). The reasons are: +-- +-- * We have no way of knowing whether the RecStmt actually occured in the +-- source code. We could add a flag in GHC, but its probably not +-- worthwhile due to the other reason. +-- +-- * GHC may move things out of the recursive group if it detects that these +-- things are in fact not recursive at all. Source locations are +-- preserved, so this is fine. +-- + +instance (Search id id) => Search id (GroupByClause id) where + search p s (GroupByNothing f) = search p s f + search p s (GroupBySomething using_f e) = + either (search p s) (const mempty) using_f `mappend` search p s e + +instance (Search id id) => Search id (ArithSeqInfo id) where + search p s (From e) = search p s e + search p s (FromThen e1 e2) = search p s e1 `mappend` search p s e2 + search p s (FromTo e1 e2) = search p s e1 `mappend` search p s e2 + search p s (FromThenTo e1 e2 e3) = + search p s e1 `mappend` search p s e2 `mappend` search p s e3 + +-- type HsRecordBinds id = HsRecFields id (LHsExpr id) +instance Search id e => Search id (HsRecFields id e) where + search p s (HsRecFields flds _) = search p s flds + +instance Search id e => Search id (HsRecField id e) where + search p s (HsRecField _lid a _) = search p s a + +instance (Search id id) => Search id (HsBracket id) where + search p s (ExpBr e) = search p s e + search p s (PatBr q) = search p s q + search p s (DecBr g) = search p s g + search p s (TypBr t) = search p s t + search _ _ (VarBr _) = mempty + +instance (Search id id) => Search id (HsSplice id) where + search p s (HsSplice _ e) = search p s e + diff --git a/lib/Scion/Inspect/TypeOf.hs b/lib/Scion/Inspect/TypeOf.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Inspect/TypeOf.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Scion.Inspect.TypeOf +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +module Scion.Inspect.TypeOf where + +import Scion.Inspect.Find ( SearchResult(..) ) + +import GHC +import Var ( varType ) +import TypeRep ( Type(..), PredType(..) ) + +------------------------------------------------------------------------------ + +typeOf :: (SearchResult Id, [SearchResult Id]) -> Maybe Type +typeOf (leaf, path) = case leaf of + FoundId i -> type_of_id i + _ -> Nothing + where + type_of_id i = case path of + FoundExpr _ (HsVar _) : FoundExpr _ (HsWrap wr _) : _ -> + Just $ reduce_type $ unwrap wr (varType i) + _ -> Just (varType i) + + unwrap WpHole t = t + unwrap (WpCompose w1 w2) t = unwrap w1 (unwrap w2 t) + unwrap (WpCast _) t = t -- XXX: really? + unwrap (WpTyApp t') t = AppTy t t' + unwrap (WpTyLam tv) t = ForAllTy tv t + -- do something else with coercion/dict vars? + unwrap (WpApp v) t = AppTy t (TyVarTy v) + unwrap (WpLam v) t = ForAllTy v t + unwrap (WpLet _bs) t = t +#ifdef WPINLINE + unwrap WpInline t = t +#endif + +-- | Reduce a top-level type application if possible. That is, we perform the +-- following simplification step: +-- @ +-- (forall v . t) t' ==> t [t'/v] +-- @ +-- where @[t'/v]@ is the substitution of @t'@ for @v@. +-- +reduce_type :: Type -> Type +reduce_type (AppTy (ForAllTy tv b) t) = + reduce_type (subst_type tv t b) +reduce_type t = t + +subst_type :: TyVar -> Type -> Type -> Type +subst_type v t' t0 = go t0 + where + go t = case t of + TyVarTy tv + | tv == v -> t' + | otherwise -> t + AppTy t1 t2 -> AppTy (go t1) (go t2) + TyConApp c ts -> TyConApp c (map go ts) + FunTy t1 t2 -> FunTy (go t1) (go t2) + ForAllTy v' bt + | v == v' -> t + | otherwise -> ForAllTy v' (go bt) + PredTy pt -> PredTy (go_pt pt) + + -- XXX: this is probably not right + go_pt (ClassP c ts) = ClassP c (map go ts) + go_pt (IParam i t) = IParam i (go t) + go_pt (EqPred t1 t2) = EqPred (go t1) (go t2) diff --git a/lib/Scion/Session.hs b/lib/Scion/Session.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Session.hs @@ -0,0 +1,723 @@ +{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE PatternGuards, DeriveDataTypeable #-} +-- | +-- Module : Scion.Session +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Utilities to manipulate the session state. +-- +module Scion.Session where +-- Imports +import Prelude hiding ( mod ) +import GHC hiding ( flags, load ) +import HscTypes ( srcErrorMessages, SourceError, isBootSummary ) +import Exception + +import Scion.Types +import Scion.Types.Notes +import Scion.Utils +import Scion.Inspect.DefinitionSite + +import qualified Data.MultiSet as MS +import Control.Monad +import Data.Data +import Data.IORef +import Data.List ( intercalate, nubBy ) +import Data.Maybe ( isJust, fromMaybe, fromJust ) +import Data.Monoid +import Data.Time.Clock ( getCurrentTime, diffUTCTime ) +import System.Directory ( setCurrentDirectory, getCurrentDirectory, + doesFileExist, getDirectoryContents ) +import System.FilePath ( (), isRelative, makeRelative, normalise, + dropFileName, takeDirectory, takeFileName ) +import Control.Exception +import System.Exit ( ExitCode(..) ) + +import qualified Distribution.ModuleName as PD ( ModuleName, components ) +import Distribution.Simple.Configure +import Distribution.Simple.GHC ( ghcOptions ) +import Distribution.Simple.LocalBuildInfo hiding ( libdir ) +import Distribution.Simple.Build ( initialBuildSteps ) +import Distribution.Simple.PreProcess ( knownSuffixHandlers ) +import qualified Distribution.Verbosity as V +import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Parse as PD +import qualified Distribution.PackageDescription.Configuration as PD + +------------------------------------------------------------------------------ + +-- TODO: have some kind of project description file, that allows us to +-- reconfigure a project when needed. + +------------------------------------------------------------------------------ + +-- * Exception Types +-- also see ScionError Exception + +data CannotOpenCabalProject = CannotOpenCabalProject String + deriving (Show, Typeable) +instance Exception CannotOpenCabalProject where + toException = scionToException + fromException = scionFromException + +data NoCurrentCabalProject = NoCurrentCabalProject deriving (Show, Typeable) +instance Exception NoCurrentCabalProject where + toException = scionToException + fromException = scionFromException + +data ComponentDoesNotExist = ComponentDoesNotExist Component + deriving (Show, Typeable) +instance Exception ComponentDoesNotExist where + toException = scionToException + fromException = scionFromException + + +-- * Setting Session Parameters + + +initialScionDynFlags :: DynFlags -> DynFlags +initialScionDynFlags dflags = + dflags { + -- GHC 6.10.1 has a bug in that it doesn't properly keep track of which + -- modules were compiled in HscNothing mode. To avoid this, we use + -- HscInterpreted. Unfortunately, that means we cannot use Scion with + -- projects that use unboxed tuples, as those are not supported by the + -- byte code compiler. +#ifdef RECOMPILE_BUG_FIXED + hscTarget = HscNothing -- by default, don't modify anything + , ghcLink = NoLink -- just to be sure +#else + hscTarget = HscInterpreted + , ghcLink = LinkInMemory +#endif + } + +-- | Reset the state of the session to a defined default state. +-- +-- Due to some bugs in GHC this isn't completely possible. For example, GHC +-- retains instance declarations which can lead to problems when you load a +-- new module which defines a different instance. (You'll get a conflicting +-- instance error, which can only be resolved by re-starting GHC.) +resetSessionState :: ScionM () +resetSessionState = do + unload + + dflags0 <- gets initialDynFlags + -- TODO: do something with result from setSessionDynFlags? + setSessionDynFlags (initialScionDynFlags dflags0) + return () + +-- | Sets the current working directory and notifies GHC about the change. +-- +-- TODO: do we want to adjust certain flags automatically? +setWorkingDir :: FilePath -> ScionM () +setWorkingDir home = do + cwd <- liftIO $ getCurrentDirectory + message deafening $ "Setting working directory: " ++ home ++ " (old: " ++ cwd ++ ")" + liftIO $ setCurrentDirectory home + cwd' <- liftIO $ getCurrentDirectory -- to avoid normalisation issues + when (cwd /= cwd') $ do + message deafening $ "(Working directory changed.)" + workingDirectoryChanged + +------------------------------------------------------------------------ +-- * Cabal Projects + +-- | Try to open a Cabal project. The project must already be configured +-- using the same version of Cabal that Scion was build against. +-- +-- Use 'configureCabalProject' to automatically configure a project (if it +-- hasn't been already.) +-- +-- TODO: Allow other working directories? Would require translating all the +-- search paths from relative to absolute paths. Furthermore, what should the +-- output directory be then? +-- +-- Throws: +-- +-- * 'CannotOpenCabalProject' if an error occurs (e.g., not configured +-- project or configured with incompatible cabal version). +-- +openCabalProject :: FilePath -- ^ Project root directroy + -> FilePath -- ^ Project dist directory (relative) + -> ScionM () +openCabalProject root_dir dist_rel_dir = do + -- XXX: check that working dir contains a .cabal file + let dist_dir = root_dir dist_rel_dir + mb_lbi <- liftIO $ tryGetConfigStateFile (localBuildInfoFile dist_dir) + case mb_lbi of + Left e -> + liftIO $ throwIO $ CannotOpenCabalProject $ "reason :" ++ show e + Right lbi -> do + setWorkingDir root_dir + resetSessionState + -- XXX: do something with old lbi before updating? + modifySessionState $ \st -> st { localBuildInfo = Just lbi } + +-- | Return the (configured) package description of the current Cabal project. +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +currentCabalPackage :: ScionM PD.PackageDescription +currentCabalPackage = do + lbi <- getLocalBuildInfo + return (localPkgDescr lbi) + +-- | Return path to the .cabal file of the current Cabal package. +-- +-- This is useful to identify the project when communicating with Scion from +-- foreign code, because this does not require serialising the local build +-- info. +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project or the +-- current project has no .cabal file. +-- +currentCabalFile :: ScionM FilePath +currentCabalFile = do + lbi <- getLocalBuildInfo + case pkgDescrFile lbi of + Just f -> return f + Nothing -> liftIO $ throwIO $ NoCurrentCabalProject + +-- | Return all components of the specified Cabal file. +-- +-- Throws: +-- +-- * 'CannotOpenCabalProject' if an error occurs (e.g., .cabal file does +-- not exist or could not be parsed.). +-- +cabalProjectComponents :: FilePath -- ^ The .cabal file + -> ScionM [Component] +cabalProjectComponents cabal_file = do + ghandle (\(_ :: ExitCode) -> + liftIO $ throwIO $ CannotOpenCabalProject cabal_file) $ do + gpd <- liftIO $ PD.readPackageDescription V.silent cabal_file + let pd = PD.flattenPackageDescription gpd + return $ + (if isJust (PD.library pd) then [Library] else []) ++ + [ Executable (PD.exeName e) | e <- PD.executables pd ] + + +-- returns a list of cabal configurations +-- dist: those who have been configured * /setup-config +-- config: those from the .scion-config project configuration file +-- all: both +-- uniq: both, but prefer config items +cabalConfigurations :: FilePath -- ^ The .cabal file + -> String -- ^ one of "dist" "config" "all" + -> Bool -- only show scion default? + -> ScionM [CabalConfiguration] +cabalConfigurations cabal type' scionDefaultOnly = do + let allowed = ["dist", "config", "all", "uniq"] + when (not $ elem type' allowed) $ scionError $ "invalid value for type, expected: one of " ++ (show allowed) + let dir = takeDirectory cabal + existingDists <- liftIO $ filterM (doesFileExist . (\c -> dir c "setup-config")) + =<< liftM (filter (not . (`elem` [".", ".."]))) (getDirectoryContents dir) + config <- parseScionProjectConfig $ projectConfigFileFromDir dir + let list = (if type' `elem` ["all", "config", "uniq"] then buildConfigurations config else []) + -- TODO read flags from setup-config files + ++ (if type' `elem` ["all", "dist", "uniq"] then map (\ a-> CabalConfiguration a []) existingDists else []) + let f = if type' == "uniq" then nubBy (\a b -> distDir a == distDir b) else id + -- apply filter + let list' = f list + let d = scionDefaultCabalConfig config + let scionDefault = filter ( ((fromJust d) ==) . distDir) list' + return $ if isJust d && scionDefaultOnly && (not . null) scionDefault + then scionDefault + else list' + +-- | Run the steps that Cabal would call before building. +-- +preprocessPackage :: FilePath + -> ScionM () +preprocessPackage dist_dir = do + lbi <- getLocalBuildInfo + let pd = localPkgDescr lbi + liftIO $ initialBuildSteps dist_dir pd lbi V.normal knownSuffixHandlers + return () + +-- | Return the current 'LocalBuildInfo'. +-- +-- The 'LocalBuildInfo' is the result of configuring a Cabal project, +-- therefore requires that we have a current Cabal project. +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +getLocalBuildInfo :: ScionM LocalBuildInfo +getLocalBuildInfo = + gets localBuildInfo >>= \mb_lbi -> + case mb_lbi of + Nothing -> liftIO $ throwIO NoCurrentCabalProject + --error "call openCabalProject before loadCabalProject" + Just lbi -> return lbi + +-- | Root directory of the current Cabal project. +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +projectRootDir :: ScionM FilePath +projectRootDir = do + -- _ <- getLocalBuildInfo -- ensure we have a current project + -- TODO: error handling + liftIO $ getCurrentDirectory + +-- | Set GHC's dynamic flags for the given component of the current Cabal +-- project (see 'openCabalProject'). +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +-- * 'ComponentDoesNotExist' if the current Cabal project does not contain +-- the specified component. +-- +setComponentDynFlags :: + Component + -> ScionM [PackageId] + -- ^ List of packages that need to be loaded. This corresponds to the + -- build-depends of the loaded component. + -- + -- TODO: do something with this depending on Scion mode? +setComponentDynFlags (File f) = do + cfg <- liftM projectConfigFileFromDir $ liftIO getCurrentDirectory + config <- parseScionProjectConfig cfg + addCmdLineFlags $ fromMaybe [] $ lookup (takeFileName f) (fileComponentExtraFlags config) +setComponentDynFlags component = do + lbi <- getLocalBuildInfo + bi <- component_build_info component (localPkgDescr lbi) + let odir = buildDir lbi + let flags = ghcOptions lbi bi odir + addCmdLineFlags flags + where + component_build_info Library pd + | Just lib <- PD.library pd = return (PD.libBuildInfo lib) + | otherwise = noLibError + component_build_info (Executable n) pd = + case [ exe | exe <- PD.executables pd, PD.exeName exe == n ] of + [ exe ] -> return (PD.buildInfo exe) + [] -> noExeError n + _ -> error $ "Multiple executables, named \"" ++ n ++ + "\" found. This is weird..." + component_build_info _ _ = + dieHard "component_build_info: impossible case" + +-- | Set the targets for a 'GHC.load' command from the meta data of the +-- current Cabal project. +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +-- * 'ComponentDoesNotExist' if the current Cabal project does not contain +-- the specified component. +-- +setComponentTargets :: Component -> ScionM () +setComponentTargets Library = do + pd <- currentCabalPackage + unless (isJust (PD.library pd)) + noLibError + let modnames = PD.libModules pd + setTargets (map cabalModuleNameToTarget modnames) +setComponentTargets (Executable n) = do + pd <- currentCabalPackage + let ex0 = filter ((n==) . PD.exeName) (PD.executables pd) + case ex0 of + [] -> noExeError n + (_:_:_) -> error $ "Multiple executables with name: " ++ n + [exe] -> do + proj_root <- cabalProjectRoot + let others = PD.otherModules (PD.buildInfo exe) + let main_mods = [ proj_root search_path PD.modulePath exe + | search_path <- PD.hsSourceDirs (PD.buildInfo exe)] + (main_mod:_) <- filterM (liftIO . doesFileExist) main_mods + let targets = Target (TargetFile main_mod Nothing) True Nothing : + map cabalModuleNameToTarget others + setTargets targets + return () +setComponentTargets (File f) = do + setTargets [ Target (TargetFile f Nothing) + True + Nothing ] + +cabalModuleNameToTarget :: PD.ModuleName -> Target +cabalModuleNameToTarget name = + Target { targetId = TargetModule (mkModuleName + (cabal_mod_to_string name)) + , targetAllowObjCode = True + , targetContents = Nothing } + where + cabal_mod_to_string m = + intercalate "." (PD.components m) + +-- | Load the specified component from the current Cabal project. +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +-- * 'ComponentDoesNotExist' if the current Cabal project does not contain +-- the specified component. +-- +loadComponent :: Component + -> ScionM CompilationResult + -- ^ The compilation result. +loadComponent comp = do + -- TODO: group warnings by file + resetSessionState + setActiveComponent comp + maybe_set_working_dir comp + -- Need to set DynFlags first, so that the search paths are set up + -- correctly before looking for the targets. + setComponentDynFlags comp + setComponentTargets comp + rslt <- load LoadAllTargets + mg <- getModuleGraph + base_dir <- projectRootDir + db <- moduleGraphDefSiteDB base_dir mg + liftIO $ evaluate db + modifySessionState $ \s -> s { lastCompResult = rslt + , defSiteDB = db } + return rslt + where + maybe_set_working_dir (File f) = do + wd <- liftIO $ getCurrentDirectory + let dir = normalise $ wd dropFileName f + setWorkingDir dir + maybe_set_working_dir _ = do + dir <- cabalProjectRoot + setWorkingDir dir + +cabalProjectRoot :: ScionM FilePath +cabalProjectRoot = do + lbi <- getLocalBuildInfo + let mb_pkg_dir = dropFileName `fmap` pkgDescrFile lbi + case mb_pkg_dir of + Just dir -> return dir + Nothing -> liftIO $ getCurrentDirectory + +-- | Make the specified component the active one. Sets the DynFlags to +-- those specified for the given component. Unloads the possible +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +-- * 'ComponentDoesNotExist' if the current Cabal project does not contain +-- the specified component. +-- +setActiveComponent :: Component -> ScionM () +setActiveComponent comp = do + curr_comp <- gets activeComponent + when (needs_unloading curr_comp) + unload + setComponentDynFlags comp + modifySessionState (\sess -> sess { activeComponent = Just comp }) + where + needs_unloading (Just c) | c /= comp = True + needs_unloading _ = False + +-- | Return the currently active component. +getActiveComponent :: ScionM (Maybe Component) +getActiveComponent = gets activeComponent + +-- ** Internal Utilities +noLibError :: ScionM a +noLibError = liftIO $ throwIO $ ComponentDoesNotExist Library + +noExeError :: String -> ScionM a +noExeError = liftIO . throwIO . ComponentDoesNotExist . Executable + +------------------------------------------------------------------------ +-- * Compilation + +-- | Wrapper for 'GHC.load'. +load :: LoadHowMuch -> ScionM CompilationResult +load how_much = do + start_time <- liftIO $ getCurrentTime + ref <- liftIO $ newIORef (mempty, mempty) + res <- loadWithLogger (logWarnErr ref) how_much + `gcatch` (\(e :: SourceError) -> handle_error ref e) + end_time <- liftIO $ getCurrentTime + let time_diff = diffUTCTime end_time start_time + (warns, errs) <- liftIO $ readIORef ref + base_dir <- projectRootDir + let notes = ghcMessagesToNotes base_dir (warns, errs) + let comp_rslt = case res of + Succeeded -> CompilationResult True notes time_diff + Failed -> CompilationResult False notes time_diff + -- TODO: We need to somehow find out which modules were recompiled so we + -- only update the part that we have new information for. + modifySessionState $ \s -> s { lastCompResult = comp_rslt } + return comp_rslt + where + logWarnErr ref err = do + let errs = case err of + Nothing -> mempty + Just exc -> srcErrorMessages exc + warns <- getWarnings + clearWarnings + add_warn_err ref warns errs + + add_warn_err ref warns errs = + liftIO $ modifyIORef ref $ + \(warns', errs') -> ( warns `mappend` warns' + , errs `mappend` errs') + + handle_error ref e = do + let errs = srcErrorMessages e + warns <- getWarnings + add_warn_err ref warns errs + clearWarnings + return Failed + +-- | Unload whatever is currently loaded. +unload :: ScionM () +unload = do + setTargets [] + load LoadAllTargets + modifySessionState $ \st -> st { lastCompResult = mempty + , defSiteDB = mempty } + return () + +-- | Parses the list of 'Strings' as command line arguments and sets the +-- 'DynFlags' accordingly. +-- +-- Does not set the flags if a parse error occurs. XXX: There's currently +-- no way to find out if there was an error from inside the program. +addCmdLineFlags :: [String] -> ScionM [PackageId] +addCmdLineFlags flags = do + message deafening $ "Setting Flags: " ++ show flags + dflags <- getSessionDynFlags + res <- gtry $ parseDynamicFlags dflags (map noLoc flags) + case res of + Left (UsageError msg) -> do + liftIO $ putStrLn $ "Dynflags parse error: " ++ msg + return [] + Left e -> liftIO $ throwIO e + Right (dflags', unknown, warnings) -> do + unless (null unknown) $ + liftIO $ putStrLn $ "Unrecognised flags:\n" ++ show (map unLoc unknown) + liftIO $ mapM_ putStrLn $ map unLoc warnings + setSessionDynFlags dflags' + +-- | List all components in the current cabal project. +-- +-- This can be used to present the user a list of possible items to load. +-- +-- Throws: +-- +-- * 'NoCurrentCabalProject' if there is no current Cabal project. +-- +availableComponents :: ScionM [Component] +availableComponents = do + pd <- currentCabalPackage + return $ (case PD.library pd of + Just _ -> [Library] + _ -> []) ++ + [ Executable n + | PD.Executable {PD.exeName = n} <- PD.executables pd ] + +-- | Set the verbosity of the GHC API. +setGHCVerbosity :: Int -> ScionM () +setGHCVerbosity lvl = do + dflags <- getSessionDynFlags + setSessionDynFlags $! dflags { verbosity = lvl } + return () + +------------------------------------------------------------------------------ +-- * Background Typechecking + +-- | Takes an absolute path to a file and attempts to typecheck it. +-- +-- This performs the following steps: +-- +-- 1. Check whether the file is actually part of the current project. It's +-- also currently not possible to typecheck a .hs-boot file using this +-- function. We simply bail out if these conditions are not met. +-- +-- 2. Make sure that all dependencies of the module are up to date. +-- +-- 3. Parse, typecheck, desugar and load the module. The last step is +-- necessary so that we can we don't have to recompile in the case that +-- we switch to another module. +-- +-- 4. If the previous step was successful, cache the results in the session +-- for use by source code inspection utilities. Some of the above steps +-- are skipped if we know that they are not necessary. +-- +backgroundTypecheckFile :: + FilePath + -> ScionM (Either String CompilationResult) + -- ^ First element is @False@ <=> step 1 above failed. +backgroundTypecheckFile fname = do + root_dir <- projectRootDir + ifM (not `fmap` isRelativeToProjectRoot fname) + (return (Left ("file " ++ fname ++ " is not relative to project root " ++ root_dir))) + prepareContext + where + prepareContext :: ScionM (Either String CompilationResult) + prepareContext = do + message verbose $ "Preparing context for " ++ fname + -- if it's the focused module, we know that the context is right + mb_focusmod <- gets focusedModule + case mb_focusmod of + Just ms | Just f <- ml_hs_file (ms_location ms), f == fname -> + backgroundTypecheckFile' mempty + + _otherwise -> do + mb_modsum <- filePathToProjectModule fname + case mb_modsum of + Nothing -> do + return $ Left "Could not find file in module graph." + Just modsum -> do + (_, rslt) <- setContextForBGTC modsum + if compilationSucceeded rslt + then backgroundTypecheckFile' rslt + else return $ Right rslt + + backgroundTypecheckFile' comp_rslt = do + message verbose $ "Background type checking: " ++ fname + clearWarnings + start_time <- liftIO $ getCurrentTime + modsum <- preprocessModule + + let finish_up tc_res errs = do + base_dir <- projectRootDir + warns <- getWarnings + clearWarnings + let notes = ghcMessagesToNotes base_dir (warns, errs) + end_time <- liftIO $ getCurrentTime + let ok = isJust tc_res + let res = CompilationResult ok notes + (diffUTCTime end_time start_time) + let abs_fname = mkAbsFilePath base_dir fname + full_comp_rslt <- removeMessagesForFile abs_fname =<< gets lastCompResult + let comp_rslt' = full_comp_rslt `mappend` comp_rslt `mappend` res + + modifySessionState (\s -> s { bgTcCache = tc_res + , lastCompResult = comp_rslt' }) + + return $ Right comp_rslt' + + ghandle (\(e :: SourceError) -> finish_up Nothing (srcErrorMessages e)) $ + do + -- TODO: measure time and stop after a phase if it takes too long? + parsed_mod <- parseModule modsum + tcd_mod <- typecheckModule parsed_mod + ds_mod <- desugarModule tcd_mod + loadModule ds_mod -- ensure it's in the HPT + finish_up (Just (Typechecked tcd_mod)) mempty + + preprocessModule = do + depanal [] True + -- reload-calculate the ModSummary because it contains the cached + -- preprocessed source code + mb_modsum <- filePathToProjectModule fname + case mb_modsum of + Nothing -> error "Huh? No modsummary after preprocessing?" + Just ms -> return ms + + +-- | Return whether the filepath refers to a file inside the current project +-- root. Return 'False' if there is no current project. +isRelativeToProjectRoot :: FilePath -> ScionM Bool +isRelativeToProjectRoot fname = do + root_dir <- projectRootDir + return (isRelative (makeRelative root_dir fname)) + `gcatch` \(_ :: NoCurrentCabalProject) -> return False + + +filePathToProjectModule :: FilePath -> ScionM (Maybe ModSummary) +filePathToProjectModule fname = do + -- We use the current module graph, don't bother to do a new depanal + -- if it's empty then we have no current component, hence no BgTcCache. + -- + -- We check for both relative and absolute filenames because we don't seem + -- to have any guarantee from GHC what the filenames will look like. + -- TODO: not sure what happens for names like "../foo" + root_dir <- projectRootDir + let rel_fname = normalise (makeRelative root_dir fname) + mod_graph <- getModuleGraph + case [ m | m <- mod_graph + , not (isBootSummary m) + , Just src <- [ml_hs_file (ms_location m)] + , src == fname || src == rel_fname || normalise src == normalise rel_fname ] + of [ m ] -> do return (Just m) + l -> do message verbose $ "No module found for " ++ fname ++ (if null l then "" else " reason: ambiguity") + return Nothing -- ambiguous or not present + `gcatch` \(_ :: NoCurrentCabalProject) -> return Nothing + +isPartOfProject :: FilePath -> ScionM Bool +isPartOfProject fname = fmap isJust (filePathToProjectModule fname) + + +-- | Ensure that all dependencies of the module are already loaded. +-- +-- Sets 'focusedModule' if it was successful. +setContextForBGTC :: ModSummary -> ScionM (Maybe ModuleName, CompilationResult) +setContextForBGTC modsum = do + message deafening $ "Setting context for: " ++ + moduleNameString (moduleName (ms_mod modsum)) + let mod_name = ms_mod_name modsum + start_time <- liftIO $ getCurrentTime + r <- load (LoadDependenciesOf mod_name) + `gcatch` \(e :: SourceError) -> + srcErrToCompilationResult start_time e + modifySessionState $ \sess -> + sess { focusedModule = if compilationSucceeded r + then Just modsum + else Nothing + } + return (Nothing, r) + where + srcErrToCompilationResult start_time err = do + end_time <- liftIO $ getCurrentTime + warns <- getWarnings + clearWarnings + base_dir <- projectRootDir + let notes = ghcMessagesToNotes base_dir (warns, srcErrorMessages err) + return (CompilationResult False notes + (diffUTCTime end_time start_time)) + +-- | Return the 'ModSummary' that refers to the source file. +-- +-- Assumes that there is exactly one such 'ModSummary'. +-- +modSummaryForFile :: FilePath -> ModuleGraph -> ModSummary +modSummaryForFile fname mod_graph = + case [ m | m <- mod_graph + , Just src <- [ml_hs_file (ms_location m)] + , src == fname ] + of [ m ] -> m + [] -> dieHard $ "modSummaryForFile: No ModSummary found for " ++ fname + _ -> dieHard $ "modSummaryForFile: Too many ModSummaries found for " + ++ fname + + +removeMessagesForFile :: AbsFilePath -> CompilationResult -> ScionM CompilationResult +removeMessagesForFile fname res = return res' + where + notes = compilationNotes res + res' = res { compilationNotes = notes' } + notes' = MS.filter f notes + f note + | isValidLoc l, FileSrc fn <- locSource l = fname /= fn + | otherwise = True + where l = noteLoc note + +-- Local Variables: +-- indent-tabs-mode: nil +-- End: diff --git a/lib/Scion/Types.hs b/lib/Scion/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Types.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} +-- | +-- Module : Scion.Types +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Types used throughout Scion. +-- +module Scion.Types + ( module Scion.Types + , liftIO, MonadIO + ) where + +import Scion.Types.Notes +import Scion.Types.ExtraInstances() + +import GHC +import HscTypes +import MonadUtils ( liftIO, MonadIO ) +import Exception + +import qualified Data.Map as M +import qualified Data.MultiSet as MS +import Distribution.Simple.LocalBuildInfo +import Control.Monad ( when ) +import Data.IORef +import Data.Monoid +import Data.Time.Clock ( NominalDiffTime ) +import Data.Typeable +import Control.Exception +import Control.Applicative + +------------------------------------------------------------------------------ +-- * The Scion Monad and Session State + +-- XXX: Can we get rid of some of this maybe stuff? +data SessionState + = SessionState { + scionVerbosity :: Verbosity, + initialDynFlags :: DynFlags, + -- ^ The DynFlags as they were when Scion was started. This is used + -- to reset flags when opening a new project. Arguably, the GHC API + -- should provide calls to reset a session. + + localBuildInfo :: Maybe LocalBuildInfo, + -- ^ Build info from current Cabal project. + + activeComponent :: Maybe Component, + -- ^ The current active Cabal component. This affects DynFlags and + -- targets. ATM, we don't support multiple active components. + + lastCompResult :: CompilationResult, + + focusedModule :: Maybe ModSummary, + -- ^ The currently focused module for background typechecking. + + bgTcCache :: Maybe BgTcCache, + -- ^ Cached state of the background typechecker. + + defSiteDB :: DefSiteDB, + -- ^ Source code locations. + + client :: String + -- ^ can be set by the client. Only used by vim to enable special hack + } + +mkSessionState :: DynFlags -> IO (IORef SessionState) +mkSessionState dflags = + newIORef (SessionState normal dflags Nothing Nothing mempty Nothing Nothing mempty "") + + +newtype ScionM a + = ScionM { unScionM :: IORef SessionState -> Ghc a } + +instance Monad ScionM where + return x = ScionM $ \_ -> return x + (ScionM ma) >>= fb = + ScionM $ \s -> do + a <- ma s + unScionM (fb a) s + fail msg = dieHard msg + +instance Functor ScionM where + fmap f (ScionM ma) = + ScionM $ \s -> fmap f (ma s) + +instance Applicative ScionM where + pure a = ScionM $ \_ -> return a + ScionM mf <*> ScionM ma = + ScionM $ \s -> do f <- mf s; a <- ma s; return (f a) + +liftScionM :: Ghc a -> ScionM a +liftScionM m = ScionM $ \_ -> m + +instance MonadIO ScionM where + liftIO m = liftScionM $ liftIO m + +instance ExceptionMonad ScionM where + gcatch (ScionM act) handler = + ScionM $ \s -> act s `gcatch` (\e -> unScionM (handler e) s) + gblock (ScionM act) = ScionM $ \s -> gblock (act s) + gunblock (ScionM act) = ScionM $ \s -> gunblock (act s) + +instance WarnLogMonad ScionM where + setWarnings = liftScionM . setWarnings + getWarnings = liftScionM getWarnings + +instance GhcMonad ScionM where + getSession = liftScionM getSession + setSession = liftScionM . setSession + +modifySessionState :: (SessionState -> SessionState) -> ScionM () +modifySessionState f = + ScionM $ \r -> liftIO $ do s <- readIORef r; writeIORef r $! f s + +getSessionState :: ScionM SessionState +getSessionState = ScionM $ \s -> liftIO $ readIORef s + +gets :: (SessionState -> a) -> ScionM a +gets sel = getSessionState >>= return . sel + +setSessionState :: SessionState -> ScionM () +setSessionState s' = ScionM $ \r -> liftIO $ writeIORef r s' + +------------------------------------------------------------------------------ +-- ** Verbosity Levels + +data Verbosity + = Silent + | Normal + | Verbose + | Deafening + deriving (Eq, Ord, Show, Enum, Bounded) + +intToVerbosity :: Int -> Verbosity +intToVerbosity n + | n < 0 = minBound + | n > fromEnum (maxBound :: Verbosity) = maxBound + | otherwise = toEnum n + +verbosityToInt :: Verbosity -> Int +verbosityToInt = fromEnum + +silent :: Verbosity +silent = Silent + +normal :: Verbosity +normal = Normal + +verbose :: Verbosity +verbose = Verbose + +deafening :: Verbosity +deafening = Deafening + +getVerbosity :: ScionM Verbosity +getVerbosity = gets scionVerbosity + +setVerbosity :: Verbosity -> ScionM () +setVerbosity v = modifySessionState $ \s -> s { scionVerbosity = v } + +message :: Verbosity -> String -> ScionM () +message v s = do + v0 <- getVerbosity + when (v0 >= v) $ liftIO $ putStrLn s + +------------------------------------------------------------------------ +-- * Reflection into IO + +-- | Reflect a computation in the 'ScionM' monad into the 'IO' monad. +reflectScionM :: ScionM a -> (IORef SessionState, Session) -> IO a +reflectScionM (ScionM f) = \(st, sess) -> reflectGhc (f st) sess + +-- | Dual to 'reflectScionM'. See its documentation. +reifyScionM :: ((IORef SessionState, Session) -> IO a) -> ScionM a +reifyScionM act = ScionM $ \st -> reifyGhc $ \sess -> act (st, sess) + +------------------------------------------------------------------------------ +-- * Compilation Results + +data BgTcCache + = Parsed ParsedModule + | Typechecked TypecheckedModule + +data CompilationResult = CompilationResult { + compilationSucceeded :: Bool, + compilationNotes :: MS.MultiSet Note, + compilationTime :: NominalDiffTime + } + +instance Monoid CompilationResult where + mempty = CompilationResult True mempty 0 + mappend r1 r2 = + CompilationResult + { compilationSucceeded = + compilationSucceeded r1 && compilationSucceeded r2 + , compilationNotes = + compilationNotes r1 `MS.union` compilationNotes r2 + , compilationTime = compilationTime r1 + compilationTime r2 + } + +------------------------------------------------------------------------------ +-- * Exceptions + +-- | Any exception raised inside Scion is a subtype of this exception. +data SomeScionException + = forall e. (Exception e) => SomeScionException e + deriving Typeable + +instance Show SomeScionException where show (SomeScionException e) = show e +instance Exception SomeScionException + +scionToException :: Exception e => e -> SomeException +scionToException = toException . SomeScionException + +scionFromException :: Exception e => SomeException -> Maybe e +scionFromException x = do + SomeScionException e <- fromException x + cast e + +-- | A fatal error. Like 'error' but suggests submitting a bug report. +dieHard :: String -> a +dieHard last_wish = do + error $ "************** Panic **************\n" ++ + last_wish ++ + "\nPlease file a bug report at:\n " ++ bug_tracker_url + where + bug_tracker_url = "http://code.google.com/p/scion-lib/issues/list" + +------------------------------------------------------------------------------ +-- * Others \/ Helpers + +data Component + = Library + | Executable String + | File FilePath + deriving (Eq, Show, Typeable) + +-- | Shorthand for 'undefined'. +__ :: a +__ = undefined + +-- * Go To Definition + +-- | A definition site database. +-- +-- This is a map from names to the location of their definition and +-- information about the defined entity. Note that a name may refer to +-- multiple entities. +-- +-- XXX: Currently we use GHC's 'TyThing' data type. However, this probably +-- holds on to a lot of stuff we don't need. It also cannot be serialised +-- directly. The reason it's done this way is that wrapping 'TyThing' leads +-- to a lot of duplicated code. Using a custom type might be useful to have +-- fewer dependencies on the GHC API; however it also creates problems +-- mapping things back into GHC API data structures. If we do this, we +-- should at least remember the 'Unique' in order to quickly look up the +-- original thing. +newtype DefSiteDB = + DefSiteDB (M.Map String [(Location,TyThing)]) + +instance Monoid DefSiteDB where + mempty = emptyDefSiteDB + mappend = unionDefSiteDB + +-- | The empty 'DefSiteDB'. +emptyDefSiteDB :: DefSiteDB +emptyDefSiteDB = DefSiteDB M.empty + +-- | Combine two 'DefSiteDB's. XXX: check for duplicates? +unionDefSiteDB :: DefSiteDB -> DefSiteDB -> DefSiteDB +unionDefSiteDB (DefSiteDB m1) (DefSiteDB m2) = + DefSiteDB (M.unionWith (++) m1 m2) + +-- | Return the list of defined names (the domain) of the 'DefSiteDB'. +-- The result is, in fact, ordered. +definedNames :: DefSiteDB -> [String] +definedNames (DefSiteDB m) = M.keys m + +-- | Returns all the entities that the given name may refer to. +lookupDefSite :: DefSiteDB -> String -> [(Location, TyThing)] +lookupDefSite (DefSiteDB m) key = + case M.lookup key m of + Nothing -> [] + Just xs -> xs + + +-- use this exception for everything else which is not important enough to +-- create a new Exception (kiss) +-- some more Exception types are defined in Session.hs (TODO?) +data ScionError = ScionError String + deriving (Show, Typeable) +instance Exception ScionError where + toException = scionToException + fromException = scionFromException +scionError :: String -> ScionM a +scionError = liftIO . throwIO . ScionError + +-- will be extended in the future +data CabalConfiguration = CabalConfiguration { + distDir :: FilePath, + extraArgs :: [String] -- additional args used to configure the project + } + +type FileComponentConfiguration = + ( FilePath, -- rel filepath to config file + [String] -- set of flags to be used to compile that file + ) + +-- the ScionProjectConfig is a project specific configuration file +-- The syntax must be simple and human readable. One JSON object per line. +-- Example: +-- { 'type' : 'build-configuration', 'dist-dir' : 'dist-custom', 'extra-args' : [ ] } +-- helperf functions see Utils.hs +data ScionProjectConfig = ScionProjectConfig { + buildConfigurations :: [CabalConfiguration], + fileComponentExtraFlags :: [FileComponentConfiguration], + scionDefaultCabalConfig :: Maybe String + } +emptyScionProjectConfig :: ScionProjectConfig +emptyScionProjectConfig = ScionProjectConfig [] [] Nothing diff --git a/lib/Scion/Types/ExtraInstances.hs b/lib/Scion/Types/ExtraInstances.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Types/ExtraInstances.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Scion.Types.ExtraInstances +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@googlemail.com +-- Stability : experimental +-- Portability : portable +-- +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Scion.Types.ExtraInstances where + +import Bag + +import Data.Monoid +import Data.Foldable + +instance Monoid (Bag a) where + mempty = emptyBag + mappend = unionBags + mconcat = unionManyBags + +instance Functor Bag where + fmap = mapBag + +instance Foldable Bag where + foldr = foldrBag + foldl = foldlBag + diff --git a/lib/Scion/Types/Notes.hs b/lib/Scion/Types/Notes.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Types/Notes.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE PatternGuards #-} +-- | +-- Module : Scion.Types.Notes +-- Copyright : (c) Thomas Schilling 2009 +-- License : BSD-style +-- +-- Maintainer : nominolo@googlemail.com +-- Stability : experimental +-- Portability : portable +-- +-- Notes, i.e., warnings, errors, etc. +-- +module Scion.Types.Notes + ( Location, LocSource(..), mkLocation, mkNoLoc + , locSource, isValidLoc, noLocText, viewLoc + , locStartCol, locEndCol, locStartLine, locEndLine + , AbsFilePath(toFilePath), mkAbsFilePath + , Note(..), NoteKind(..), Notes + , ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote + , ghcMessagesToNotes + ) +where + +import qualified ErrUtils as GHC ( ErrMsg(..), WarnMsg, Messages ) +import qualified SrcLoc as GHC +import qualified FastString as GHC ( unpackFS ) +import qualified Outputable as GHC ( showSDoc, ppr, showSDocForUser ) +import qualified Bag ( bagToList ) + +import qualified Data.MultiSet as MS +import System.FilePath + +infixr 9 `thenCmp` + +-- * Notes + +-- | A note from the compiler or some other tool. +data Note + = Note { noteKind :: NoteKind + , noteLoc :: Location + , noteMessage :: String + } deriving (Eq, Ord, Show) + +-- | Classifies the kind (or severity) of a note. +data NoteKind + = ErrorNote + | WarningNote + | InfoNote + | OtherNote + deriving (Eq, Ord, Show) + +type Notes = MS.MultiSet Note + +-- * Absolute File Paths + +-- | Represents a 'FilePath' which we know is absolute. +-- +-- Since relative 'FilePath's depend on the a current working directory we +-- normalise all paths to absolute paths. Use 'mkAbsFilePath' to create +-- absolute file paths. +newtype AbsFilePath = AFP { toFilePath :: FilePath } deriving (Eq, Ord) +instance Show AbsFilePath where show (AFP s) = show s + +-- | Create an absolute file path given a base directory. +-- +-- Throws an error if the first argument is not an absolute path. +mkAbsFilePath :: FilePath -- ^ base directory (must be absolute) + -> FilePath -- ^ absolute or relative + -> AbsFilePath +mkAbsFilePath baseDir dir + | isAbsolute baseDir = AFP $ normalise $ baseDir dir + | otherwise = + error "mkAbsFilePath: first argument must be an absolute path" + +-- * Scion's 'Location' data type + +-- | Scion's type for source code locations (regions). +-- +-- We use a custom location type for two reasons: +-- +-- 1. We enforce the invariant, that the file path of the location is an +-- absolute path. +-- +-- 2. Independent evolution from the GHC API. +-- +-- To save space, the 'Location' type is kept abstract and uses special +-- cases for notes that span only one line or are only one character wide. +-- Use 'mkLocation' and 'viewLoc' as well as the respective accessor +-- functions to construct and destruct nodes. +-- +-- If no reasonable can be given, use the 'mkNoLoc' function, but be careful +-- not to call 'viewLoc' or any other accessor function on such a +-- 'Location'. +-- +data Location + = LocOneLine { + locSource :: LocSource, + locLine :: {-# UNPACK #-} !Int, + locSCol :: {-# UNPACK #-} !Int, + locECol :: {-# UNPACK #-} !Int + } + | LocMultiLine { + locSource :: LocSource, + locSLine :: {-# UNPACK #-} !Int, + locELine :: {-# UNPACK #-} !Int, + locSCol :: {-# UNPACK #-} !Int, + locECol :: {-# UNPACK #-} !Int + } + | LocPoint { + locSource :: LocSource, + locLine :: {-# UNPACK #-} !Int, + locCol :: {-# UNPACK #-} !Int + } + | LocNone { noLocText :: String } + deriving (Eq, Show) + +-- | The \"source\" of a location. +data LocSource + = FileSrc AbsFilePath + -- ^ The location refers to a position in a file. + | OtherSrc String + -- ^ The location refers to something else, e.g., the command line, or + -- stdin. + deriving (Eq, Ord, Show) + +instance Ord Location where compare = cmpLoc + +-- | Construct a source code location from start and end point. +-- +-- If the start point is after the end point, they are swapped +-- automatically. +mkLocation :: LocSource + -> Int -- ^ start line + -> Int -- ^ start column + -> Int -- ^ end line + -> Int -- ^ end column + -> Location +mkLocation file l0 c0 l1 c1 + | l0 > l1 = mkLocation file l1 c0 l0 c1 + | l0 == l1 && c0 > c1 = mkLocation file l0 c1 l1 c0 + | l0 == l1 = if c0 == c1 + then LocPoint file l0 c0 + else LocOneLine file l0 c0 c1 + | otherwise = LocMultiLine file l0 l1 c0 c1 + +-- | Construct a source location that does not specify a region. The +-- argument can be used to give some hint as to why there is no location +-- available. (E.g., \"File not found\"). +mkNoLoc :: String -> Location +mkNoLoc msg = LocNone msg + +-- | Test whether a location is valid, i.e., not constructed with 'mkNoLoc'. +isValidLoc :: Location -> Bool +isValidLoc (LocNone _) = False +isValidLoc _ = True + +noLocError :: String -> a +noLocError f = error $ f ++ ": argument must not be a noLoc" + +-- | Return the start column. Only defined on valid locations. +locStartCol :: Location -> Int +locStartCol l@LocPoint{} = locCol l +locStartCol LocNone{} = noLocError "locStartCol" +locStartCol l = locSCol l + +-- | Return the end column. Only defined on valid locations. +locEndCol :: Location -> Int +locEndCol l@LocPoint{} = locCol l +locEndCol LocNone{} = noLocError "locEndCol" +locEndCol l = locECol l + +-- | Return the start line. Only defined on valid locations. +locStartLine :: Location -> Int +locStartLine l@LocMultiLine{} = locSLine l +locStartLine LocNone{} = noLocError "locStartLine" +locStartLine l = locLine l + +-- | Return the end line. Only defined on valid locations. +locEndLine :: Location -> Int +locEndLine l@LocMultiLine{} = locELine l +locEndLine LocNone{} = noLocError "locEndLine" +locEndLine l = locLine l + +{-# INLINE viewLoc #-} +-- | View on a (valid) location. +-- +-- It holds the property: +-- +-- > prop_viewLoc_mkLoc s l0 c0 l1 c1 = +-- > viewLoc (mkLocation s l0 c0 l1 c1) == (s, l0, c0, l1, c1) +-- +viewLoc :: Location + -> (LocSource, Int, Int, Int, Int) + -- ^ source, start line, start column, end line, end column. +viewLoc l = (locSource l, locStartLine l, locStartCol l, + locEndLine l, locEndCol l) + +-- | Comparison function for two 'Location's. +cmpLoc :: Location -> Location -> Ordering +cmpLoc LocNone{} _ = LT +cmpLoc _ LocNone{} = GT +cmpLoc l1 l2 = + (f1 `compare` f2) `thenCmp` + (sl1 `compare` sl2) `thenCmp` + (sc1 `compare` sc2) `thenCmp` + (el1 `compare` el2) `thenCmp` + (ec1 `compare` ec2) + where + (f1, sl1, sc1, el1, ec1) = viewLoc l1 + (f2, sl2, sc2, el2, ec2) = viewLoc l2 + +-- | Lexicographic composition two orderings. Compare using the first +-- ordering, use the second to break ties. +thenCmp :: Ordering -> Ordering -> Ordering +thenCmp EQ x = x +thenCmp x _ = x +{-# INLINE thenCmp #-} + +-- * Converting from GHC types. + +-- | Convert a 'GHC.SrcSpan' to a 'Location'. +-- +-- The first argument is used to normalise relative source locations to an +-- absolute file path. +ghcSpanToLocation :: FilePath -- ^ Base directory + -> GHC.SrcSpan + -> Location +ghcSpanToLocation baseDir sp + | GHC.isGoodSrcSpan sp = + mkLocation mkLocFile + (GHC.srcSpanStartLine sp) + (GHC.srcSpanStartCol sp) + (GHC.srcSpanEndLine sp) + (GHC.srcSpanEndCol sp) + | otherwise = + mkNoLoc (GHC.showSDoc (GHC.ppr sp)) + where + mkLocFile = + case GHC.unpackFS (GHC.srcSpanFile sp) of + s@('<':_) -> OtherSrc s + p -> FileSrc $ mkAbsFilePath baseDir p + +ghcErrMsgToNote :: FilePath -> GHC.ErrMsg -> Note +ghcErrMsgToNote = ghcMsgToNote ErrorNote + +ghcWarnMsgToNote :: FilePath -> GHC.WarnMsg -> Note +ghcWarnMsgToNote = ghcMsgToNote WarningNote + +-- Note that we don *not* include the extra info, since that information is +-- only useful in the case where we don not show the error location directly +-- in the source. +ghcMsgToNote :: NoteKind -> FilePath -> GHC.ErrMsg -> Note +ghcMsgToNote note_kind base_dir msg = + Note { noteLoc = ghcSpanToLocation base_dir loc + , noteKind = note_kind + , noteMessage = show_msg (GHC.errMsgShortDoc msg) + } + where + loc | (s:_) <- GHC.errMsgSpans msg = s + | otherwise = GHC.noSrcSpan + unqual = GHC.errMsgContext msg + show_msg = GHC.showSDocForUser unqual + +-- | Convert 'GHC.Messages' to 'Notes'. +-- +-- This will mix warnings and errors, but you can split them back up +-- by filtering the 'Notes' based on the 'noteKind'. +ghcMessagesToNotes :: FilePath -- ^ Base path for normalising paths. + -- See 'mkAbsFilePath'. + -> GHC.Messages -> Notes +ghcMessagesToNotes base_dir (warns, errs) = + MS.union (map_bag2ms (ghcWarnMsgToNote base_dir) warns) + (map_bag2ms (ghcErrMsgToNote base_dir) errs) + where + map_bag2ms f = MS.fromList . map f . Bag.bagToList diff --git a/lib/Scion/Utils.hs b/lib/Scion/Utils.hs new file mode 100644 --- /dev/null +++ b/lib/Scion/Utils.hs @@ -0,0 +1,189 @@ +{-# OPTIONS_GHC -fno-warn-orphans -XPatternGuards #-} +-- | +-- Module : Scion.Utils +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Various utilities. +-- +module Scion.Utils where + +import Scion.Types + +import GHC ( GhcMonad, ModSummary, spans, getLoc, Located + , depanal, topSortModuleGraph, TypecheckedMod + , mkPrintUnqualifiedForModule, moduleInfo ) +import Digraph ( flattenSCCs ) +import Outputable + +import Control.Monad +import Data.Maybe ( fromMaybe ) + +import Data.Char (isLower, isUpper) + +import Text.JSON + +import Data.Foldable (foldlM) + +import System.FilePath + +import System.Directory (doesFileExist) + +import System.IO (openFile, hPutStrLn, hClose, IOMode(..)) + +import Data.List (isPrefixOf) + +thingsAroundPoint :: (Int, Int) -> [Located n] -> [Located n] +thingsAroundPoint pt ls = [ l | l <- ls, spans (getLoc l) pt ] + +modulesInDepOrder :: GhcMonad m => m [ModSummary] +modulesInDepOrder = do + gr <- depanal [] False + return $ flattenSCCs $ topSortModuleGraph False gr Nothing + +-- in dep-order +foldModSummaries :: GhcMonad m => + (a -> ModSummary -> m a) -> a + -> m a +foldModSummaries f seed = + modulesInDepOrder >>= foldM f seed + + +expectJust :: String -> Maybe a -> a +expectJust _ (Just a) = a +expectJust msg Nothing = + dieHard $ "Just x expected.\n grep for \"" ++ msg ++ "\"" + +unqualifiedForModule :: TypecheckedMod m => m -> ScionM PrintUnqualified +unqualifiedForModule tcm = do + fromMaybe alwaysQualify `fmap` mkPrintUnqualifiedForModule (moduleInfo tcm) + +second :: (a -> b) -> (c, a) -> (c, b) +second f (x,y) = (x, f y) + +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM cm tm em = do + c <- cm + if c then tm else em + + +------------------------------------------------------------------------ +-- JSON helper functions + +lookupKey :: JSON a => JSObject JSValue -> String -> Result a +lookupKey = flip valFromObj + +makeObject :: [(String, JSValue)] -> JSValue +makeObject = makeObj + +------------------------------------------------------------------------------ + + +-- an alternative to the broken Fuzzy module +-- match sH simpleHTTP +-- match siH simpleHTTP +-- match sHTTP simpleHTTP +-- match pSL putStrLn +-- match lM liftM +-- match DS Data.Set +camelCaseMatch :: String -> String -> Bool +camelCaseMatch (c:cs) (i:is) + | c == i = (camelCaseMatch cs $ dropWhile (\c' -> isLower c' || c' == '.') . dropWhile isUpper $ is) + || camelCaseMatch cs is -- to allow siH match simpleHTTP + | otherwise = False +camelCaseMatch [] [] = True +camelCaseMatch [] _ = False +camelCaseMatch _ [] = False + + +instance JSON CabalConfiguration where + readJSON (JSObject obj) + | Ok "build-configuration" <- lookupKey obj "type" + , Ok distDir' <- lookupKey obj "dist-dir" + , Ok args <- lookupKey obj "extra-args" + , Ok args2 <- readJSONs args + = return $ CabalConfiguration distDir' args2 + readJSON _ = fail "CabalConfiguration" + showJSON (CabalConfiguration dd ea) = makeObject [ + ("dist-dir", JSString (toJSString dd)) + , ("extra-args", JSArray (map (JSString . toJSString) ea)) ] + + +data ScionDefaultCabalConfig = ScionDefaultCabalConfig String +instance JSON ScionDefaultCabalConfig where + readJSON (JSObject obj) + | Ok s <- lookupKey obj "scion-default-cabal-config" + = return $ ScionDefaultCabalConfig s + readJSON _ = fail "ScionDefaultCabalConfig" + showJSON (ScionDefaultCabalConfig s) = makeObject $ [ ("scion-default-cabal-config", (JSString . toJSString) s) ] + +readFileComponentConfig :: JSValue -> Result (String, [String]) + +readFileComponentConfig (JSObject obj) + | Ok "component-file" <- lookupKey obj "type" + , Ok file <- lookupKey obj "file" + , Ok args <- lookupKey obj "flags" + , Ok args2 <- readJSONs args + = return (file, args2) +readFileComponentConfig _ = fail "reading component-file config" + +projectConfigFileFromDir :: FilePath -> FilePath +projectConfigFileFromDir = ( ".scion-config") +projectConfigFromDir :: FilePath -> ScionM ScionProjectConfig +projectConfigFromDir = parseScionProjectConfig . projectConfigFileFromDir + +-- If the file exists append. Deleting settings you don't need is faster than looking them up.. +-- So let's extend this creating a complete reference? +-- Maybe we can even add flags from the cabal file automatically ? +writeSampleConfig :: FilePath -> IO () +writeSampleConfig file = do + h <- openFile file AppendMode + hPutStrLn h $ "\n" ++ unlines [ + "// this is a demo scion project configuration file has been created for you" + ,"// you can use it to write down a set of configurations you'd like to test" + ,"//" + ,"// make scion select the default scion entry" + ,"{\"scion-default-cabal-config\":\"dist-scion\"}" + ,"// default scion entry:" + ,"{\"type\":\"build-configuration\", \"dist-dir\":\"dist-scion\", \"extra-args\": [], \"scion-default\": 1}" + ,"//" + ,"// some examples:" + ,"{\"type\":\"build-configuration\", \"dist-dir\":\"dist-demo-simple-tools-from-path-default\", \"extra-args\": []}" + ,"{\"type\":\"build-configuration\", \"dist-dir\":\"dist-demo-1\", \"extra-args\": [\"--with-hc-pkg=PATH\", \"--with-compiler=path-to-ghc\"]}" + ,"{\"type\":\"build-configuration\", \"dist-dir\":\"dist-demo-2\", \"extra-args\": [\"--flags=BuildTestXHTML BuildTestSimple\", \"--disable-library-profiling\"]}" + ,"//" + ,"{\"type\":\"component-file\", \"file\": \"test-application.hs\", \"flags\":[\"-package\", \"parsec\"]}" + ,"{\"type\":\"component-file\", \"file\": \"test-application.hs\", \"flags\":[]}" + ] + hClose h + +-- TODO ensure file handle is closed! +-- the format of this file will change when scion matures.. +-- However it's a quick and easy way for scion, the client and users to read and write the config +parseScionProjectConfig :: FilePath -> ScionM ScionProjectConfig +parseScionProjectConfig path = do + de <- liftIO $ doesFileExist path + if de + then do + lines' <- liftIO $ liftM ( filter (not . isPrefixOf "//") . lines) $ readFile path + jsonParsed <- mapM parseLine lines' + foldlM parseJSON emptyScionProjectConfig jsonParsed + else return emptyScionProjectConfig + where + parseLine :: String -> ScionM JSValue + parseLine l = case decodeStrict l of + Ok r -> return r + Error msg -> scionError $ "error parsing configuration line" ++ (show l) ++ " error : " ++ msg + parseJSON :: ScionProjectConfig -> JSValue -> ScionM ScionProjectConfig + parseJSON pc json = case readJSON json of + Ok bc -> return $ pc { buildConfigurations = bc : buildConfigurations pc } + Error msg1 -> case readFileComponentConfig json of + Ok cf -> return $ pc { fileComponentExtraFlags = cf : fileComponentExtraFlags pc } + Error msg2 -> case readJSON json of + Ok (ScionDefaultCabalConfig name) -> return $ pc { scionDefaultCabalConfig = Just name } + Error msg3 -> scionError $ "invalid JSON object " ++ (show json) ++ " error :" ++ msg1 ++ "\n" ++ msg2 ++ "\n" ++ msg3 + diff --git a/scion.cabal b/scion.cabal new file mode 100644 --- /dev/null +++ b/scion.cabal @@ -0,0 +1,147 @@ +name: scion +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Thomas Schilling +maintainer: Thomas Schilling +homepage: http://github.com/nominolo/scion +synopsis: Haskell IDE library +description: + Scion is a Haskell library that aims to implement those parts of a + Haskell IDE which are independent of a particular front-end. Scion + is based on the GHC API and Cabal. It provides both a Haskell API and + a server for non-Haskell clients such as Emacs and Vim. + . + See the homepage (http://code.google.com/p/scion-lib/) and the + README + (http://github.com/nominolo/scion/blob/master/README.markdown) for + more information. + +category: Development +stability: provisional +build-type: Simple +cabal-version: >= 1.6 +extra-source-files: README.markdown +data-files: + emacs/*.el + vim_runtime_path/autoload/*.vim + vim_runtime_path/ftplugin/*.vim + vim_runtime_path/plugin/*.vim + +flag testing + description: Enable Debugging things like QuickCheck properties, etc. + default: False + +flag server + description: Install the scion-server. + default: True + +library + build-depends: + base == 4.*, + Cabal >= 1.5 && < 1.7, + containers == 0.2.*, + directory == 1.0.*, + filepath == 1.1.*, + ghc >= 6.10 && < 6.12, + ghc-paths == 0.1.*, + ghc-syb == 0.1.*, + hslogger == 1.0.*, + json == 0.4.*, + multiset == 0.1.*, + time == 1.1.*, + uniplate == 1.2.* + + hs-source-dirs: lib + extensions: CPP, PatternGuards + exposed-modules: + Scion.Types, + Scion.Types.ExtraInstances, + Scion.Types.Notes, + Scion.Inspect, + Scion.Inspect.Find, + Scion.Inspect.TypeOf, + Scion.Inspect.DefinitionSite, + Scion.Utils, + Scion.Session, + Scion.Configure, + Scion + + if flag(testing) + build-depends: QuickCheck == 2.* + cpp-options: -DDEBUG + + if impl(ghc > 6.11) + cpp-options: -DHAVE_PACKAGE_DB_MODULES + + -- TODO: drop after 6.10.2 is out + if impl(ghc >= 6.11.20081113) || impl(ghc >= 6.10.2 && < 6.11) + cpp-options: -DRECOMPILE_BUG_FIXED + + if impl(ghc == 6.10.*) + cpp-options: -DWPINLINE + + ghc-options: -Wall + +executable scion-server + if !flag(server) + buildable: False + + main-is: Main.hs + hs-source-dirs: lib server + + build-depends: + -- From the library: + base == 4.*, + Cabal >= 1.5 && < 1.7, + containers == 0.2.*, + directory == 1.0.*, + filepath == 1.1.*, + ghc >= 6.10 && < 6.12, + ghc-paths == 0.1.*, + ghc-syb == 0.1.*, + hslogger == 1.0.*, + json == 0.4.*, + multiset == 0.1.*, + time == 1.1.* + + if flag(server) + build-depends: + -- Server only + bytestring == 0.9.*, + network >= 2.1 && < 2.3, + network-bytestring == 0.1.*, + utf8-string == 0.3.* + + other-modules: + Scion + Scion.Configure + Scion.Inspect + Scion.Inspect.DefinitionSite + Scion.Session + Scion.Types + Scion.Types.Notes + Scion.Utils + + Scion.Server.Commands + Scion.Server.ConnectionIO + Scion.Server.Generic + Scion.Server.Protocol + + ghc-options: -Wall + extensions: CPP, PatternGuards + + if flag(testing) + build-depends: QuickCheck == 2.* + cpp-options: -DDEBUG + + if impl(ghc > 6.11) + cpp-options: -DHAVE_PACKAGE_DB_MODULES + + -- TODO: drop after 6.10.2 is out + if impl(ghc >= 6.11.20081113) || impl(ghc >= 6.10.2 && < 6.11) + cpp-options: -DRECOMPILE_BUG_FIXED + + if impl(ghc == 6.10.*) + cpp-options: -DWPINLINE + diff --git a/server/Main.hs b/server/Main.hs new file mode 100644 --- /dev/null +++ b/server/Main.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, ScopedTypeVariables, + TypeFamilies, PatternGuards, CPP #-} +{-# OPTIONS_GHC -Wall #-} +-- | +-- Module : Scion.Server.Emacs +-- License : BSD-style +-- +-- Maintainer : marco-oweber@gmx.de +-- Stability : pre-alpha +-- Portability : portable +-- +-- An example server which will talk to different backends +-- The first handshake is done this way: +-- The client sends : "select scion-server protocol: name version" +-- where name and version specify the protocol to be used. +-- the server replies in any case by either +-- "ok\n" or "failure : message\n" +-- From then on the specific protocol handler takes over control +-- +-- multiple connections to the same server are not yet supported +-- because I don't know yet in detail when ghc api calls can be made +-- concurrently.. Maybe using an MVar is an option (TODO) + +module Main where + +import MonadUtils ( liftIO ) +import Scion.Server.Generic as Gen +--import qualified Scion.Server.ProtocolEmacs as Emacs +import qualified Scion.Server.ConnectionIO as CIO +import Scion (runScion) + + +import Prelude hiding ( log ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitSuccess) +import System.IO (stdin, stdout, hSetBuffering, hFlush, BufferMode(..)) +import qualified System.Log.Logger as HL +import qualified System.Log.Handler.Simple as HL +import qualified System.Log.Handler.Syslog as HL +import qualified Data.ByteString.Lazy.Char8 as S +import Network ( listenOn, PortID(..) ) +import Network.Socket hiding (send, sendTo, recv, recvFrom) +import Network.Socket.ByteString +import Data.List (isPrefixOf, break) +import Data.Foldable (foldrM) +import qualified Control.Exception as E +import Control.Monad ( when, forever, liftM ) +import System.Console.GetOpt + + +log = HL.logM __FILE__ +logInfo = log HL.INFO +logDebug = log HL.DEBUG +logError = log HL.ERROR + +-- how should the client connect to the server? +-- if you're paranoid about your code Socketfile or StdInOut +-- will be the most secure choice.. (Everyone can connect via TCP/IP at the +-- moment) +data ConnectionMode = TCPIP Bool PortNumber -- the Bool indicates whether to scan + | StdInOut +#ifndef mingw32_HOST_OS + | Socketfile FilePath +#endif + deriving Show + +data StartupConfig = StartupConfig { + connectionMode :: ConnectionMode, + autoPort :: Bool, + showHelp :: Bool + } deriving Show +defaultPort = 4005 +defaultStartupConfig = StartupConfig (TCPIP False (fromInteger defaultPort)) False False + +options :: [OptDescr (StartupConfig -> IO StartupConfig)] +options = + [ Option ['p'] ["port"] + (ReqArg (\o opts -> return $ opts { connectionMode = (TCPIP False . fromInteger) (read o) }) (show defaultPort)) + "listen on this TCP port" + , Option ['a'] ["autoport"] + (NoArg (\opts -> return $ opts { autoPort = True })) + "scan until a free TCP port is found" + , Option ['i'] ["stdinout"] + (NoArg (\opts -> return $ opts { connectionMode = StdInOut})) + "client must connect to stdin and stdout" +#ifndef mingw32_HOST_OS + , Option ['s'] ["socketfile"] + (ReqArg (\o opts -> return $ opts { connectionMode = Socketfile o}) + "/tmp/scion-io") + "listen on this socketfile" +#endif + , Option ['h'] ["help"] (NoArg (\opts -> return $ opts { showHelp = True } )) + "show this help" + + , Option ['f'] ["log-file"] (ReqArg (\f opts -> do + fh <- HL.fileHandler f HL.DEBUG + HL.updateGlobalLogger "" (HL.addHandler fh) + return opts ) "/tmp/scion-log") "log to the given file" + ] + +initializeLogging = do + -- by default log everything to stdout + HL.updateGlobalLogger "" (HL.setLevel HL.DEBUG) + +helpText = do + pN <- getProgName + let header = unlines [ "usage of scion server (executable :" ++ pN ++ ")" ] + return $ usageInfo header options + +-- attempts to listen on each port in the list in turn, and returns the first successful +listenOnOneOf :: [PortID] -> IO Socket +listenOnOneOf (p:ps) = catch + (listenOn p) + (\(ex :: IOError) -> if null ps then E.throwIO ex else listenOnOneOf ps) + +-- this way, we can iterate until we find a free port number +instance Bounded PortNumber where + minBound = 0 + maxBound = 0xFFFF + +serve :: ConnectionMode -> IO () +serve (TCPIP auto nr) = do + sock <- liftIO $ if auto + then listenOnOneOf (map PortNumber [nr..maxBound]) + else listenOn (PortNumber nr) + realNr <- liftIO $ socketPort sock + putStrLn $ "=== Listening on port: " ++ show realNr + hFlush stdout + let run True = return () + run _ = + E.handle (\(e::E.IOException) -> do + logInfo ("caught :" ++ (show e) ++ "\n\nwaiting for next client") + run False) $ do + (sock', _addr) <- liftIO $ accept sock + sock_conn <- CIO.mkSocketConnection sock' + stop_server <- handleClient sock_conn + run stop_server + run False +serve StdInOut = do + hSetBuffering stdout LineBuffering + hSetBuffering stdin LineBuffering + _ <- handleClient (stdin, stdout) + return () +#ifndef mingw32_HOST_OS +serve (Socketfile file) = do + sock <- liftIO $ listenOn (UnixSocket file) + let run True = return () + run _ = + E.handle (\(e::E.IOException) -> do + logInfo ("caught :" ++ (show e) ++ "\n\nwaiting for next client") + run False) $ do + (sock', _addr) <- liftIO $ accept sock + sock_conn <- CIO.mkSocketConnection sock' + stop_server <- handleClient sock_conn + run stop_server + run False +#endif + +-- does the handshaking and then runs the protocol implementation +handleClient :: (CIO.ConnectionIO con) => con -> IO Bool +handleClient con = do + runScion $ Gen.handle con 0 + +fixConfig :: StartupConfig -> StartupConfig +fixConfig conf = case connectionMode conf of + TCPIP _ nr -> conf { connectionMode = TCPIP (autoPort conf) nr } + otherwise -> conf + +main :: IO () +main = do + + -- logging + initializeLogging + + -- cmd opts + (opts, nonOpts, _err_msgs) <- fmap (getOpt Permute options) getArgs + + when ((not . null) nonOpts) $ + logError $ "no additional arguments expected, got: " ++ (show nonOpts) + + startupConfig <- return . fixConfig =<< foldrM ($) defaultStartupConfig opts + + -- help + when (showHelp startupConfig) $ helpText >>= putStrLn >> exitSuccess + + -- start server + logInfo "starting server" + -- E.handle (\(e :: SomeException) -> "shutting down server due to exception " ++ show e) $ + do + log HL.DEBUG $ "opts: " ++ (show startupConfig) + serve (connectionMode startupConfig) diff --git a/server/Scion/Server/Commands.hs b/server/Scion/Server/Commands.hs new file mode 100644 --- /dev/null +++ b/server/Scion/Server/Commands.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards, + ExistentialQuantification #-} -- for 'Cmd' +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Scion.Server.Commands +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Commands provided by the server. +-- +-- TODO: Need some way to document the wire protocol. Autogenerate? +-- +module Scion.Server.Commands ( + handleRequest, malformedRequest, -- allCommands, allCommands', + -- these are reused in the vim interface + supportedPragmas, allExposedModules, +) where + +import Prelude as P +import Scion.Types +import Scion.Types.Notes +import Scion.Utils +import Scion.Session +import Scion.Server.Protocol +import Scion.Inspect +import Scion.Inspect.DefinitionSite +import Scion.Configure + +import DynFlags ( supportedLanguages, allFlags ) +import Exception +import FastString +import GHC +import PprTyThing ( pprTypeForUser ) +import Outputable ( ppr, showSDoc, showSDocDump, dcolon, showSDocForUser, + showSDocDebug ) +import qualified Outputable as O ( (<+>), ($$) ) + +import Control.Applicative +import Control.Monad +import Data.List ( nub ) +import Data.Time.Clock ( NominalDiffTime ) +import System.Exit ( ExitCode(..) ) +import Text.JSON +import qualified Data.Map as M +import qualified Data.MultiSet as MS + +import Distribution.Text ( display ) +import qualified Distribution.PackageDescription as PD +import GHC.SYB.Utils + +#ifndef HAVE_PACKAGE_DB_MODULES +import UniqFM ( eltsUFM ) +import Packages ( pkgIdMap ) + +import Distribution.InstalledPackageInfo +#endif + +type KeepGoing = Bool + +-- a scion request is JS object with 3 keys: +-- method: the method to be called +-- params: arguments to be passed +-- id : this value will be passed back to the client +-- to identify a reply to a specific request +-- asynchronous requests will be implemented in the future +handleRequest :: JSValue -> ScionM (JSValue, KeepGoing) +handleRequest (JSObject req) = + let request = do JSString method <- lookupKey req "method" + params <- lookupKey req "params" + seq_id <- lookupKey req "id" + return (fromJSString method, params, seq_id) + in + case request of + Error _ -> return (malformedRequest, True) + Ok (method, params, seq_id) + | method == "quit" -> return (makeObject + [("version", str "0.1") + ,("result", JSNull) + ,("id", seq_id)], False) + | otherwise -> + case M.lookup method allCmds of + Nothing -> return (unknownCommand seq_id, True) + Just (Cmd _ arg_parser) -> + decode_params params arg_parser seq_id + where + decode_params JSNull arg_parser seq_id = + decode_params (makeObject []) arg_parser seq_id + decode_params (JSObject args) arg_parser seq_id = + case unPa arg_parser args of + Left err -> return (paramParseError seq_id err, True) + Right act -> do + r <- handleScionException act + case r of + Error msg -> return (commandExecError seq_id msg, True) + Ok a -> + return (makeObject + [("version", str "0.1") + ,("id", seq_id) + ,("result", showJSON a)], True) + decode_params _ _ seq_id = + return (paramParseError seq_id "Params not an object", True) + +handleRequest _ = do + return (malformedRequest, True) + +malformedRequest :: JSValue +malformedRequest = makeObject + [("version", str "0.1") + ,("error", makeObject + [("name", str "MalformedRequest") + ,("message", str "Request was not a proper request object.")])] + +unknownCommand :: JSValue -> JSValue +unknownCommand seq_id = makeObject + [("version", str "0.1") + ,("id", seq_id) + ,("error", makeObject + [("name", str "UnknownCommand") + ,("message", str "The requested method is not supported.")])] + +paramParseError :: JSValue -> String -> JSValue +paramParseError seq_id msg = makeObject + [("version", str "0.1") + ,("id", seq_id) + ,("error", makeObject + [("name", str "ParamParseError") + ,("message", str msg)])] + +commandExecError :: JSValue -> String -> JSValue +commandExecError seq_id msg = makeObject + [("version", str "0.1") + ,("id", seq_id) + ,("error", makeObject + [("name", str "CommandFailed") + ,("message", str msg)])] + +allCmds :: M.Map String Cmd +allCmds = M.fromList [ (cmdName c, c) | c <- allCommands ] + +------------------------------------------------------------------------ + +-- | All Commands supported by this Server. +allCommands :: [Cmd] +allCommands = + [ cmdConnectionInfo + , cmdOpenCabalProject + , cmdConfigureCabalProject + , cmdLoadComponent + , cmdListSupportedLanguages + , cmdListSupportedPragmas + , cmdListSupportedFlags + , cmdListCabalComponents + , cmdListCabalConfigurations + , cmdWriteSampleConfig + , cmdListRdrNamesInScope + , cmdListExposedModules + , cmdCurrentComponent + , cmdCurrentCabalFile + , cmdSetVerbosity + , cmdGetVerbosity + , cmdLoad + , cmdDumpSources + , cmdThingAtPoint + , cmdSetGHCVerbosity + , cmdBackgroundTypecheckFile + , cmdAddCmdLineFlag + , cmdForceUnload + , cmdDumpDefinedNames + , cmdDefinedNames + , cmdNameDefinitions + , cmdIdentify + ] + +------------------------------------------------------------------------------ + +type OkErr a = Result a + +-- encode expected errors as proper return values +handleScionException :: ScionM a -> ScionM (OkErr a) +handleScionException m = ((((do + r <- m + return (Ok r) + `gcatch` \(e :: SomeScionException) -> return (Error (show e))) + `gcatch` \(e' :: GhcException) -> + case e' of + Panic _ -> throw e' + InstallationError _ -> throw e' + Interrupted -> throw e' + _ -> return (Error (show e'))) + `gcatch` \(e :: ExitCode) -> + -- client code may not exit the server! + return (Error (show e))) + `gcatch` \(e :: IOError) -> + return (Error (show e))) +-- `gcatch` \(e :: SomeException) -> +-- liftIO (print e) >> liftIO (throwIO e) + +------------------------------------------------------------------------------ + +newtype Pa a = Pa { unPa :: JSObject JSValue -> Either String a } +instance Monad Pa where + return x = Pa $ \_ -> Right x + m >>= k = Pa $ \req -> + case unPa m req of + Left err -> Left err + Right a -> unPa (k a) req + fail msg = Pa $ \_ -> Left msg + +withReq :: (JSObject JSValue -> Pa a) -> Pa a +withReq f = Pa $ \req -> unPa (f req) req + +reqArg' :: JSON a => String -> (a -> b) -> (b -> r) -> Pa r +reqArg' name trans f = withReq $ \req -> + case lookupKey req name of + Error _ -> fail $ "required arg missing: " ++ name + Ok x -> + case readJSON x of + Error m -> fail $ "could not decode: " ++ name ++ " - " ++ m + Ok a -> return (f (trans a)) + +optArg' :: JSON a => String -> b -> (a -> b) -> (b -> r) -> Pa r +optArg' name dflt trans f = withReq $ \req -> + case lookupKey req name of + Error _ -> return (f dflt) + Ok x -> + case readJSON x of + Error n -> fail $ "could not decode: " ++ name ++ " - " ++ n + Ok a -> return (f (trans a)) + +reqArg :: JSON a => String -> (a -> r) -> Pa r +reqArg name f = reqArg' name id f + +optArg :: JSON a => String -> a -> (a -> r) -> Pa r +optArg name dflt f = optArg' name dflt id f + +noArgs :: r -> Pa r +noArgs = return + +infixr 1 <&> + +-- | Combine two arguments. +-- +-- TODO: explain type +(<&>) :: (a -> Pa b) + -> (b -> Pa c) + -> a -> Pa c +a1 <&> a2 = \f -> do f' <- a1 f; a2 f' + +data Cmd = forall a. JSON a => Cmd String (Pa (ScionM a)) + +cmdName :: Cmd -> String +cmdName (Cmd n _) = n + +------------------------------------------------------------------------ + +-- | Used by the client to initialise the connection. +cmdConnectionInfo :: Cmd +cmdConnectionInfo = Cmd "connection-info" $ noArgs worker + where + worker = let pid = 0 :: Int in -- TODO for linux: System.Posix.Internals (c_getpid) + return $ makeObject + [("version", showJSON scionVersion) + ,("pid", showJSON pid)] + +cmdOpenCabalProject :: Cmd +cmdOpenCabalProject = + Cmd "open-cabal-project" $ + reqArg' "root-dir" fromJSString <&> + optArg' "dist-dir" ".dist-scion" fromJSString <&> + optArg' "extra-args" [] decodeExtraArgs $ worker + where + worker root_dir dist_dir extra_args = do + openOrConfigureCabalProject root_dir dist_dir extra_args + preprocessPackage dist_dir + (toJSString . display . PD.package) `fmap` currentCabalPackage + +cmdConfigureCabalProject :: Cmd +cmdConfigureCabalProject = + Cmd "configure-cabal-project" $ + reqArg' "root-dir" fromJSString <&> + optArg' "dist-dir" ".dist-scion" fromJSString <&> + optArg' "extra-args" [] decodeExtraArgs $ cmd + where + cmd path rel_dist extra_args = do + configureCabalProject path rel_dist extra_args + preprocessPackage rel_dist + (toJSString . display . PD.package) `fmap` currentCabalPackage + +decodeBool :: JSValue -> Bool +decodeBool (JSBool b) = b +decodeBool _ = error "no bool" + +decodeExtraArgs :: JSValue -> [String] +decodeExtraArgs JSNull = [] +decodeExtraArgs (JSString s) = + words (fromJSString s) -- TODO: check shell-escaping +decodeExtraArgs (JSArray arr) = + [ fromJSString s | JSString s <- arr ] + +instance JSON Component where + readJSON (JSObject obj) + | Ok JSNull <- lookupKey obj "library" = return Library + | Ok s <- lookupKey obj "executable" = + return $ Executable (fromJSString s) + | Ok s <- lookupKey obj "file" = + return $ File (fromJSString s) + readJSON _ = fail "component" + + showJSON Library = makeObject [("library", JSNull)] + showJSON (Executable n) = + makeObject [("executable", JSString (toJSString n))] + showJSON (File n) = + makeObject [("file", JSString (toJSString n))] + +instance JSON CompilationResult where + showJSON (CompilationResult suc notes time) = + makeObject [("succeeded", JSBool suc) + ,("notes", showJSON notes) + ,("duration", showJSON time)] + readJSON (JSObject obj) = do + JSBool suc <- lookupKey obj "succeeded" + notes <- readJSON =<< lookupKey obj "notes" + dur <- readJSON =<< lookupKey obj "duration" + return (CompilationResult suc notes dur) + readJSON _ = fail "compilation-result" + +instance (Ord a, JSON a) => JSON (MS.MultiSet a) where + showJSON ms = showJSON (MS.toList ms) + readJSON o = MS.fromList <$> readJSON o + +instance JSON Note where + showJSON (Note note_kind loc msg) = + makeObject [("kind", showJSON note_kind) + ,("location", showJSON loc) + ,("message", JSString (toJSString msg))] + readJSON (JSObject obj) = do + note_kind <- readJSON =<< lookupKey obj "kind" + loc <- readJSON =<< lookupKey obj "location" + JSString s <- lookupKey obj "message" + return (Note note_kind loc (fromJSString s)) + readJSON _ = fail "note" + +str :: String -> JSValue +str = JSString . toJSString + +instance JSON NoteKind where + showJSON ErrorNote = JSString (toJSString "error") + showJSON WarningNote = JSString (toJSString "warning") + showJSON InfoNote = JSString (toJSString "info") + showJSON OtherNote = JSString (toJSString "other") + readJSON (JSString s) = + case lookup (fromJSString s) + [("error", ErrorNote), ("warning", WarningNote) + ,("info", InfoNote), ("other", OtherNote)] + of Just x -> return x + Nothing -> fail "note-kind" + readJSON _ = fail "note-kind" + +instance JSON Location where + showJSON loc | not (isValidLoc loc) = + makeObject [("no-location", str (noLocText loc))] + showJSON loc | (src, l0, c0, l1, c1) <- viewLoc loc = + makeObject [case src of + FileSrc f -> ("file", str (toFilePath f)) + OtherSrc s -> ("other", str s) + ,("region", JSArray (map showJSON [l0,c0,l1,c1]))] + readJSON (JSObject obj) = do + src <- (do JSString f <- lookupKey obj "file" + return (FileSrc (mkAbsFilePath "/" (fromJSString f)))) + <|> + (do JSString s <- lookupKey obj "other" + return (OtherSrc (fromJSString s))) + JSArray ls <- lookupKey obj "region" + case mapM readJSON ls of + Ok [l0,c0,l1,c1] -> return (mkLocation src l0 c0 l1 c1) + _ -> fail "region" + readJSON _ = fail "location" + +instance JSON NominalDiffTime where + showJSON t = JSRational True (fromRational (toRational t)) + readJSON (JSRational _ n) = return $ fromRational (toRational n) + readJSON _ = fail "diff-time" + +cmdLoadComponent :: Cmd +cmdLoadComponent = + Cmd "load-component" $ + reqArg "component" $ cmd + where + cmd comp = do + loadComponent comp + +instance Sexp CompilationResult where + toSexp (CompilationResult success notes time) = toSexp $ + ExactSexp $ parens $ + showString "compilation-result" <+> + toSexp success <+> + toSexp notes <+> + toSexp (ExactSexp (showString (show + (fromRational (toRational time) :: Float)))) + +cmdListSupportedLanguages :: Cmd +cmdListSupportedLanguages = Cmd "list-supported-languages" $ noArgs cmd + where cmd = return (map toJSString supportedLanguages) + +cmdListSupportedPragmas :: Cmd +cmdListSupportedPragmas = + Cmd "list-supported-pragmas" $ noArgs $ return supportedPragmas + +supportedPragmas :: [String] +supportedPragmas = + [ "OPTIONS_GHC", "LANGUAGE", "INCLUDE", "WARNING", "DEPRECATED" + , "INLINE", "NOINLINE", "RULES", "SPECIALIZE", "UNPACK", "SOURCE" + , "SCC" + , "LINE" -- XXX: only used by code generators, still include? + ] + +cmdListSupportedFlags :: Cmd +cmdListSupportedFlags = + Cmd "list-supported-flags" $ noArgs $ return (nub allFlags) + +cmdListRdrNamesInScope :: Cmd +cmdListRdrNamesInScope = + Cmd "list-rdr-names-in-scope" $ noArgs $ cmd + where cmd = do + rdr_names <- getNamesInScope + return (map (showSDoc . ppr) rdr_names) + +-- FIXME: we want the results from a configured cabal file dist/ * because +-- some components may be skipped due to compilation flags (buildable : False) ? +cmdListCabalComponents :: Cmd +cmdListCabalComponents = + Cmd "list-cabal-components" $ reqArg' "cabal-file" fromJSString $ cmd + where cmd cabal_file = cabalProjectComponents cabal_file + +-- return all cabal configurations. +-- currently this just globs for * /setup-config +-- in the future you may write a config file describing the most common configuration settings +cmdListCabalConfigurations :: Cmd +cmdListCabalConfigurations = + Cmd "list-cabal-configurations" $ + reqArg' "cabal-file" fromJSString <&> + optArg' "type" "uniq" id <&> + optArg' "scion-default" False decodeBool $ cmd + where cmd cabal_file type' scionDefault = liftM showJSON $ cabalConfigurations cabal_file type' scionDefault + +cmdWriteSampleConfig :: Cmd +cmdWriteSampleConfig = + Cmd "write-sample-config" $ + reqArg "file" $ cmd + where cmd fp = liftIO $ writeSampleConfig fp + +allExposedModules :: ScionM [ModuleName] +#ifdef HAVE_PACKAGE_DB_MODULES +allExposedModules = map moduleName `fmap` packageDbModules True +#else +-- This implementation requires our Cabal to be the same as GHC's. +allExposedModules = do + dflags <- getSessionDynFlags + let pkg_db = pkgIdMap (pkgState dflags) + return $ P.concat (map exposedModules (filter exposed (eltsUFM pkg_db))) +#endif + +cmdListExposedModules :: Cmd +cmdListExposedModules = Cmd "list-exposed-modules" $ noArgs $ cmd + where cmd = do + mod_names <- allExposedModules + return $ map (showSDoc . ppr) mod_names + +cmdSetGHCVerbosity :: Cmd +cmdSetGHCVerbosity = + Cmd "set-ghc-verbosity" $ reqArg "level" $ setGHCVerbosity + +cmdBackgroundTypecheckFile :: Cmd +cmdBackgroundTypecheckFile = + Cmd "background-typecheck-file" $ reqArg' "file" fromJSString $ cmd + where cmd fname = backgroundTypecheckFile fname + +cmdForceUnload :: Cmd +cmdForceUnload = Cmd "force-unload" $ noArgs $ unload + +cmdAddCmdLineFlag :: Cmd +cmdAddCmdLineFlag = + Cmd "add-command-line-flag" $ + optArg' "flag" "" fromJSString <&> + optArg' "flags" [] (map fromJSString) $ cmd + where cmd flag flags' = do + addCmdLineFlags $ (if flag == "" then [] else [flag]) ++ flags' + return JSNull + +cmdThingAtPoint :: Cmd +cmdThingAtPoint = + Cmd "thing-at-point" $ + reqArg "file" <&> reqArg "line" <&> reqArg "column" $ cmd + where + cmd fname line col = do + let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line col + tc_res <- gets bgTcCache + -- TODO: don't return something of type @Maybe X@. The default + -- serialisation sucks. + case tc_res of + Just (Typechecked tcm) -> do + --let Just (src, _, _, _, _) = renamedSource tcm + let src = typecheckedSource tcm + --let in_range = const True + let in_range = overlaps loc + let r = findHsThing in_range src + --return (Just (showSDoc (ppr $ S.toList r))) + unqual <- unqualifiedForModule tcm + case pathToDeepest r of + Nothing -> return (Just "no info") + Just (x,xs) -> + --return $ Just (showSDoc (ppr x O.$$ ppr xs)) + case typeOf (x,xs) of + Just t -> + return $ Just $ showSDocForUser unqual + (prettyResult x O.<+> dcolon O.<+> + pprTypeForUser True t) + _ -> return (Just (showSDocDebug (ppr x O.$$ ppr xs ))) + _ -> return Nothing + +cmdDumpSources :: Cmd +cmdDumpSources = Cmd "dump-sources" $ noArgs $ cmd + where + cmd = do + tc_res <- gets bgTcCache + case tc_res of + Just (Typechecked tcm) -> do + let Just (rn, _, _, _, _) = renamedSource tcm + let tc = typecheckedSource tcm + liftIO $ putStrLn $ showSDocDump $ ppr rn + liftIO $ putStrLn $ showData TypeChecker 2 tc + return () + _ -> return () + +-- remove this func, obsolete. there is also load-component +cmdLoad :: Cmd +cmdLoad = Cmd "load" $ reqArg "component" $ cmd + where + cmd comp = do + liftIO (putStrLn $ "Loading " ++ show comp) + loadComponent comp + +cmdSetVerbosity :: Cmd +cmdSetVerbosity = + Cmd "set-verbosity" $ reqArg "level" $ cmd + where cmd v = setVerbosity (intToVerbosity v) + +cmdGetVerbosity :: Cmd +cmdGetVerbosity = Cmd "get-verbosity" $ noArgs $ verbosityToInt <$> getVerbosity + +-- rename to GetCurrentComponent? +cmdCurrentComponent :: Cmd +cmdCurrentComponent = Cmd "current-component" $ noArgs $ getActiveComponent + +cmdCurrentCabalFile :: Cmd +cmdCurrentCabalFile = Cmd "current-cabal-file" $ noArgs $ cmd + where cmd = do + r <- gtry currentCabalFile + case r of + Right f -> return (showJSON f) + Left (_::SomeScionException) -> return JSNull + +cmdDumpDefinedNames :: Cmd +cmdDumpDefinedNames = Cmd "dump-defined-names" $ noArgs $ cmd + where + cmd = do db <- gets defSiteDB + liftIO $ putStrLn $ dumpDefSiteDB db + +cmdDefinedNames :: Cmd +cmdDefinedNames = Cmd "defined-names" $ noArgs $ cmd + where cmd = definedNames <$> gets defSiteDB + +cmdNameDefinitions :: Cmd +cmdNameDefinitions = + Cmd "name-definitions" $ reqArg' "name" fromJSString $ cmd + where cmd nm = do + db <- gets defSiteDB + let locs = map fst $ lookupDefSite db nm + return locs + +cmdIdentify :: Cmd +cmdIdentify = + Cmd "client-identify" $ reqArg' "name" fromJSString $ cmd + where cmd c = modifySessionState $ \s -> s { client = c } diff --git a/server/Scion/Server/ConnectionIO.hs b/server/Scion/Server/ConnectionIO.hs new file mode 100644 --- /dev/null +++ b/server/Scion/Server/ConnectionIO.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleInstances, ExistentialQuantification, MultiParamTypeClasses #-} +-- | +-- Module : Scion.Server.ConnectionIO +-- License : BSD-style +-- +-- Maintainer : marco-oweber@gmx.de +-- Stability : experimental +-- Portability : portable +-- +-- Abstraction over Socket and Handle IO. + +module Scion.Server.ConnectionIO ( + ConnectionIO(..), mkSocketConnection +) where + +import Prelude hiding (log) +import System.IO (Handle, hFlush) +import Network.Socket (Socket) +import Network.Socket.ByteString (recv, send) +import Data.IORef +import qualified System.Log.Logger as HL +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L + +log :: HL.Priority -> String -> IO () +log = HL.logM "io.connection" + +logError :: String -> IO () +logError = log HL.ERROR + +class ConnectionIO con where + getLine :: con -> IO L.ByteString + getN :: con -> Int -> IO L.ByteString + put :: con -> L.ByteString -> IO () + putLine :: con -> L.ByteString -> IO () + putLine c s = put c s >> put c (L.singleton '\n') + +-- (stdin,stdout) implemenation +instance ConnectionIO (Handle, Handle) where + getLine (i, _) = do l <- S.hGetLine i; return (L.fromChunks [l]) + getN (i,_) = L.hGet i + put (_,o) = L.hPut o + putLine (_,o) = \l -> do + -- ghc doesn't use the ghc api to print texts all the time. So mark + -- scion replies by a leading "scion:" see README.markdown + S.hPutStr o scionPrefix + L.hPut o l + S.hPutStr o newline + hFlush o -- don't ask me why this is needed. LineBuffering is set as well (!) + +scionPrefix :: S.ByteString +scionPrefix = S.pack "scion:" + +newline :: S.ByteString +newline = S.pack "\n" + +data SocketConnection = SockConn Socket (IORef S.ByteString) + +mkSocketConnection :: Socket -> IO SocketConnection +mkSocketConnection sock = + do r <- newIORef S.empty; return $ SockConn sock r + +-- Socket.ByteString implemenation +instance ConnectionIO SocketConnection where + -- TODO: Handle client side closing of connection. + getLine (SockConn sock r) = do + buf <- readIORef r + (line_chunks, buf') <- go buf + writeIORef r buf' + return (L.fromChunks line_chunks) + where + go buf | S.null buf = do + chunk <- recv sock 1024 + if S.null chunk + then return ([], S.empty) + else go chunk + go buf = + let (before, rest) = S.breakSubstring newline buf in + case () of + _ | S.null rest -> do + -- no newline found + (cs', buf') <- go rest + return (before:cs', buf') + _ | otherwise -> + return ([before], S.drop (S.length newline) rest) + + getN (SockConn sock r) len = do + buf <- readIORef r + if S.length buf > len + then do let (str, buf') = S.splitAt len buf + writeIORef r buf' + return (L.fromChunks [str]) + else do + str <- recv sock (len - S.length buf) + writeIORef r S.empty + return (L.fromChunks [buf, str]) + + put (SockConn sock _) lstr = do + go (L.toChunks lstr) + -- is there a better excption which should be thrown instead? (TODO) + -- throw $ mkIOError ResourceBusy ("put in " ++ __FILE__) Nothing Nothing + where go [] = return () + go (str:strs) = do + let l = S.length str + sent <- send sock str + if (sent /= l) then do + logError $ (show l) ++ " bytes to be sent but could only sent : " ++ (show sent) + else go strs diff --git a/server/Scion/Server/Generic.hs b/server/Scion/Server/Generic.hs new file mode 100644 --- /dev/null +++ b/server/Scion/Server/Generic.hs @@ -0,0 +1,65 @@ +module Scion.Server.Generic + ( handle + ) where + +import Prelude hiding ( log ) + +import Scion +import Scion.Types (gets, SessionState(..)) +import Scion.Server.ConnectionIO as CIO +import Scion.Server.Commands + +import Text.JSON +import Text.JSON.Types +import qualified Data.ByteString.Lazy.Char8 as S +import qualified Data.ByteString.Lazy.UTF8 as S +import qualified System.Log.Logger as HL + +log :: HL.Priority -> String -> IO () +log = HL.logM "protocol.generic" +logDebug :: MonadIO m => String -> m () +logDebug = liftIO . log HL.DEBUG + +type StopServer = Bool + +handle :: (ConnectionIO con) => + con + -> Int + -> ScionM StopServer +handle con 0 = do + loop + where + loop = do + -- TODO: don't require line-based input + str <- liftIO $ CIO.getLine con + logDebug $ "parsing command: " ++ show str + let mb_req = decodeStrict (S.toString str) + (resp, keep_going) + <- case mb_req of + Error _ -> return (malformedRequest, True) + Ok req -> handleRequest req + c <- gets client + let resp_str = encodeStrict (if (c == "vim") then vimHack resp else resp) + logDebug $ show resp_str + liftIO $ CIO.putLine con (S.fromString resp_str) + --logDebug $ "sent response" + if keep_going then loop else do + --logDebug "finished serving connection." + return True + +handle con unknownVersion = do + -- handshake failure, don't accept this client version + liftIO $ CIO.putLine con $ + S.pack $ "failure: Don't know how to talk to client version " + ++ (show unknownVersion) + return False + +-- vim doesn't know about true,false,null thus can't parse it. this functions +-- mapps those values to 1,0,"" +vimHack :: JSValue -> JSValue +vimHack JSNull = JSString (toJSString "") +vimHack (JSBool True) = JSRational False 1 +vimHack (JSBool False) = JSRational False 0 +vimHack (JSArray l) = JSArray $ map vimHack l +vimHack (JSObject (JSONObject list)) = JSObject $ JSONObject $ map (\(x,y) -> (x, vimHack y)) list +vimHack e = e -- JSRational, JSString diff --git a/server/Scion/Server/Protocol.hs b/server/Scion/Server/Protocol.hs new file mode 100644 --- /dev/null +++ b/server/Scion/Server/Protocol.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, PatternGuards #-} +-- | +-- Module : Scion.Server.Protocol +-- Copyright : (c) Thomas Schilling 2008 +-- License : BSD-style +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Server message types and methods for serialising and deserialising them to +-- strings. +-- +-- TODO: Document protocol + message format. +-- +module Scion.Server.Protocol where + +import Prelude hiding ( span ) + +import Scion.Types +import Scion.Types.Notes + +import Data.Char ( isDigit, isSpace ) +import Numeric ( showInt ) +import Text.ParserCombinators.ReadP +import qualified Data.Map as M +import qualified Data.MultiSet as MS + +------------------------------------------------------------------------------ + +-- Bump this before every release whenever the wire-protocol is changed +-- (extension-only is fine) +-- +-- Don't forget to also adjust the client code. +scionVersion :: Int +scionVersion = 1 + +------------------------------------------------------------------------------ + +class Sexp a where toSexp :: a -> ShowS +instance Sexp String where toSexp s = showString (show s) +instance Sexp Int where toSexp i = showInt i +instance Sexp Integer where toSexp i = showInt i +instance Sexp () where toSexp _ = showString "nil" +instance Sexp Bool where + toSexp True = showChar 't' + toSexp False = showString "nil" +instance (Sexp a, Sexp b) => Sexp (a, b) where + toSexp (x, y) = parens (toSexp x <+> toSexp y) +instance Sexp a => Sexp (Maybe a) where + toSexp Nothing = showString "nil" + toSexp (Just x) = toSexp x + +newtype Lst a = Lst [a] +instance Sexp a => Sexp (Lst a) where + toSexp (Lst xs) = parens (go xs) + where go [] = id + go [y] = toSexp y + go (y:ys) = toSexp y <+> go ys + +newtype Keyword = K String deriving (Eq, Ord, Show) +instance Sexp Keyword where + toSexp (K s) = showChar ':' . showString s + +-- if you need to cheat +newtype ExactSexp = ExactSexp ShowS +instance Sexp ExactSexp where + toSexp (ExactSexp s) = s + +instance (Sexp a, Sexp b) => Sexp (M.Map a b) where + toSexp m = parens (go (M.assocs m)) + where go ((k,v):r) = toSexp k <+> toSexp v <+> go r + go [] = id + +instance Sexp Component where + toSexp Library = showString ":library" + toSexp (Executable n) = + parens (showString ":executable" <+> showString (show n)) + toSexp (File f) = + parens (showString ":file" <+> showString (show f)) + +instance Sexp a => Sexp (MS.MultiSet a) where + toSexp ms = toSexp (Lst (MS.toList ms)) + +instance Sexp NoteKind where + toSexp k = showString $ case k of + ErrorNote -> ":error" + WarningNote -> ":warning" + InfoNote -> ":info" + OtherNote -> ":other" + +instance Sexp Note where + toSexp n = + parens (toSexp (noteKind n) <+> + toSexp (noteLoc n) <+> + putString (noteMessage n) <+> + putString "") + +instance Sexp Location where + toSexp loc + | isValidLoc loc, + (f, sl, sc, el, ec) <- viewLoc loc = + parens (showString ":loc" <+> toSexp f <+> + showInt sl <+> showInt sc <+> + showInt el <+> showInt ec) + | otherwise = + parens (showString ":no-loc" <+> showString (show (noLocText loc))) + +instance Sexp LocSource where + toSexp (FileSrc f) = showString (show f) + toSexp (OtherSrc s) = showString s + + +------------------------------------------------------------------------------ + +data Request + = Rex (ScionM String) Int -- Remote EXecute + | RQuit + +instance Show Request where + show (Rex _ i) = "Rex " ++ show i + show RQuit = "RQuit" + +data Response + = RReturn String Int + | RReaderError String String + deriving Show + +data Command = Command { + getCommand :: ReadP (ScionM String) + } + +------------------------------------------------------------------------------ + +-- * Parsing Requests + +parseRequest :: [Command] -> String -> Maybe Request +parseRequest cmds msg = + let rs = readP_to_S (messageParser cmds) msg in + case [ r | (r, "") <- rs ] of + [m] -> Just m + [] -> Nothing + _ -> error "Ambiguous grammar for message. This is a bug." + +-- | At the moment messages are in a very simple Lisp-style format. This +-- should also be easy to parse (and generate) for non-lisp clients. +messageParser :: [Command] -> ReadP Request +messageParser cmds = do + r <- inParens $ choice + [ string ":quit" >> return RQuit + , do string ":emacs-rex" + sp + c <- inParens (choice (map getCommand cmds)) + sp + i <- getInt + return (Rex c i) + ] + skipSpaces + return r + +inParens :: ReadP a -> ReadP a +inParens = between (char '(') (char ')') + +getString :: ReadP String +getString = decodeEscapes `fmap` (char '"' >> munchmunch False) + where + munchmunch had_backspace = do + c <- get + if c == '"' && not had_backspace + then return [] + else do + (c:) `fmap` munchmunch (c == '\\') + +getInt :: ReadP Int +getInt = munch1 isDigit >>= return . read + +decodeEscapes :: String -> String +decodeEscapes = id -- XXX + +-- | One or more spaces. +sp :: ReadP () +sp = skipMany1 (satisfy isSpace) + + +------------------------------------------------------------------------------ + +-- * Writing Responses + +showResponse :: Response -> String +showResponse r = shows' r "\n" + where + shows' (RReturn f i) = + parens (showString ":return" <+> + parens (showString ":ok" <+> showString f) + <+> showInt i) + shows' (RReaderError s t) = + parens (showString ":reader-error" <+> + showString (show s) <+> + showString (show t)) +parens :: ShowS -> ShowS +parens p = showChar '(' . p . showChar ')' + +putString :: String -> ShowS +putString s = showString (show s) + +infixr 1 <+> +(<+>) :: ShowS -> ShowS -> ShowS +l <+> r = l . showChar ' ' . r diff --git a/vim_runtime_path/autoload/haskellcomplete.vim b/vim_runtime_path/autoload/haskellcomplete.vim new file mode 100644 --- /dev/null +++ b/vim_runtime_path/autoload/haskellcomplete.vim @@ -0,0 +1,367 @@ +" This file contains the code necessary to talk to the scion server +" -> haskellcomplete#EvalScion ) +" +" This implementation requires has('python') support + +" You can look up some use cases in the ftplugin file. +" +" This code is based on the initial implementation found in shim by Benedikt Schmidt +" The server side code can be found in src-scion-server/Scion/Server/ProtocolVim.hs + +if exists('g:tovl') + fun! s:Log(level, msg) + call tovl#log#Log("haskellcomplete",a:level, type(a:msg) == type("") ? a:msg : string(a:msg)) + endf +else + fun! s:Log(level, msg) + echoe a:msg + endf +endif + +" require python or exit +if !has('python') | call s:Log(0, "Error: scion requires vim compiled with +python") | finish | endif + +let g:vim_scion_protocol_version = "0" + +fun! haskellcomplete#LoadComponent(set_cabal_project, component) + let result = haskellcomplete#EvalScion(0, 'load-component', { 'component' : a:component}) + if has_key(result,'error') + if result['error']['message'] == "NoCurrentCabalProject" && a:set_cabal_project + let cabal_project = haskellcomplete#SetCurrentCabalProject() + return haskellcomplete#LoadComponent(0, a:component) + else + throw "can't handle this failure: ".string(result['error']) + endif + endif + return result['result'] +endf + +fun! haskellcomplete#SetCurrentCabalProject() + let configs = haskellcomplete#EvalScion(1,'list-cabal-configurations', + \ { 'cabal-file' : haskellcomplete#CabalFile() + \ , 'scion-default': json#IntToBool(get(g:scion_config, "use_default_scion_cabal_dist_dir", 1)) }) + let config = haskellcomplete#ChooseFromList(configs, 'select a cabal configuration') + let result = haskellcomplete#EvalScion(1,'open-cabal-project' + \ ,{'root-dir' : getcwd() + \ ,'dist-dir' : config['dist-dir'] + \ ,'extra-args' : config['extra-args'] } + \ ) +endf + +fun! haskellcomplete#ScionResultToErrorList(action, func, result) + let qflist = [] + for dict in a:result['notes'] + let loc = dict['location'] + if has_key(loc, 'no-location') + " using no-location so that we have an item to jump to. + " ef we don't use that dummy file SaneHook won't see any errors! + call add(qflist, { 'filename' : 'no-location' + \ ,'lnum' : 0 + \ ,'col' : 0 + \ ,'text' : loc['no-location'] + \ ,'type' : dict['kind'] == "error" ? "E" : "W" + \ }) + else + call add(qflist, { 'filename' : loc['file'] + \ ,'lnum' : loc['region'][0] + \ ,'col' : loc['region'][1] + \ ,'text' : '' + \ ,'type' : dict['kind'] == "error" ? "E" : "W" + \ }) + endif + for msgline in split(dict['message'],"\n") + call add(qflist, {'text': msgline}) + endfor + endfor + + call call(a:func, [qflist]) + if exists('g:haskell_qf_hook') + exec g:haskell_qf_hook + endif + if (len(qflist) == 0) + return printf(a:action." success. compilationTime: %s", string(a:result['duration'])) + else + return printf(a:action." There are errors. compilationTime: %s", string(a:result['duration'])) + endif +endfun + + +" if there is item take it, if there are more than one ask user which one to +" use.. -- don't think cabal allows multiple .cabal files.. At least the user +" is notified that there are more than one .cabal files +fun! haskellcomplete#ChooseFromList(list, ...) + let msg = a:0 > 0 ? a:1 : "choose from list" + if empty(a:list) + return + elseif len(a:list) == 1 + return a:list[0] + else + let l = [] + let i = 1 + for line in a:list + let line2 = type(line) != type('') ? string(line) : line + call add(l, i.': '.line2) + let i = i + 1 + unlet line + endfor + return a:list[inputlist(l)-1] + endif +endf + +fun! haskellcomplete#CabalFile() + if !exists('g:cabal_file') + let list = split(glob('*.cabal'),"\n") + if empty(list) + throw "no cabal file found" + endif + let g:cabal_file = getcwd().'/'.haskellcomplete#ChooseFromList(list) + endif + return g:cabal_file +endf + +fun! haskellcomplete#List(what) + return haskellcomplete#EvalScion(1,'list-'.a:what, {}) +endf + +fun! haskellcomplete#OpenCabalProject(method, ...) + return haskellcomplete#EvalScion(1,a:method + \ ,{'root-dir' : getcwd() + \ ,'dist-dir' : a:1 + \ ,'extra-args' : a:000[1:] } + \ ) +endf + +fun! haskellcomplete#compToV(...) + let component = a:0 > 0 ? a:1 : 'file:'.expand('%:p') + let m = matchstr(component, '^executable:\zs.*') + if m != '' | return {'executable' : m} | endif + let m = matchstr(component, '^library$') + if m != '' | return {'library' : json#NULL()} | endif + let m = matchstr(component, '^file:\zs.*') + if m != '' | return {'file' : m} | endif + throw "invalid component".component +endfun + +fun! haskellcomplete#WriteSampleConfig(...) + let file = a:0 > 0 ? a:1 : ".scion-config" + let file = fnamemodify(file, ":p") + return haskellcomplete#EvalScion(1, 'write-sample-config', {'file' : file}) +endf + +" if there are errors open quickfix and jump to first error (ignoring warning) +" if not close it +fun! haskellcomplete#SaneHook() + let list = getqflist() + let nr = 0 + let open = 0 + let firstError = 0 + for i in getqflist() + let nr = nr +1 + if i['bufnr'] == 0 | continue | endif + if i['type'] == "E" && firstError == 0 + let firstError = nr + endif + let open = 1 + endfor + if open + cope " open + " move to first error + if firstError > 0 | exec "crewind ".firstError | endif + else + cclose + endif +endf + +" use this to connect to a socket +" connection settings: see strings in connectscion + +" returns string part before and after cursor +function! haskellcomplete#BcAc() + let pos = col('.') -1 + let line = getline('.') + return [strpart(line,0,pos), strpart(line, pos, len(line)-pos)] +endfunction + +" completion functions +if !exists('g:haskellcompleteAll') + let g:haskellcompleteAll='' " '' or '-all' '-all' means complete from the set of all function exported by all modules found in all used packages +endif + +fun! haskellcomplete#CompletModule(findstart, base) + if a:findstart + let [bc,ac] = haskellcomplete#BcAc() + return len(bc)-len(matchstr(bc,'\S*$')) + else + let [bc,ac] = haskellcomplete#BcAc() + let addImport = bc !~ 'import\s\+\S*$' + let matches = haskellcomplete#EvalScion( + \ { 'request' : 'cmdModuleCompletion' + \ , 'camelCase' : 'True' + \ , 'short' : a:base + \ }) + if addImport + call map(matches, string('import ').'.v:val') + endif + return matches + endif +endf + +let g:scion_request_id = 1 + +" name: method name +" params: params to method +" optional argument: continuation function (not yet implemented) +" returns: nothing when continuation function is given +" reply else +function! haskellcomplete#EvalScion(fail_on_error, method, params, ...) + if a:0 > 0 + let continuation a:0 + endif + let g:scion_request_id = g:scion_request_id + 1 + let request = { 'method' : a:method, 'params' : a:params, 'id' : g:scion_request_id } + " the first string converts the vim object into a string, the second + " converts this string into a python string + let g:scion_arg = json#Encode(request) + py evalscionAssign(vim.eval('g:scion_arg')) + " warnings + for w in get(g:scion_result, 'warnings', []) + call s:Log(1, w) | echo w + endfor + " errors + + if !a:fail_on_error + return g:scion_result + endif + + if has_key(g:scion_result,'error') + call s:Log(0, g:scion_result['error']) + throw "There was a scion server error :".string(g:scion_result['error']) + else + return g:scion_result['result'] + endif +endfunction + +function! s:DefPython() +python << PYTHONEOF +import sys, tokenize, cStringIO, types, socket, string, vim, popen2, os +from subprocess import Popen, PIPE + +scion_log_stdout = vim.eval('exists("g:scion_log_stdout") && g:scion_log_stdout') +scion_stdout = [] + +class ScionServerConnection: + """base of a server connection. They all provide two methods: send and receive bothe sending or receiving a single line separated by \\n""" + def send(self, line): + self.scion_i.write("%s\n"%line) + self.scion_i.flush() + def receive(self): + s = self.scion_o.readline() + if s == "": + raise "EOF, stderr lines: \n%s"%self.scion_err.read() + else: + return s[:-1] + +class ScionServerConnectionStdinOut(ScionServerConnection): + """this connection launches the server and connects to its stdin and stdout streams""" + def __init__(self, scion_executable): + #self.scion_o,self.scion_i,e = popen2.popen3('%s -i -f /tmp/scion-log-%s' % (scion_executable, os.getcwd().replace('/','_').replace('\\','_')) + p = Popen([scion_executable,"-i","-f", "/tmp/scion-log-%s"%(os.getcwd().replace('/','_').replace('\\','_'))], \ + shell = False, bufsize = 1, stdin = PIPE, stdout = PIPE, stderr = PIPE) + self.scion_o = p.stdout + self.scion_i = p.stdin + self.scion_err = p.stderr + + def receive(self): + global scion_log_stdout, scion_stdout + s = ScionServerConnection.receive(self) + + # ghc doesn't always use the ghc API to print statements.. so ignore all + # lines not marked by "scion:" at the beginning + # see README.markdown + while s[:6] != "scion:": + # throw away non "scion:" line and try again + if scion_log_stdout: + scion_stdout.append(s) + scion_stdout = scion_stdout[-200:] + # should this be printed? It doesn't hurt much but might be useful when + # trouble shooting.. + print "ignoring line", s + s = ScionServerConnection.receive(self) + + return s[6:] + +class ScionServerConnectionSocket(ScionServerConnection): + """connects to the scion server by either TCP/IP or socketfile""" + def __init__(self, connection): + if type(connection) == type([]): + # array [ host, port ] + # vim.eval always returns strings! + connection = (connection[0], string.atoi(connection[1])) + print "connection is now %s" % connection.__str__() + su = socket.socket(socket.AF_INET, socket.SOCK_STREAM) + else: # must be path -> file socket + print "else " + su = socket.socket(socket.AF_UNIX, socket.SOCK_STREAM) + su.settimeout(10) + su.connect(connection) + # making file to use readline() + self.scion_o = su.makefile('rw') + self.scion_i = self.scion_o + +server_connection = None +told_user_about_missing_configuration = 0 +lastScionResult = ""; +def connectscion(): + # check that connection method has been defined + global server_connection + global told_user_about_missing_configuration + if 0 == told_user_about_missing_configuration: + try: + # use connection form vim value so that python is used as lazily as possible + scionConnectionSetting = vim.eval('g:scion_connection_setting') + print "connecting to scion %s"%scionConnectionSetting.__str__() + except NameError: + vim.command("sp") + b = vim.current.buffer + b.append( "you haven't defined g:scion_connection_setting") + b.append( "Do so by adding one of the following lines to your .vimrc:") + b.append( "TCP/IP, socket, stdio") + b.append( "let g:scion_connection_setting = ['socket', \"socket file location\"] # socket connection") + b.append( "let g:scion_connection_setting = ['socket', ['localhost', 4005]] # host, port TCIP/IP connection") + b.append( "let g:scion_connection_setting = ['scion', \"scion_server location\"] # stdio connection ") + told_user_about_missing_configuration = 1 + + if scionConnectionSetting[0] == "socket": + server_connection = ScionServerConnectionSocket(scionConnectionSetting[1]) + else: + server_connection = ScionServerConnectionStdinOut(scionConnectionSetting[1]) + # tell server than vim doesn't like true, false, null + vim.command('call haskellcomplete#EvalScion(1, "client-identify", {"name":"vim"})') + +# sends a command and returns the returned line +def evalscion(str): + global server_connection + try: + server_connection.send(str) + except: + vim.command('echom "%s"'% ("(re)connecting to scion")) + connectscion() + server_connection.send(str) + return server_connection.receive() + +# str see EvalScion +def evalscionAssign(str): + global lastScionResult + """assigns scion result to g:scion_result, result should either be + { "result" : ..., "error" : [String] }""" + vim.command("silent! unlet g:scion_result") + lastScionResult = evalscion(str) + vim.command("silent! let g:scion_result = %s" % lastScionResult) + vim.command("if !exists('g:scion_result') | let g:scion_result = {'error' : \"couldn't parse scion result.\n%s\nTry :py print lastScionResult to see full server response\" } | endif " % str[:80]) + +# sys.path.extend(['.','..']) +PYTHONEOF +endfunction + +call s:DefPython() +" vim: set et ts=4: diff --git a/vim_runtime_path/autoload/json.vim b/vim_runtime_path/autoload/json.vim new file mode 100644 --- /dev/null +++ b/vim_runtime_path/autoload/json.vim @@ -0,0 +1,44 @@ +" vim encodes strings using ''. JSON requires ". + +" dummy type which is used to encode "null" +" same could be done for true / false. But we don't use those yet +fun! json#NULL() + return function("json#NULL") +endf +fun! json#True() + return function("json#True") +endf +fun! json#False() + return function("json#False") +endf +fun! json#IntToBool(i) + return a:i == 1 ? json#True() : json#False() +endf + +fun! json#Encode(thing) + if type(a:thing) == type("") + return '"'.escape(a:thing,'"').'"' + elseif type(a:thing) == type({}) + let pairs = [] + for [Key, Value] in items(a:thing) + call add(pairs, json#Encode(Key).':'.json#Encode(Value)) + unlet Key | unlet Value + endfor + return "{".join(pairs, ",")."}" + elseif type(a:thing) == type(0) + return a:thing + elseif type(a:thing) == type([]) + return '['.join(map(a:thing, "json#Encode(v:val)"),",").']' + return + elseif string(a:thing) == string(json#NULL()) + return "null" + elseif string(a:thing) == string(json#True()) + return "true" + elseif string(a:thing) == string(json#False()) + return "false" + else + throw "unexpected new thing: ".string(a:thing) + endif +endf + +" usage example: echo json#Encode({'method': 'connection-info', 'id': 0, 'params': [3]}) diff --git a/vim_runtime_path/ftplugin/haskell.vim b/vim_runtime_path/ftplugin/haskell.vim new file mode 100644 --- /dev/null +++ b/vim_runtime_path/ftplugin/haskell.vim @@ -0,0 +1,124 @@ +if exists('g:dont_load_haskell_scion_interface_simple') + finish +endif + +" r = scion result with error locations +" func : either setqflist or setloclist +if !exists('g:haskell_qf_hook') + let g:haskell_qf_hook = 'call haskellcomplete#SaneHook()' +endif + +" very simple user interface to expose scion functionality +" I'll implement a better interface in tovl. +" (http://github.com/MarcWeber/theonevimlib) + +fun! s:BackgroundTypecheckFile(...) + " no file given defaults to current buffer + let file = a:0 > 0 ? a:1 : expand('%:p') + let r = haskellcomplete#EvalScion(1, 'background-typecheck-file', {'file' : file}) + if has_key(r,'Right') + echo haskellcomplete#ScionResultToErrorList('file check', 'setqflist', r['Right']) + else + call setqflist([{'text' : r['Left']}]) + cope + " isn't shown because silent is used below.. and silent is used so that + " need not to be pressed over and over again + echo "this file could not be checked, reason: ".r['Left']."(-> backgroundTypecheckFile)" + endif +endf + +fun! s:FlagCompletion(A,L,P) + let beforeC= a:L[:a:P-1] + let word = matchstr(beforeC, '\zs\S*$') + let list = haskellcomplete#List("supported-flags") + "allow glob patterns: + call filter(list, 'v:val =~ '.string('^'.substitute(word,'*','.*','g'))) + return list +endf + +fun! s:ListCabalConfigurations(...) + let params = { 'cabal-file' : haskellcomplete#CabalFile()} + if a:0 > 0 + let params['type'] = a:1 + endif + return haskellcomplete#EvalScion(1,'list-cabal-configurations', params) +endf + +" intentionally suffixing commands by "Scion" +" This way you have less typing. You can still get a list of Scion commands by +" :*Scion + +" ===== you don't need any project for these: ============= +command! -buffer ConnectionInfoScion + \ echo haskellcomplete#EvalScion(1,'connection-info',{}) + +" list supported languages +command! -buffer ListSupportedLanguagesScion + \ echo haskellcomplete#List('supported-languages') + +" list supported pragmas +command! -buffer ListSupportedPragmasScion + \ echo haskellcomplete#List('supported-pragmas') + +command! -buffer ListSupportedFlagsScion + \ echo haskellcomplete#List('supported-flags') + +command! -buffer ListRdrNamesInScopeScion + \ echo haskellcomplete#List('rdr-names-in-scope') + +command! -buffer ListCabalComponentsScion + \ echo haskellcomplete#EvalScion(1,'list-cabal-components',{'cabal-file': haskellcomplete#CabalFile()}) + +command! -buffer ListExposedModulesScion + \ echo haskellcomplete#List('exposed-modules') + +command! -nargs=* ListCabalConfigurationsScion + \ echo s:ListCabalConfigurations() + +command! -nargs=1 SetGHCVerbosityScion + \ echo haskellcomplete#EvalScion(1,'set-ghc-verbosity',{'level': 1*}) + +command! -nargs=1 SetVerbosityScion + \ echo haskellcomplete#EvalScion(1,'set-verbosity',{'level': 1*}) + +command! -nargs=0 GetVerbosityScion + \ echo haskellcomplete#EvalScion(1,'get-verbosity',{}) + +command! -nargs=0 CurrentComponentScion + \ echo haskellcomplete#EvalScion(1,'current-component',{}) + +command! -nargs=0 CurrentCabalFileScion + \ echo haskellcomplete#EvalScion(1,'current-cabal-file',{}) + +command! -nargs=0 DumpDefinedNamesScion + \ echo haskellcomplete#EvalScion(1,'dump-defined-names',{}) + +command! -nargs=0 DefinedNamesScion + \ echo haskellcomplete#EvalScion(1,'defined-names',{}) + +command! -nargs=1 NameDefinitions + \ echo haskellcomplete#EvalScion(1,'name-definitions',{'name' : }) + +command! -buffer -nargs=* -complete=file BackgroundTypecheckFileScion + \ call s:BackgroundTypecheckFile() + +command! -nargs=0 ForceUnloadScion + \ echo haskellcomplete#EvalScion(1,'force-unload',{}) + +command! -nargs=0 DumpSourcesScion + \ echo haskellcomplete#EvalScion(1,'dump-sources',{}) + +command! -nargs=1 -complete=customlist,s:FlagCompletion -buffer AddCommandLineFlagScion + \ echo haskellcomplete#EvalScion(1,'add-command-line-flag',{'flags': []}) + +" ===== loading a cabal project: ============================ + +" assuming pwd is current cabal directory containing the .cabal file +" optional argument specifies the cabal build (dist) directory +command! -buffer -nargs=* -complete=file OpenCabalProjectScion + \ echo haskellcomplete#OpenCabalProject('open-cabal-project',) +command! -buffer -nargs=* -complete=file ConfigureCabalProjectScion + \ echo haskellcomplete#OpenCabalProject('configure-cabal-project', ) + +command! -buffer ThingAtPointScion + \ echo haskellcomplete#EvalScion(1,'thing-at-point', {'file' : expand('%:p'), 'line' : 1*line('.'), 'column' : 1*col('.')}) diff --git a/vim_runtime_path/plugin/haskell_scion.vim b/vim_runtime_path/plugin/haskell_scion.vim new file mode 100644 --- /dev/null +++ b/vim_runtime_path/plugin/haskell_scion.vim @@ -0,0 +1,46 @@ +if !exists('g:scion_config') + let g:scion_config = {} + " let g:scion_config['use_default_scion_cabal_dist_dir'] = 0 +endif +" probably more commands should be moved from haskell.vim into this file so +" that the commands can be run even when not editing a haskell file. + +fun! s:LoadComponentCompletion(A,L,P) + let beforeC= a:L[:a:P-1] + let word = matchstr(beforeC, '\zs\S*$') + + let result = [] + for item in haskellcomplete#EvalScion(1,'list-cabal-components',{'cabal-file': haskellcomplete#CabalFile()}) + if has_key(item, 'library') + call add(result, 'library') " there can only be one + elseif has_key(item, 'executable') + call add(result, 'executable:'. item['executable']) + else + " component type File will never be returned ? + throw "unexpected item ".string(item) + endif + endfor + return result +endf + +fun! s:LoadComponentScion(...) + let result = haskellcomplete#LoadComponent(1,call('haskellcomplete#compToV', a:000)) + echo haskellcomplete#ScionResultToErrorList('load component finished: ','setqflist', result) + + " start checking file on buf write + if !exists('g:dont_check_on_buf_write') + augroup HaskellScion + au BufWritePost *.hs,*.hsc,*.lhs silent! BackgroundTypecheckFile + augroup end + endif +endf + + +" arg either "library", "executable:name" or "file:Setup.hs" +" no args: file: +command! -nargs=? -complete=customlist,s:LoadComponentCompletion + \ LoadComponentScion + \ call s:LoadComponentScion() + +command! -nargs=* -complete=file -buffer WriteSampleConfigScion + \ echo haskellcomplete#WriteSampleConfig() | e .scion-config