scion (empty) → 0.1
raw patch · 25 files changed
+7247/−0 lines, 25 filesdep +Cabaldep +QuickCheckdep +basesetup-changed
Dependencies added: Cabal, QuickCheck, base, bytestring, containers, directory, filepath, ghc, ghc-paths, ghc-syb, hslogger, json, multiset, network, network-bytestring, time, uniplate, utf8-string
Files
- LICENSE +30/−0
- README.markdown +353/−0
- Setup.hs +4/−0
- emacs/scion.el +2414/−0
- lib/Scion.hs +57/−0
- lib/Scion/Configure.hs +178/−0
- lib/Scion/Inspect.hs +195/−0
- lib/Scion/Inspect/DefinitionSite.hs +116/−0
- lib/Scion/Inspect/Find.hs +396/−0
- lib/Scion/Inspect/TypeOf.hs +74/−0
- lib/Scion/Session.hs +723/−0
- lib/Scion/Types.hs +326/−0
- lib/Scion/Types/ExtraInstances.hs +29/−0
- lib/Scion/Types/Notes.hs +275/−0
- lib/Scion/Utils.hs +189/−0
- scion.cabal +147/−0
- server/Main.hs +191/−0
- server/Scion/Server/Commands.hs +588/−0
- server/Scion/Server/ConnectionIO.hs +108/−0
- server/Scion/Server/Generic.hs +65/−0
- server/Scion/Server/Protocol.hs +208/−0
- vim_runtime_path/autoload/haskellcomplete.vim +367/−0
- vim_runtime_path/autoload/json.vim +44/−0
- vim_runtime_path/ftplugin/haskell.vim +124/−0
- vim_runtime_path/plugin/haskell_scion.vim +46/−0
+ LICENSE view
@@ -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.
+ README.markdown view
@@ -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 <version>+ (add-to-list 'load-path "~/.cabal/share/scion-<version>/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-<version>/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-<version>/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:<this buf>`. 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.
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main :: IO ()+main = defaultMain
+ emacs/scion.el view
@@ -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-mode-map>\+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.++<hostname> <port> <coding-system> -> <network-stream-process>"+ (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-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 <name>.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 <name>)."+ (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
+ lib/Scion.hs view
@@ -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 "<api-client>"+ 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
+ lib/Scion/Configure.hs view
@@ -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 <args>@ 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
+ lib/Scion/Inspect.hs view
@@ -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 +-}
+ lib/Scion/Inspect/DefinitionSite.hs view
@@ -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)
+ lib/Scion/Inspect/Find.hs view
@@ -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+
+ lib/Scion/Inspect/TypeOf.hs view
@@ -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)
+ lib/Scion/Session.hs view
@@ -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:
+ lib/Scion/Types.hs view
@@ -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
+ lib/Scion/Types/ExtraInstances.hs view
@@ -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+
+ lib/Scion/Types/Notes.hs view
@@ -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
+ lib/Scion/Utils.hs view
@@ -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+
+ scion.cabal view
@@ -0,0 +1,147 @@+name: scion+version: 0.1+license: BSD3+license-file: LICENSE+author: Thomas Schilling <nominolo@googlemail.com>+maintainer: Thomas Schilling <nominolo@googlemail.com>+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+
+ server/Main.hs view
@@ -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)
+ server/Scion/Server/Commands.hs view
@@ -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 }
+ server/Scion/Server/ConnectionIO.hs view
@@ -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
+ server/Scion/Server/Generic.hs view
@@ -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
+ server/Scion/Server/Protocol.hs view
@@ -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 <cmd> " ++ 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
+ vim_runtime_path/autoload/haskellcomplete.vim view
@@ -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:
+ vim_runtime_path/autoload/json.vim view
@@ -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]})
+ vim_runtime_path/ftplugin/haskell.vim view
@@ -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+ " <cr> 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<c-d>++" ===== 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(<f-args>)++command! -nargs=1 SetGHCVerbosityScion+ \ echo haskellcomplete#EvalScion(1,'set-ghc-verbosity',{'level': 1*<f-args>})++command! -nargs=1 SetVerbosityScion+ \ echo haskellcomplete#EvalScion(1,'set-verbosity',{'level': 1*<f-args>})++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' : <f-args>})++command! -buffer -nargs=* -complete=file BackgroundTypecheckFileScion+ \ call s:BackgroundTypecheckFile(<f-args>)++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': [<f-args>]})++" ===== 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',<f-args>)+command! -buffer -nargs=* -complete=file ConfigureCabalProjectScion+ \ echo haskellcomplete#OpenCabalProject('configure-cabal-project', <f-args>)++command! -buffer ThingAtPointScion+ \ echo haskellcomplete#EvalScion(1,'thing-at-point', {'file' : expand('%:p'), 'line' : 1*line('.'), 'column' : 1*col('.')})
+ vim_runtime_path/plugin/haskell_scion.vim view
@@ -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:<current file>+command! -nargs=? -complete=customlist,s:LoadComponentCompletion+ \ LoadComponentScion+ \ call s:LoadComponentScion(<f-args>)++command! -nargs=* -complete=file -buffer WriteSampleConfigScion+ \ echo haskellcomplete#WriteSampleConfig(<f-args>) | e .scion-config