Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'scion-2nd-attempt'

  • Loading branch information...
commit 6047ffa2bce733af4345a5921cc7e1276a91f778 2 parents e0cd3e5 + 37d142e
@nominolo authored
View
115 Makefile
@@ -1,75 +1,40 @@
-.PHONY: default clean install-lib install-deps setup
-
-default: all
-all: build
-
-include config.mk
-
-# If not set in custom config.mk, use the default versions
-HC ?= ghc
-PKG ?= ghc-pkg
-HADDOCK ?= haddock
-
-DIST = dist
-DIST_LIB = $(DIST)/lib
-DIST_SERVER = $(DIST)/server
-SETUP_DIST = setup-dist
-SETUP = $(SETUP_DIST)/Setup
-
-DOTDOTSETUP = cabal
-
-CABAL_INSTALL_OPTS += --ghc --with-compiler=$(HC) --with-hc-pkg=$(PKG)
-CABAL_FLAGS ?=
-# -ftesting
-
-$(DIST)/setup-config: $(SETUP) scion.cabal $(DIST)
- $(SETUP) configure -v --builddir=$(DIST) \
- --with-compiler=$(HC) --with-hc-pkg=$(PKG) \
- --user $(CABAL_FLAGS) > $(DIST)/lib-config-log
-
-$(DIST)/build/libHSscion-0.1.a: $(SETUP) $(DIST)/setup-config $(wildcard lib/**/*.hs lib/**/**/*.hs server/**/*.hs)
- @echo === Building scion ===
- $(SETUP) build --builddir=$(DIST)
-
-$(DIST):
- mkdir $(DIST)
-
-$(SETUP): Setup.hs $(SETUP_DIST)
- $(HC) --make $< -o $@
-
-$(SETUP_DIST):
- mkdir $@
-
-setup: $(SETUP)
-
-build: $(DIST)/build/libHSscion-0.1.a
-
-# TODO: dodgy
-install: $(DIST)/build/libHSscion-0.1.a
- cabal install
-
-# test: build
-# echo main | $(HC) --interactive -package ghc -DDEBUG -isrc -idist/build tests/RunTests.hs
-# # ./dist/build/test_get_imports/test_get_imports $(GHC_PATH)/compiler dist-stage2 +RTS -s -RTS
-
-clean:
- $(SETUP) clean --builddir=$(DIST) || rm -rf $(DIST)
-
-distclean: clean
- rm -rf $(SETUP_DIST)
-
-# doc: configure
-# $(SETUP) haddock --with-haddock=$(HADDOCK)
-
-printvars:
- @echo "UseInplaceGhc = $(UseInplaceGhc)"
- @echo "GHC_PATH = $(GHC_PATH)"
- @echo "HC = $(HC)"
- @echo "PKG = $(PKG)"
- @echo "HADDOCK = $(HADDOCK)"
- @echo "CABAL_INSTALL = $(CABAL_INSTALL)"
- @echo " ..._OPTS = $(CABAL_INSTALL_OPTS)"
- @echo "CABAL_FLAGS = $(CABAL_FLAGS)"
- @echo "---------------------------------------------------------------"
- @echo "DIST_LIB = $(DIST_LIB)"
- @echo "SETUP_DIST = $(SETUP_DIST)"
+default: install
+
+# Create a file config.mk to customise some of these options. This
+# can be useful for example to compile with the HEAD branch of GHC.
+# See config.mk.sample for an example.
+-include config.mk
+
+TOP := $(shell pwd)
+DIST ?= dist
+HC ?= ghc
+RUNHC ?= runghc -f $(HC)
+
+#HC = ghc-6.12.1
+#RUNHC = runghc -f$(HC)
+
+boot:
+ mkdir -p $(DIST)
+
+.PHONY: inplace
+inplace:
+ $(HC) --make -outputdir $(DIST) -isrc -package ghc Scion.Session
+ $(HC) --make -outputdir $(DIST) -isrc -package ghc Scion.Worker.Main
+ $(HC) --make -outputdir $(DIST) -isrc -package ghc src/Worker.hs -o $(DIST)/scion-worker
+# cp src/Worker.hs $(DIST)/Worker.hs
+ echo "#!/bin/sh\n$(DIST)/scion-worker \$${1+\"\$$@\"}" > inplace/scion-worker
+ chmod +x inplace/scion-worker
+ echo "#!/bin/sh\n$(RUNHC) -i\"$(TOP)/src\" -package --ghc-arg=ghc -i\"$(DIST)\" \"$(TOP)/src/Server.hs\"" > inplace/scion-server
+ chmod +x inplace/scion-server
+
+.PHONY: install
+install:
+ time cabal -v install --builddir=$(DIST)/cabal --with-compiler=$(HC)
+
+.PHONY: test
+test:
+ $(RUNHC) test/TestSuite.hs
+
+.PHONY: docs
+docs:
+ cabal -v haddock --builddir=$(DIST)/cabal
View
62 docs/Architecture.markdown
@@ -0,0 +1,62 @@
+Since version 0.3 Scion uses a multi-process architecture. The Scion
+library starts one or more `scion-worker` processes which do the
+actual work. The Scion library just manages these processes (and
+caches some of their state). This solves the following problems:
+
+ - *Static Flags*. Some of GHC's command line flags can only be set
+ on start-up. This is important mainly for flags that control the
+ kind of compilation (profiled, threaded).
+
+ - *Other write-once state*. GHC only reads the package database once
+ on startup. If new packages have been installed since startup
+ they will not be visible. Changing the database by force while a
+ session is running is likely to cause problems.
+
+ - *Caches*. There are a few caches in GHC that cannot be flushed.
+ These include the name cache, and the package DB cache.
+
+ - *Multiple Compiler Versions*. It is not possible to link to two
+ different versions of GHC from within the same program. If we
+ want to make sure a program compiles with multiple versions of GHC
+ (or multiple combinations of its dependencies) we need to use
+ multiple processes.
+
+The downside of a multi-process architecture is of course the
+additional context switches and communication overhead. To reduce
+this, we:
+
+ - use a binary protocol,
+
+ - cache some information on the library side, and
+
+ - avoid sending too much data between library and worker.
+
+Non-Haskell front-ends use a scion-server that takes the place of the
+library.
+
+The architecture therefore looks as follows:
+
+ +-----------------------+
+ | Non-Haskell frontend |
+ | (Eclipse, Emacs, Vim) |
+ +-----------------------+
+ ^
+ | front-end specific protocol
+ | (e.g., json, s-exprs)
+ v
+ +-----------------+
+ | Scion server / |
+ | Scion library |
+ +-----------------+
+ ^ ^ ^
+ | | | binary protocol
+ v v v
+ +--------------+ +--------------+
+ | Scion worker | ... | Scion worker |
+ +--------------+ +--------------+
+
+If the front-end is written in Haskell, it will take the part of the
+Scion library. The Scion server, in turn, translates between a
+front-end-specific serialisation format to Scion library API calls.
+
+The library-worker protocol is defined in `src/Scion/Types/Commands`.
View
535 emacs/scion.el
@@ -24,7 +24,6 @@
(eval-and-compile
(require 'cl)
- (require 'json)
(unless (fboundp 'define-minor-mode)
(require 'easy-mmode)
(defalias 'define-minor-mode 'easy-mmode-define-minor-mode)))
@@ -86,10 +85,7 @@ This applies to the *inferior-lisp* buffer and the network connections."
(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."))
+ "The string that should be displayed in the modeline."))
;;;---------------------------------------------------------------------------
@@ -103,6 +99,8 @@ evaluate BODY.
`(let ((,var ,value))
(when ,var ,@body)))
+(put 'when-let 'lisp-indent-function 1)
+
(defmacro destructure-case (value &rest patterns)
"Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
@@ -195,8 +193,9 @@ You might prefer `ido-completing-read' to the default, but that
leads to problems on some versions of Emacs which are so severe
that Emacs needs to be restarted. (You have been warned!)")
-(defun scion-completing-read (prompt collection &optional predicate require-match
- initial-input hist def inherit-input-method)
+(defun scion-completing-read (prompt collection
+ &optional predicate require-match
+ initial-input hist def inherit-input-method)
(if (eq scion-completing-read-function 'ido-completing-read)
;; ido-completing-read does not support the last argument. What
;; a mess.
@@ -226,10 +225,13 @@ that Emacs needs to be restarted. (You have been warned!)")
(defun scion-tree-default-printer (tree)
(princ (scion-tree.item tree) (current-buffer)))
+(defun scion-tree-text-printer (tree)
+ (insert (scion-tree.item tree)))
+
(defun scion-tree-decoration (tree)
(cond ((scion-tree-leaf-p tree) "-- ")
- ((scion-tree.collapsed-p tree) "[+] ")
- (t "-+ ")))
+ ((scion-tree.collapsed-p tree) "-* ")
+ (t "-+ ")))
(defun scion-tree-insert-list (list prefix)
"Insert a list of trees."
@@ -283,6 +285,7 @@ This is used for labels spanning multiple lines."
(defun scion-tree-toggle (tree)
"Toggle the visibility of TREE's children."
(with-struct (scion-tree. collapsed-p start-mark end-mark prefix) tree
+ (goto-char start-mark)
(setf collapsed-p (not collapsed-p))
(scion-tree-delete tree)
(insert-before-markers " ") ; move parent's end-mark
@@ -300,23 +303,59 @@ This is used for labels spanning multiple lines."
(defvar scion-last-compilation-result nil
"The result of the most recently issued compilation.")
+(defvar scion-opening-session nil
+ "This variable is set temporarily when opening a file
+to indicate which session the file should obtain.")
+
(make-variable-buffer-local
- (defvar scion-mode-line " Scion"))
+ (defvar scion-modeline-string nil))
(define-minor-mode scion-mode
"\\<scion-mode-map>\
Scion: Smart Haskell mode.
\\{scion-mode-map}"
nil
- scion-mode-line
+ nil
;; Fake binding to coax `define-minor-mode' to create the keymap
'((" " 'self-insert-command))
+ (setq scion-modeline-string (scion-modeline-string))
(when scion-last-compilation-result
- (scion-highlight-notes (scion-compiler-notes) (current-buffer))))
+ (scion-highlight-notes (scion-compiler-notes) (current-buffer)))
+ (when scion-opening-session
+ (setq scion-current-session scion-opening-session)))
(define-key scion-mode-map " " 'self-insert-command)
+
+(add-to-list 'minor-mode-alist
+ `(scion-mode ,(if (featurep 'xemacs)
+ 'scion-modeline-string
+ '(:eval (scion-modeline-string)))))
+
+(defun scion-modeline-state-string (conn session)
+ (when scion-last-compilation-result
+ (destructuring-bind (tag successp notes duration nwarnings nerrors)
+ scion-last-compilation-result
+ (format "%d/%d" nerrors nwarnings))))
+
+(defun scion-modeline-string ()
+ "Return the string to display in the modeline.
+
+The string \"Scion\" is only shown if no connection is active, otherwise
+some info about the current session is shown."
+ (let ((conn (scion-current-connection)))
+ (if (not conn)
+ (and scion-mode " Scion")
+ (let ((session scion-current-session))
+ (if (not session)
+ " [?]"
+ (concat
+ "["
+ (format "#%d:" session)
+ (scion-modeline-state-string conn session)
+ "]"))))))
+
;; dummy definitions for the compiler
(defvar scion-net-coding-system)
(defvar scion-net-processes)
@@ -533,10 +572,8 @@ See also `scion-net-valid-coding-systems'.")
"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"))
+ (let* ((msg (concat (scion-prin1-to-string sexp) "\n"))
+ (string (concat (scion-net-encode-length (length msg)) msg))
;; (string (concat (scion-net-encode-length (length msg)) msg))
(coding-system (cdr (process-coding-system proc))))
(scion-log-event sexp)
@@ -559,6 +596,7 @@ EVAL'd by Lisp."
(defun scion-net-close (process &optional debug)
(setq scion-net-processes (remove process scion-net-processes))
+ (setq scion-sessions nil)
(when (eq process scion-default-connection)
(setq scion-default-connection nil))
(cond (debug
@@ -606,8 +644,8 @@ EVAL'd by Lisp."
(defun scion-net-have-input-p ()
"Return true if a complete message is available."
(goto-char (point-min))
- ;; A message is terminated by a newline.
- (search-forward "\n" nil t))
+ (and (>= (buffer-size) 6)
+ (>= (- (buffer-size) 6) (scion-net-decode-length))))
(defun scion-run-when-idle (function &rest args)
"Call FUNCTION as soon as Emacs is idle."
@@ -626,15 +664,14 @@ EVAL'd by Lisp."
(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)))
+ (let* ((length (scion-net-decode-length))
+ (start (+ 6 (point)))
+ (end (+ start length)))
+ (assert (plusp length))
+ (prog1 (save-restriction
+ (narrow-to-region start end)
+ (read (current-buffer)))
+ (delete-region (point-min) end))))
(defun scion-net-decode-length ()
"Read a 24-bit hex-encoded integer from buffer."
@@ -890,14 +927,13 @@ Bound in the connection's process-buffer.")
;; 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-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
+ (destructuring-bind (&key pid version &allow-other-keys) info
(scion-check-version version connection)
(setf (scion-pid) pid
(scion-connection-name) (format "%d" pid)))
@@ -905,7 +941,7 @@ Bound in the connection's process-buffer.")
(run-hooks 'scion-connected-hook))
(message "Connected.")))
-(defvar scion-protocol-version 1)
+(defvar scion-protocol-version 2)
(defun scion-check-version (version conn)
(or (equal version scion-protocol-version)
@@ -972,50 +1008,39 @@ Can return nil if there's no process object for the connection."
;;;;; 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.
+;;; remote procedure calls (RPCs). The basic operation is to ask the
+;;; scion-server which links against the Scion API to perform some
+;;; command and eventually return a 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.
+;;; an error occurs during the request then an error message is
+;;; printed.
;;;
;;; 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).
+;;; completion) and that shouldn't trigger errors.
;;;
-;;; 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).
+;;; We have the concept of the "current Scion session". Most RPC
+;;; requests always say what session they operate in. A session
+;;; comprises a set of files (and modules) and compiler flags. A
+;;; buffer can only be considered member of one session at any time.
+;;; The buffer-local value of `scion-current-session' contains the id
+;;; (an integer) of the current session or NIL if the module is not
+;;; part of any session.
;;;
-;;; 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.
+;;; The global variable `scion-sessions' contains a list of all
+;;; possible sessions.
-(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."))
+(defvar scion-sessions nil
+ "Contains an alist of all active sessions.")
(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."))
-
+ (defvar scion-current-session nil
+ "The id of the current session on the Haskell side.
+nil means no session.
+fixnum a specific session."))
(defun scion-current-package ()
nil)
@@ -1047,10 +1072,9 @@ This is set only in buffers bound to specific packages."))
(defmacro* scion-rex ((&rest saved-vars)
(sexp &optional
- (package '(scion-current-package))
- (thread 'scion-current-thread))
+ (session 'scion-current-session))
&rest continuations)
- "(scion-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)
+ "(scion-rex (VAR ...) (SEXP &optional SESSION) CLAUSES ...)
Remote EXecute SEXP.
@@ -1070,20 +1094,16 @@ asynchronously.
Note: don't use backquote syntax for SEXP, because Emacs20 cannot
deal with that."
- (let ((result (gensym))
- (gsexp (gensym)))
+ (let ((result (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))))))))
+ (scion-dispatch-event
+ (list :emacs-rex ,sexp nil ,session
+ (lambda (,result)
+ (destructure-case ,result
+ ,@continuations)))))))
(defun scion-eval (sexp &optional package)
"Evaluate EXPR on the Scion server and return the result."
@@ -1150,41 +1170,24 @@ deal with that."
(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))
+ (destructure-case event
+ ((:emacs-rex form package session-id continuation)
+ (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)))))))))))
+ (let ((id (incf (scion-continuation-counter))))
+ (scion-send `(:emacs-rex ,form ,package ,session-id ,id))
+ (push (cons id continuation)
+ (scion-rex-continuations))
+ ;; TODO: recompute mode lines to show pending status
+ ))
+ ((:return value id)
+ (let ((rec (assq id (scion-rex-continuations))))
+ (cond (rec (setf (scion-rex-continuations)
+ (remove rec (scion-rex-continuations)))
+ ;; TODO: recompute mode lines
+ (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."
@@ -1194,7 +1197,16 @@ deal with that."
"Stop the server we are currently connected to."
(interactive)
(scion-eval '(quit))
- (scion-disconnect))
+ (scion-disconnect)
+ (scion-set-buffer-sessions nil)
+ (setq scion-sessions nil))
+
+;; (defun scion-send-sigint ()
+;; (interactive)
+;; (ignore-errors
+;; (let ((server-buffer (get-buffer "*scion-server*")))
+;; (dele)))
+;; (signal-process ()))
(defun scion-use-sigint-for-interrupt (&optional connection)
nil)
@@ -1577,38 +1589,48 @@ PREDICATE is executed in the buffer to test."
;;; See Scion server JSON instances for details.
(defun scion-note.message (note)
- (plist-get note :message))
+ (destructure-case note
+ ((note kind loc message)
+ message)))
+
+(defun scion-note.location (note)
+ (destructure-case note
+ ((note kind loc message) loc)))
(defun scion-note.filename (note)
- (let ((loc (scion-note.location note)))
- (plist-get loc :file)))
+ (destructure-case (scion-note.location note)
+ ((:loc src . region)
+ (destructure-case src
+ ((:file name) name)
+ ((:other txt) nil)))
+ ((:no-loc txt) nil)))
+
+(defun scion-note.range (note)
+ (destructure-case (scion-note.location note)
+ ((:loc src . range) range)
+ ((:no-loc txt) nil)))
(defun scion-note.line (note)
- (when-let (region (plist-get (scion-note.location note) :region))
+ (when-let (region (scion-note.range note))
(destructuring-bind (sl sc el ec) region
sl)))
(defun scion-note.col (note)
- (when-let (region (plist-get (scion-note.location note) :region))
+ (when-let (region (scion-note.range note))
(destructuring-bind (sl sc el ec) region
sc)))
(defun scion-note.region (note buffer)
- (when-let (region (plist-get (scion-note.location note) :region))
+ (when-let (region (scion-note.range note))
(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))
+ (destructure-case note
+ ((note severity loc msg)
+ severity)))
(defun scion-location-to-region (start-line start-col end-line end-col
&optional buffer)
@@ -1730,6 +1752,133 @@ The overlay has several properties:
(when note
(return note)))))))
+
+;;;---------------------------------------------------------------------------
+;;; The buffer that shows all active sessions and compiler notes
+(defvar scion-session-view-mode-map)
+
+(define-derived-mode scion-session-view-mode fundamental-mode
+ "Scion Sessions"
+ "\\<scion-session-view-mode-map>\
+\\{scion-session-view-mode-map}
+\\{scion-popup-bufffer-mode-map}
+")
+
+(scion-define-keys scion-session-view-mode-map
+ ((kbd "RET") 'scion-session-view-default-action-or-show-details)
+ ([return] 'scion-session-view-default-action-or-show-details)
+ ([mouse-2] 'scion-session-view-default-action-or-show-details/mouse)
+ ((kbd "q") 'scion-popup-buffer-quit-function))
+
+(defun scion-session-view-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-session-view-default-action)))
+ (if fn (funcall fn) (scion-session-view-show-details))))))
+
+(defun scion-session-view-default-action-or-show-details ()
+ "Invoke the action at point, or show details."
+ (interactive)
+ (let ((fn (get-text-property (point) 'scion-session-view-default-action)))
+ (if fn (funcall fn) (scion-session-view-show-details))))
+
+(defun scion-session-view-show-details ()
+ (interactive)
+ (let* ((tree (scion-tree-at-point))
+ (note (plist-get (scion-tree.plist tree) 'note))
+ (session-id (plist-get (scion-tree.plist tree) 'session-id))
+ (inhibit-read-only t))
+ (cond ((not (scion-tree-leaf-p tree))
+ (scion-tree-toggle tree))
+ (t
+ (scion-show-source-location note t session-id)))))
+
+(defun scion-list-sessions (sessions &optional no-popup)
+ "Show all sessions and compiler notes in a tree view
+
+If NO-POPUP is non-NIL, only show the buffer if it is already visible."
+ (interactive (list scion-sessions))
+ (labels ((fill-out-buffer ()
+ (erase-buffer)
+ (scion-session-view-mode)
+ (when (null sessions)
+ (insert "[No active sessions]"))
+ (let ((collapsed-p))
+ (dolist (tree (mapcar #'scion-session-to-tree sessions))
+ (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 Sessions*")
+ (setq buffer-read-only nil)
+ (fill-out-buffer)
+ (setq buffer-read-only t))
+ (scion-with-popup-buffer ("*Scion Sessions*")
+ (fill-out-buffer))))))
+
+;; (defun scion-notes-to-files (notes)
+;; "Turn list of notes into a hashtable mapping filenames to notes."
+;; (let ((file->notes (scion-makehash #'string=)))
+;; (loop for note in notes do
+;; (progn
+;; (unless (file-name-absolute-p (scion-note.filename note))
+;; (error "Note filename not absolute: %s" note))
+;; (
+
+(defun scion-session-to-tree (session)
+ (destructuring-bind (session-id home-dir graph notes) session
+ (let ((file-nodes (mapcar (lambda (n)
+ (scion-tree-for-graph-node n notes session-id home-dir))
+ graph)))
+ (make-scion-tree :item (format "Session #%d" session-id)
+ :collapsed-p nil
+ :kids (list (make-scion-tree :item "Modules/Files"
+ :collapsed-p nil
+ :kids file-nodes))))))
+
+(defun scion-format-path-name (path root-dir)
+ "Like `file-relative-name' but keep absolute path if need be."
+ (if root-dir
+ (let ((rel (file-relative-name path root-dir)))
+ (if (and (> (length rel) 5)
+ (string= "../.." (substring rel 0 5)))
+ path
+ rel))
+ path))
+
+(defun scion-tree-for-graph-node (node notes &optional session-id home-dir)
+ (cond
+ ((eq (car node) 'modsum)
+ (destructuring-bind (module-name filename) (cdr node)
+ (let* ((file-notes
+ (reverse
+ (mapcar (lambda (note) (scion-note-to-tree note session-id))
+ (gethash filename notes nil))))
+ (num-notes (length file-notes)))
+ (make-scion-tree :item (concat
+ (propertize (format "%s" module-name)
+ 'face 'bold
+ 'font-lock-face 'bold)
+ (when (> num-notes 0)
+ (format " [%d]" num-notes))
+ (format " (%s)" (scion-format-path-name filename home-dir)))
+ :kids file-notes
+ :print-fn #'scion-tree-text-printer
+ :collapsed-p (/= num-notes 1)))))
+ (t (error "Unknown graph node type."))))
+
+(defun scion-note-to-tree (note &optional session-id)
+ (make-scion-tree :item (scion-note.message note)
+ :collapsed-p nil
+ :plist (list 'note note 'session-id session-id)))
+
;;;---------------------------------------------------------------------------
;;; The buffer that shows the compiler notes
@@ -1770,36 +1919,40 @@ The overlay has several properties:
(interactive)
(let* ((tree (scion-tree-at-point))
(note (plist-get (scion-tree.plist tree) 'note))
+ (session-id (plist-get (scion-tree.plist tree) 'session-id))
(inhibit-read-only t))
(cond ((not (scion-tree-leaf-p tree))
(scion-tree-toggle tree))
(t
- (scion-show-source-location note t)))))
+ (scion-show-source-location note t session-id)))))
-(defun scion-show-source-location (note &optional no-highlight-p)
+(defun scion-show-source-location (note &optional no-highlight-p session-id)
(save-selected-window ; show the location, but don't hijack focus.
- (scion-goto-source-location note)
+ (let ((scion-opening-session session-id))
+ (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)))
+ (save-excursion
+ (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))))
(with-current-buffer buff
- (scion-flash-region (car r) (cadr r) 0.5)))))))
+ (goto-char (point-min))
+ (forward-line (1- (scion-note.line note)))
+ (move-to-column (scion-note.col note))
+ (let ((r (scion-note.region note 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.
@@ -1976,29 +2129,32 @@ Sets the GHC flags for the library from the current Cabal project and loads it."
(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)))
+ (successp succeeded))
(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))
+ (list tag successp notes duration nwarnings nerrors))
(scion-highlight-notes notes buf)
(if (not buf)
(progn
+ (scion-update-session-view)
(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))
+ (scion-list-sessions scion-sessions)))
+ (scion-update-session-view))
+ (scion-report-status (format "%d/%d" nerrors nwarnings))
nil)))))
-(defun scion-update-compilater-notes-buffer ()
+(defun scion-update-session-view ()
"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)))
+ (when (get-buffer "*Scion Sessions*")
+ (scion-list-sessions scion-sessions)
+ ;; (scion-list-compiler-notes (scion-compiler-notes) t)
+ ))
;; ((:ok warns)
;; (setq scion-last-compilation-result
@@ -2241,14 +2397,15 @@ forces it to be off. NIL toggles the current state."
(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)
+ (scion-report-status "-/-")
+ (scion-eval-async `(file-modified ,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))
+ (destructuring-bind (ok notes) result
+ (if ok
+ (scion-report-compilation-result
+ (list :succeeded t :notes notes :duration 0.42)
+ (current-buffer))
(scion-report-status "[?]")))
nil)))))
@@ -2256,10 +2413,48 @@ forces it to be off. NIL toggles the current state."
(defvar scion-mode-line-notes nil))
(defun scion-report-status (status)
- (let ((stats-str (concat " Scion" status)))
+ (let ((stats-str (concat " " status)))
(setq scion-mode-line stats-str)
(force-mode-line-update)))
+(defun scion-graph-node.file (node)
+ (case (car node)
+ (modsum
+ (destructuring-bind (module-name filename) (cdr node)
+ filename))
+ (t (error "Not a graph node: %s" node))))
+
+(defun scion-session.session-id (session)
+ (destructuring-bind (%session-id home-dir graph notes) session
+ %session-id))
+
+(defun scion-session.graph (session)
+ (destructuring-bind (session-id home-dir graph notes) session
+ graph))
+
+(defun scion-set-buffer-sessions (session)
+ "Set the session id for each scion-enabled buffer.
+
+If SESSION is nil, clears all buffer session."
+ (let ((buffers (scion-filter-buffers (lambda () scion-mode))))
+ (dolist (buffer buffers)
+ (with-current-buffer buffer
+ (if (null session)
+ (setq scion-current-session nil)
+ (let ((session-id (scion-session.session-id session)))
+ (princ (format "set buffer session: %s %s" buffer session-id))
+ (when (and (null scion-current-session)
+ (scion-is-buffer-in-session-p buffer session))
+ (setq scion-current-session session-id))))))))
+
+(defun scion-is-buffer-in-session-p (buffer session)
+ (let ((fname (buffer-file-name buffer)))
+ (when fname
+ (let ((graph (scion-session.graph session)))
+ (find-if (lambda (n)
+ (string= fname (scion-graph-node.file n)))
+ graph)))))
+
;;;---------------------------------------------------------------------------
;;;; To be sorted
@@ -2302,7 +2497,10 @@ loaded."
(error "Invalid component"))
((scion-cabal-component-p comp)
- (let* ((curr-cabal-file (scion-eval '(current-cabal-file)))
+ (scion-load-component% comp)
+ ;; TODO: Reintegrate this code
+ (ignore
+ '(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))))
@@ -2323,16 +2521,29 @@ loaded."
(lambda (x)
(setq scion-project-root-dir root-dir)
(message (format "Cabal project loaded: %s" x))
- (scion-load-component% comp))))))))
+ (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)
+ (scion-eval-async `(create-session ,comp)
(lambda (result)
- (scion-report-compilation-result result))))
+ (scion-complete-load-component result)
+ ;; (scion-report-compilation-result result)
+ )))
+
+(defun scion-complete-load-component (result)
+ (destructuring-bind (new-session-p session-id home-dir notes graph) result
+ (if new-session-p
+ (let ((session (list session-id home-dir graph
+ (scion-make-notes notes))))
+ (push session scion-sessions)
+ (scion-set-buffer-sessions session)
+ (scion-report-compilation-result
+ (list :succeeded t :notes notes :duration 0.42)))
+ (message "Component already loaded as session #%s" session-id))))
(defun scion-cabal-component-p (comp)
(cond
@@ -2380,7 +2591,7 @@ loaded."
"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))))
+ (let ((comps (scion-eval `(list-cabal-components ,cabal-file))))
comps))
(defun scion-get-verbosity ()
View
174 scion.cabal
@@ -1,5 +1,5 @@
name: scion
-version: 0.1.0.2
+version: 0.3
license: BSD3
license-file: LICENSE
author: Thomas Schilling <nominolo@googlemail.com>
@@ -19,59 +19,65 @@ description:
category: Development
stability: provisional
build-type: Simple
-cabal-version: >= 1.6
+cabal-version: >= 1.10
extra-source-files: README.markdown
-data-files:
- emacs/*.el
- vim_runtime_path/autoload/*.vim
- vim_runtime_path/ftplugin/*.vim
- vim_runtime_path/plugin/*.vim
+--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 testing
+-- description: Enable Debugging things like QuickCheck properties, etc.
+-- default: False
-flag server
- description: Install the scion-server.
- default: True
+--flag server
+-- description: Install the scion-server.
+-- default: True
library
+ default-language: Haskell2010
build-depends:
- base == 4.*,
- Cabal >= 1.5 && < 1.7,
- containers == 0.2.*,
- directory == 1.0.*,
- filepath == 1.1.*,
- ghc >= 6.10 && < 6.12,
+ base >= 4.2 && < 4.5,
+ Cabal >= 1.8 && < 1.13,
+ containers >= 0.3 && < 0.5,
+ directory >= 1.0 && < 1.2,
+ filepath >= 1.1 && < 1.3,
+ ghc >= 6.12 && < 7.3,
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
+ multiset >= 0.1 && < 0.3,
+ time >= 1.1 && < 1.3,
+ text >= 0.11 && < 0.12,
+ process >= 1.0 && < 1.2,
+ unix-compat >= 0.2 && < 0.3,
+ bytestring >= 0.9 && < 0.10,
+ binary >= 0.5 && < 0.6,
+ old-locale >= 1.0 && < 1.1,
+ network >= 2.3 && < 2.4,
+ temporary == 1.1.*,
+ canonical-filepath == 1.0.*
+
+ hs-source-dirs: src
+ default-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.Cabal,
+ Scion.Ghc,
Scion.Session,
- Scion.Configure,
- Scion
-
- if flag(testing)
- build-depends: QuickCheck == 2.*
- cpp-options: -DDEBUG
+ Scion.Types.Compiler,
+ Scion.Types.Commands,
+ Scion.Types.Core,
+ Scion.Types.Monad,
+ Scion.Types.Note,
+ Scion.Types.Session,
+ Scion.Types.Worker,
+ Scion.Utils.Convert,
+ Scion.Utils.IO,
+ Scion.Worker.Commands,
+ Scion.Worker.Main
+ other-modules:
+ Paths_scion
- if impl(ghc > 6.11)
- cpp-options: -DHAVE_PACKAGE_DB_MODULES
+ 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)
@@ -82,65 +88,25 @@ library
ghc-options: -Wall
-executable scion-server
- if !flag(server)
- buildable: False
-
- main-is: Main.hs
- hs-source-dirs: lib server
-
+executable scion-worker
+ main-is: Worker.hs
+ hs-source-dirs: src-execs
+ default-language: Haskell2010
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
+ scion,
+ base >= 4.2 && < 4.5
+executable scion-server
+ main-is: Server.hs
+ hs-source-dirs: src-execs
+ default-language: Haskell2010
+ build-depends:
+ scion,
+ atto-lisp >= 0.2 && < 0.3,
+ attoparsec >= 0.8.5.1 && < 0.9,
+ base >= 4.2 && < 4.5,
+ bytestring >= 0.9 && < 0.10,
+ multiset >= 0.1 && < 0.3,
+ network >= 2.3 && < 2.4,
+ text >= 0.11 && < 0.12,
+ canonical-filepath == 1.0.*
View
372 src-execs/Server.hs
@@ -0,0 +1,372 @@
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+module Main where
+
+import Scion.Types.Note
+import Scion.Types.Compiler ( Extension, extensionName )
+import Scion.Types.Monad hiding ( catch )
+import Scion.Types.Session hiding ( catch )
+import Scion.Cabal
+import Scion.Session
+
+import Control.Applicative
+--import Control.Exception ( throwIO, handle, IOException )
+import Data.AttoLisp ( FromLisp(..), ToLisp(..) )
+import Data.Bits ( shiftL, (.|.) )
+import Data.Maybe ( isNothing )
+import Data.Monoid
+import Data.String
+--import Data.Char ( chr )
+import Network ( listenOn, PortID(..) )
+import Network.Socket hiding (send, sendTo, recv, recvFrom)
+import Network.Socket.ByteString
+import Numeric ( showHex )
+import System.IO
+import System.FilePath.Canonical
+import qualified Network.Socket.ByteString.Lazy as NL
+import qualified Data.AttoLisp as L
+import qualified Data.Attoparsec as A
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Char8 as S ( pack )
+import qualified Data.MultiSet as MS
+import qualified Data.Text as T
+
+data ConnectionMode
+ = TcpIp AutoSearchPorts PortNumber
+ | StdInOut
+ deriving Show
+
+type AutoSearchPorts = Bool
+
+data WireFormat
+ = Json
+ | Lisp
+ -- TODO: Maybe add a Thrift/protobuf based binary format?
+
+type KeepGoing = Bool
+
+main :: IO ()
+main = do
+ serve (TcpIp True 4040)
+
+serve :: ConnectionMode -> IO ()
+serve (TcpIp auto nr) = do
+ sock <- if auto then
+ listenOnOneOf (map PortNumber [nr .. 0xffff])
+ else
+ listenOn (PortNumber nr)
+ realPort <- socketPort sock
+ -- This output is important, it's expected by Emacs.
+ putStrLn $ "=== Listening on port: " ++ show realPort
+ hFlush stdout
+ let loop = do
+ handle (\(_e :: IOException) -> do
+ putStrLn "Connection terminated. Waiting for next client."
+ loop) $ do
+ (sock', _addr) <- accept sock
+ keep_going <- mainLoop sock' Lisp
+ if keep_going then loop else return ()
+ loop
+serve StdInOut = do
+ putStrLn "Connection mode input/output not currently supported"
+
+-- | Attempt to listen on each port in the list in turn.
+listenOnOneOf :: [PortID] -> IO Socket
+listenOnOneOf [] = error "Could not find free port"
+listenOnOneOf (p:ps) =
+ listenOn p `catch`
+ (\(ex :: IOError) ->
+ if null ps then throwIO ex else listenOnOneOf ps)
+
+mainLoop :: Socket -> WireFormat -> IO KeepGoing
+mainLoop sock Lisp = runScion $ do
+ setVerbosity deafening
+ loop
+ where
+ loop = do
+ hdr <- io $ recv sock 6
+ let mb_len = decodeLen hdr
+ case mb_len of
+ Nothing -> return True
+ Just len -> do
+ msg <- io $ recv sock len
+ io $ putStr $ "==> [" ++ show len ++ "] "
+ io $ B.putStrLn msg
+ case parseRequest msg of
+ Left err_msg -> do
+ io $ putStrLn $ "ParseError: " ++ err_msg
+ io $ sendResponse sock invalidRequestId
+ (Error ("ParseError: " ++ err_msg))
+ loop
+ Right (Request QuitServer _ _ reqId) -> do
+ io $ sendResponse sock reqId (Ok RQuitting)
+ return False
+ Right (Request cmd _ sessionId reqId) -> do
+ -- TODO: Handle exceptions
+ mb_resp <- ignoreMostErrors $ handleRequest cmd sessionId
+ case mb_resp of
+ Right resp -> do
+ io $ sendResponse sock reqId (Ok resp)
+ loop
+ Left err_msg -> do
+ io $ sendResponse sock reqId (Error err_msg)
+ loop
+mainLoop _sock Json = do
+ putStrLn "JSON is not yet supported"
+ return True
+
+sendResponse :: Socket -> RequestId -> Response -> IO ()
+sendResponse sock reqId resp =
+ let !str = encodeResponse reqId resp
+ in do
+ let len = (fromIntegral $ BL.length str)
+ putStr $ "<== [" ++ show len ++ "] "
+ BL.putStrLn str
+ n <- send sock (encodeLen len)
+ m <- NL.send sock str
+ putStrLn $ " [Sent: " ++ show n ++ "+" ++ show m ++ "]"
+ return ()
+
+encodeLen :: Int -> B.ByteString
+encodeLen n =
+ let s = showHex n "" in
+ S.pack (replicate (6 - length s) '0' ++ s)
+
+-- | Decode a 6 digit hexadecimal number.
+decodeLen :: B.ByteString -> Maybe Int
+decodeLen b | B.length b /= 6 = Nothing
+decodeLen bs = go bs (0 :: Int)
+ where
+ go b !acc = case B.uncons b of
+ Nothing -> Just acc
+ Just (w, b')
+ | w >= 48 && w <= 57 -> -- '0'..'9'
+ go b' ((acc `shiftL` 4) .|. (fromIntegral w - 48))
+ | w >= 97 && w <= 102 -> -- 'a'..'f'
+ go b' ((acc `shiftL` 4) .|. (fromIntegral w - 87))
+ | w >= 65 && w <= 70 -> -- 'A'..'F'
+ go b' ((acc `shiftL` 4) .|. (fromIntegral w - 55))
+ | otherwise -> Nothing
+
+{-
+decodeLen (B.pack (map (fromIntegral . ord) "00000a") == Just 10)
+-}
+
+newtype RequestId = RequestId Integer
+ deriving (Show)
+
+invalidRequestId :: RequestId
+invalidRequestId = RequestId (-1)
+
+data Request
+ = Request ServerCommand (Maybe T.Text) (Maybe SessionId) RequestId
+ deriving Show
+
+-- Extend this to support new commands
+data ServerCommand
+ = ConnectionInfo
+ | ListSupportedLanguages
+ | QuitServer
+ | ListAvailConfigs T.Text
+ | CreateSession SessionConfig
+ | FileModified T.Text
+ deriving Show
+
+data ServerResponse
+ = RConnectionInfo Int -- protocol version
+ | RSupportedLanguages [Extension]
+ | RQuitting
+ | RFileConfigs [SessionConfig]
+ | RSessionCreated IsNewSession SessionId FilePath Notes [ModuleSummary]
+ | RFileModifiedResult Bool Notes
+
+type IsNewSession = Bool
+
+data Response
+ = Ok ServerResponse
+ | Error String
+ | Abort
+
+instance ToLisp RequestId where
+ toLisp (RequestId n) = toLisp n
+
+instance FromLisp RequestId where
+ parseLisp e = RequestId <$> parseLisp e
+
+instance FromLisp Request where
+ parseLisp e = L.struct ":emacs-rex" Request e
+
+instance FromLisp ServerCommand where
+ parseLisp e =
+ L.struct "connection-info" ConnectionInfo e <|>
+ L.struct "list-supported-languages" ListSupportedLanguages e <|>
+ L.struct "quit" QuitServer e <|>
+ L.struct "list-cabal-components" ListAvailConfigs e <|>
+ L.struct "create-session" CreateSession e <|>
+ L.struct "file-modified" FileModified e <|>
+ (case e of
+ L.List (L.Symbol nm:_) ->
+ fail $ "Unknown server command: " ++ T.unpack nm
+ _ ->
+ fail "Invalid command syntax")
+
+instance ToLisp Response where
+ toLisp (Ok a) = L.mkStruct ":ok" [toLisp a]
+ toLisp (Error msg) = L.mkStruct ":error" [L.String (T.pack msg)]
+ toLisp Abort = L.mkStruct ":abort" []
+
+instance ToLisp ServerResponse where
+ toLisp (RConnectionInfo protoVersion) =
+ L.List [L.Symbol ":pid", L.Number 31337,
+ L.Symbol ":version", toLisp protoVersion]
+ toLisp (RSupportedLanguages exts) = toLisp exts
+ toLisp RQuitting = L.nil
+ toLisp (RFileConfigs confs) =
+ toLisp confs
+ toLisp (RSessionCreated ex sid root_path notes graph) =
+ L.List [toLisp ex, toLisp sid, toLisp (T.pack root_path), toLisp notes, toLisp graph]
+ toLisp (RFileModifiedResult inGraph notes) =
+ L.List [toLisp inGraph, toLisp notes]
+
+instance ToLisp SessionConfig where
+ toLisp (FileConfig file flags) =
+ L.List [L.Symbol ":file", fromString file,
+ toLisp (map (toLisp . T.pack) flags)]
+ toLisp conf@CabalConfig{} =
+ case sc_component conf of
+ Library -> L.List [L.Symbol ":library",
+ toLisp (T.pack (sc_cabalFile conf))]
+ Executable e ->
+ L.List [L.Symbol ":executable", fromString e,
+ toLisp (T.pack (sc_cabalFile conf))]
+ toLisp EmptyConfig{} = error "Cannot serialise EmptyConfig"
+
+instance FromLisp SessionConfig where
+ parseLisp e =
+ L.struct ":library" mkLibrary e <|>
+ L.struct ":executable" mkExecutable e <|>
+ L.struct ":file" (\f -> FileConfig (T.unpack f) []) e
+ where
+ mkLibrary :: T.Text -> SessionConfig
+ mkLibrary cabalFile = componentToSessionConfig (T.unpack cabalFile) Library
+
+ mkExecutable :: T.Text -> T.Text -> SessionConfig
+ mkExecutable exeName cabalFile =
+ componentToSessionConfig (T.unpack cabalFile)
+ (Executable (T.unpack exeName))
+
+instance ToLisp SessionId where
+ toLisp = toLisp . unsafeSessionIdToInt
+
+instance FromLisp SessionId where
+ parseLisp e = unsafeSessionIdFromInt <$> parseLisp e
+
+instance ToLisp Extension where
+ toLisp = toLisp . extensionName
+
+instance ToLisp a => ToLisp (MS.MultiSet a) where
+ toLisp = toLisp . MS.toList
+
+instance ToLisp Note where
+ toLisp (Note knd loc msg) =
+ L.mkStruct "note" [toLisp knd, toLisp loc, toLisp msg]
+
+instance ToLisp NoteKind where
+ toLisp ErrorNote = L.Symbol ":error"
+ toLisp WarningNote = L.Symbol ":warning"
+ toLisp InfoNote = L.Symbol ":info"
+ toLisp OtherNote = L.Symbol ":other"
+
+instance ToLisp Location where
+ toLisp loc | not (isValidLoc loc) =
+ L.mkStruct ":no-loc" [toLisp (T.pack (noLocText loc))]
+ toLisp loc | (src, sl, sc, el, ec) <- viewLoc loc =
+ L.mkStruct ":loc" (toLisp src : map toLisp [sl, sc, el, ec])
+
+instance ToLisp LocSource where
+ toLisp (FileSrc path) =
+ L.mkStruct ":file" [toLisp (T.pack (toFilePath path))]
+ toLisp (OtherSrc txt) =
+ L.mkStruct ":other" [toLisp (T.pack txt)]
+
+instance ToLisp ModuleSummary where
+ toLisp modsum =
+ L.mkStruct "modsum"
+ [toLisp (ms_module modsum),
+ toLisp (T.pack $ canonicalFilePath $ ms_location modsum)]
+
+instance ToLisp ModuleName where
+ toLisp modname = toLisp (moduleNametoText modname)
+
+--instance From
+
+parseRequest :: B.ByteString -> Either String Request
+parseRequest chunk =
+ case A.parseOnly L.lisp chunk of
+ Left msg -> Left msg
+ Right lsp ->
+ case L.fromLisp lsp of
+ L.Success req -> Right req
+ L.Error msg -> Left msg
+
+encodeResponse :: RequestId -> Response -> BL.ByteString
+encodeResponse reqId resp =
+ L.encode (L.List [return_kw, toLisp resp, toLisp reqId])
+ where
+ return_kw = L.Symbol ":return"
+ {-
+test1 =
+ case A.parseOnly L.lisp (S.pack "(list-supported-languages)") of
+ Left msg -> putStrLn msg
+ Right lsp ->
+ case L.fromLisp lsp :: L.Result ServerCommand of
+ L.Success c -> print c
+ L.Error msg -> putStrLn msg
+-}
+-----------------------------------------------------------------------
+
+scionProtocolVersion :: Int
+scionProtocolVersion = 2
+
+handleRequest :: ServerCommand -> Maybe SessionId -> ScionM ServerResponse
+handleRequest ConnectionInfo _ = do
+ return (RConnectionInfo scionProtocolVersion)
+handleRequest ListSupportedLanguages _ =
+ RSupportedLanguages <$> supportedLanguagesAndExtensions
+handleRequest (ListAvailConfigs file) _ =
+ RFileConfigs <$> cabalSessionConfigs (T.unpack file)
+handleRequest (CreateSession conf) _ = do
+ existing <- sessionForConfig conf
+ sid <- case existing of
+ Nothing -> createSession conf
+ Just sid_ -> return sid_
+ notes <- sessionNotes sid
+ mods <- sessionModules sid
+ home <- sessionHomeDir <$> getSessionState sid
+ return (RSessionCreated (isNothing existing) sid
+ (canonicalFilePath home) notes mods)
+handleRequest (FileModified file) (Just sid) = do
+ fileModified sid (T.unpack file)
+ let fileInModuleGraph = True -- FIXME: find out
+ RFileModifiedResult fileInModuleGraph <$> sessionNotes sid
+handleRequest (FileModified file0) Nothing = do
+ let file = T.unpack file0
+ ss <- fileSessions file
+ case ss of
+ [] ->
+ return $ RFileModifiedResult False mempty
+ sid:_ -> do
+ fileModified sid file
+ RFileModifiedResult True <$> sessionNotes sid
+
+--handleRequest (FileModififedInMemory filename newcontents) (Just sid) = do
+ -- 1. Put newcontents into a file, add that file to the module graph
+ -- import Foo.Bar
+ -- src/Foo/Bar.hs old version
+ -- /tmp/scion/Foo/Bar.hs
+-- error "unimplmented"
+
+handleRequest QuitServer _ =
+ error "handleRequest: should not have reached this point"
View
6 src-execs/Worker.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import Scion.Worker.Main ( workerMain )
+
+main = workerMain 42
+--main = soloWorkerMain
View
161 src/Scion/Cabal.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, CPP, PatternGuards #-}
+-- | Stuff related to working on top of Cabal. E.g., configuring a
+-- project.
+--
+-- Some functions are in the 'Worker' monad and can therefore be only
+-- run on a worker. This mainly includes functions that may take a
+-- while to run. Other functions are parameterised over the monad and
+-- can therefore be run where wanted.
+--
+--
+module Scion.Cabal where
+
+import Scion.Types.Core
+import Scion.Types.Session
+import Scion.Types.Worker
+
+import Data.Maybe ( isJust )
+import Data.Typeable ( Typeable )
+import Control.Monad ( when )
+import Distribution.PackageDescription.Parse
+import Distribution.Simple.Build ( initialBuildSteps )
+import Distribution.Simple.Configure
+import Distribution.Simple.LocalBuildInfo hiding ( libdir )
+import qualified Distribution.PackageDescription as PD
+import qualified Distribution.PackageDescription.Parse as PD
+import qualified Distribution.PackageDescription.Configuration as PD
+import Distribution.Simple.PreProcess ( knownSuffixHandlers )
+import Distribution.Simple.Program
+import Distribution.Simple.Setup ( defaultConfigFlags,
+ ConfigFlags(..), Flag(..) )
+import qualified Distribution.Verbosity as V ( normal, deafening, silent )
+import GHC.Paths ( ghc, ghc_pkg )
+import System.Directory
+import System.Exit ( ExitCode(..) )
+import System.FilePath ( dropFileName, takeBaseName )
+
+-- | Something went wrong inside Cabal.
+data CabalException = CabalException String
+ deriving (Typeable)
+
+instance Show CabalException where
+ show (CabalException msg) = "CabalException: " ++ msg
+
+instance Exception CabalException
+
+-- | Set up a Cabal component, (re-)configuring it if necessary.
+--
+-- Checks whether an existing configuration result exists on disk and
+-- configures the project if not. Similarly, if the existing config
+-- is outdated the project is reconfigured.
+--
+-- Configuration 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.
+--
+configureCabalProject :: SessionConfig -> FilePath
+ -> Worker LocalBuildInfo
+configureCabalProject conf@CabalConfig{} build_dir = do
+ cabal_exists <- io $ doesFileExist cabal_file
+ when (not cabal_exists) $
+ io $ throwIO $ CabalException $
+ ".cabal file does not exist: " ++ cabal_file
+ let setup_config = localBuildInfoFile build_dir
+ conf'd <- io $ doesFileExist setup_config
+ if not conf'd
+ then do
+ message verbose $ "Configuring for first time: " ++ cabal_file
+ do_configure
+ else do
+ -- check whether setup_config is up to date
+ cabal_time <- io $ getModificationTime cabal_file
+ conf_time <- io $ getModificationTime setup_config
+ if cabal_time >= conf_time
+ then do
+ message verbose $ "Reconfiguring because .cabal file is newer: "
+ ++ cabal_file
+ do_configure
+ else do
+ mb_lbi <- io $ maybeGetPersistBuildConfig build_dir
+ case mb_lbi of
+ Nothing -> do
+ message verbose $ "Reconfiguring because Cabal says so: "
+ ++ cabal_file
+ do_configure
+ Just lbi ->
+ return lbi
+
+ where
+ cabal_file = sc_cabalFile conf
+
+ do_configure =
+ ghandle (\(e :: IOError) ->
+ io $ throwIO $
+ CabalException $ "Failed to configure" ++ show e) $ do
+ gen_pkg_descr <- io $ readPackageDescription V.normal cabal_file
+ -- TODO: The following only works for build-type simple. We
+ -- should support non-standard Setup.hs as well.
+
+ -- Make sure we configure with the same version of GHC
+ let prog_conf =
+ userSpecifyPaths [("ghc", ghc), ("ghc-pkg", ghc_pkg)]
+ defaultProgramConfiguration
+ let config_flags =
+ (defaultConfigFlags prog_conf)
+ { configDistPref = Flag build_dir
+ , configVerbosity = Flag V.deafening
+ , configUserInstall = Flag True
+ -- TODO: parse flags properly
+ }
+ let root_dir = dropFileName cabal_file
+ io $ do
+ setCurrentDirectory root_dir
+ lbi <- configure (gen_pkg_descr, (Nothing, []))
+ config_flags
+ writePersistBuildConfig build_dir lbi
+ initialBuildSteps build_dir (localPkgDescr lbi) lbi V.normal
+ knownSuffixHandlers
+ return lbi
+
+availableComponents :: PD.PackageDescription -> [Component]
+availableComponents pd =
+ (if isJust (PD.library pd) then [Library] else []) ++
+ [ Executable (PD.exeName e)
+ | e <- PD.executables pd ]
+
+-- | List all possible components of the @.cabal@ given file.
+--
+-- Some components might not be available depending on the way the
+-- program is configured.
+fileComponents :: (ExceptionMonad m, MonadIO m) =>
+ FilePath -> m [Component]
+fileComponents cabal_file = do
+ ghandle (\(_ :: ExitCode) ->
+ io $ throwIO $ CabalException $ "Cannot open Cabal file: "
+ ++ cabal_file) $ do
+ gpd <- io $ PD.readPackageDescription V.silent cabal_file
+ return (availableComponents (PD.flattenPackageDescription gpd))
+
+-- | List all possible default session configs from a given @.cabal@ file.
+cabalSessionConfigs :: (ExceptionMonad m, MonadIO m) => FilePath
+ -> m [SessionConfig]
+cabalSessionConfigs cabal_file = do
+ comps <- fileComponents cabal_file
+ return (map (componentToSessionConfig cabal_file) comps)
+
+-- | Create the default configuration for a Cabal file and component.
+componentToSessionConfig :: FilePath -> Component -> SessionConfig
+componentToSessionConfig cabal_file comp =
+ CabalConfig{ sc_name = nameFromComponent comp
+ , sc_cabalFile = cabal_file
+ , sc_component = comp
+ , sc_configFlags = []
+ , sc_buildDir = Nothing
+ }
+ where
+ library_name = takeBaseName cabal_file
+
+ nameFromComponent Library = library_name
+ nameFromComponent (Executable exe_name) =
+ library_name ++ ":" ++ exe_name
View
136 src/Scion/Ghc.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE CPP, MultiParamTypeClasses #-}
+module Scion.Ghc
+ ( -- * Converting from GHC error messages
+ ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote,
+ ghcMessagesToNotes, scionColToGhcCol, fromGhcModSummary
+ )
+where
+
+import Scion.Types.Note
+import Scion.Types.Session
+import Scion.Utils.Convert
+
+import qualified ErrUtils as Ghc ( ErrMsg(..), WarnMsg, Messages )
+import qualified SrcLoc as Ghc
+import qualified HscTypes as Ghc
+import qualified Module as Ghc
+import qualified GHC 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 qualified Data.Text as T
+
+import Data.String ( fromString )
+import System.FilePath.Canonical
+
+-- * 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)
+ (ghcColToScionCol $ Ghc.srcSpanStartCol sp)
+ (Ghc.srcSpanEndLine sp)
+ (ghcColToScionCol $ 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 = T.pack (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
+
+fromGhcModSummary :: MonadIO m => Ghc.ModSummary -> m ModuleSummary
+fromGhcModSummary ms = do
+ cpath <- case Ghc.ml_hs_file (Ghc.ms_location ms) of
+ Just fp -> io $ canonical fp
+ Nothing -> error "Module has no location"
+ return $ ModuleSummary
+ { ms_module = convert (Ghc.moduleName (Ghc.ms_mod ms))
+ , ms_fileType = case Ghc.ms_hsc_src ms of
+ Ghc.HsSrcFile -> HaskellFile
+ Ghc.HsBootFile -> HaskellBootFile
+ , ms_imports =
+ map (convert . Ghc.unLoc
+ . Ghc.ideclName . Ghc.unLoc) (Ghc.ms_imps ms)
+ , ms_location = cpath
+ }
+
+instance Convert Ghc.ModuleName ModuleName where
+ convert m = fromString (Ghc.moduleNameString m)
+
+instance Convert Target Ghc.Target where
+ convert = targetToGhcTarget
+
+targetToGhcTarget :: Target -> Ghc.Target
+targetToGhcTarget (ModuleTarget mdl) =
+ Ghc.Target { Ghc.targetId = Ghc.TargetModule mdl'
+ , Ghc.targetAllowObjCode = True
+ , Ghc.targetContents = Nothing
+ }
+ where mdl' = convert mdl -- Ghc.mkModuleName (C.display mdl)
+targetToGhcTarget (FileTarget path) =
+ -- TODO: make sure paths are absolute or relative to a known directory
+ Ghc.Target { Ghc.targetId = Ghc.TargetFile path Nothing
+ , Ghc.targetAllowObjCode = True
+ , Ghc.targetContents = Nothing
+ }
+
+instance Convert ModuleName Ghc.ModuleName where
+ convert (ModuleName s) = Ghc.mkModuleName (T.unpack s)
+
+ghcColToScionCol :: Int -> Int
+#if __GLASGOW_HASKELL__ < 700
+ghcColToScionCol c=c -- GHC 6.x starts at 0 for columns
+#else
+ghcColToScionCol c=c-1 -- GHC 7 starts at 1 for columns
+#endif
+
+scionColToGhcCol :: Int -> Int
+#if __GLASGOW_HASKELL__ < 700
+scionColToGhcCol c=c -- GHC 6.x starts at 0 for columns
+#else
+scionColToGhcCol c=c+1 -- GHC 7 starts at 1 for columns
+#endif
View
421 src/Scion/Session.hs
@@ -0,0 +1,421 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings,
+ ScopedTypeVariables #-}
+-- | Basic Ideas:
+--
+-- All we need to /describe/ a session is a 'SessionConfig'. From
+-- that we can reconstruct all internal state on demand. Of course,
+-- for efficiency we do lots of caching (preferably on disk).
+--
+-- Session state stored and managed by a separate process, the Scion
+-- worker. This causes a bit of overhead, but for most actions will
+-- be negligible.
+--
+-- Most interactions will be of the form \"This file has changed,
+-- please update the state\" or \"Give me this information based on
+-- the current state.\"
+--
+module Scion.Session where
+
+import Scion.Types.Compiler
+import Scion.Types.Note
+import Scion.Types.Session
+import Scion.Types.Commands
+import Scion.Types.Monad
+--import Scion.Worker
+import Scion.Utils.Convert
+import Scion.Utils.IO
+import Scion.Cabal ( CabalException )
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception ( throwIO )
+import Control.Monad ( when, unless, forever, filterM )
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
+import Data.Char ( ord )
+import Data.Maybe
+import Data.Time.Clock ( getCurrentTime )
+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+import System.Directory ( doesFileExist, getTemporaryDirectory,
+ removeDirectoryRecursive )
+import System.Exit ( ExitCode(..) )
+import System.FilePath ( dropFileName, (</>), takeFileName,
+ makeRelative, takeDirectory )
+import System.FilePath.Canonical
+import System.IO
+import System.IO.Temp ( createTempDirectory )
+import System.PosixCompat.Files ( getFileStatus, modificationTime )
+import System.Process ( getProcessExitCode, terminateProcess )
+
+import Debug.Trace
+
+-- -------------------------------------------------------------------
+
+-- | Throw a 'ScionException' if the file does not exist.
+ensureFileExists :: FilePath -> ScionM ()
+ensureFileExists file = do
+ ok <- io $ doesFileExist file
+ when (not ok) $ scionError $ "File does not exist: " ++ file
+
+-- | Create a new session for the given session config.
+--
+-- Starts a new worker and returns the associated session ID.
+createSession :: SessionConfig
+ -> ScionM SessionId
+createSession sc0@FileConfig{ sc_fileName = file } = do
+ ensureFileExists file
+
+ mod_time <- convert . modificationTime <$> io (getFileStatus file)
+
+ starter <- getWorkerStarter
+ working_dir <- io $ canonical $ dropFileName file
+ let sc = sc0{ sc_fileName = takeFileName file }
+
+ (whdl, rslt, graph)
+ <- startWorker starter (canonicalFilePath working_dir) sc
+
+ outdir0 <- io $ getTemporaryDirectory
+ sid <- genSessionId
+ let outdir = outdir0 </> show sid
+
+ -- TODO: specify output directory to worker
+ let sess0 = SessionState
+ { sessionConfig = sc
+ , sessionConfigTimeStamp = mod_time
+ , sessionWorker = whdl
+ , sessionOutputDir = outdir
+ , sessionModuleGraph = graph
+ , sessionLastCompilation = rslt
+ , sessionHomeDir = working_dir
+ }
+
+ registerSession sid sess0
+ return sid
+
+createSession sc0@CabalConfig{ sc_cabalFile = file } = do
+ ensureFileExists file
+
+ mod_time <- convert . modificationTime <$> io (getFileStatus file)
+
+ starter <- getWorkerStarter
+ working_dir <- io $ canonical $ dropFileName file
+
+ sid <- genSessionId
+
+ build_dir <- case sc_buildDir sc0 of
+ Nothing -> do
+ tmp <- io getTemporaryDirectory
+ dir <- io $ createTempDirectory tmp "scion-dist"
+ addCleanupTodo (removeDirectoryRecursive dir)
+ return dir
+ Just d -> return d
+
+ let sc = sc0{ sc_buildDir = Just build_dir,
+ sc_cabalFile = takeFileName file -- TODO: use absolute path instead
+ }
+ (whdl, rslt, graph)
+ <- startWorker starter (canonicalFilePath working_dir) sc
+
+ let sess0 = SessionState
+ { sessionConfig = sc
+ , sessionConfigTimeStamp = mod_time
+ , sessionWorker = whdl
+ , sessionOutputDir = build_dir
+ , sessionModuleGraph = graph
+ , sessionLastCompilation = rslt
+ , sessionHomeDir = working_dir
+ }
+
+ registerSession sid sess0
+ return sid
+
+
+createSession sc@EmptyConfig{} = do
+ starter <- getWorkerStarter
+ working_dir <- io $ canonical =<< getTemporaryDirectory
+ (whdl, rslt, graph)
+ <- startWorker starter (canonicalFilePath working_dir) sc
+ outdir0 <- io $ getTemporaryDirectory
+ sid <- genSessionId
+ let outdir = outdir0 </> show sid
+ timestamp <- convert <$> io getCurrentTime
+ -- TODO: specify output directory to worker
+ let sess0 = SessionState
+ { sessionConfig = sc
+ , sessionConfigTimeStamp = timestamp
+ , sessionWorker = whdl
+ , sessionOutputDir = outdir
+ , sessionModuleGraph = graph
+ , sessionLastCompilation = rslt
+ , sessionHomeDir = working_dir
+ }
+
+ registerSession sid sess0
+ return sid
+
+-- | Stop the session and associated worker.
+destroySession :: SessionId -> ScionM ()
+destroySession sid = do
+ sess <- getSessionState sid
+ _ <- io $ stopWorker (sessionWorker sess) (Just 3)
+ unregisterSession sid
+ return ()
+
+-- | Create a temporary session that is destroyed when the
+-- continuation exits (normally or via an exception).
+withSession :: SessionConfig -> (SessionId -> ScionM a) -> ScionM a
+withSession sconf k = do
+ sid <- createSession sconf
+ k sid `gfinally` (do destroySession sid; unregisterSession sid)
+
+-- | Return messages for each node.
+sessionNotes :: SessionId -> ScionM Notes
+sessionNotes sid = do
+ compilationNotes . sessionLastCompilation <$> getSessionState sid
+
+sessionModules :: SessionId -> ScionM [ModuleSummary]
+sessionModules sid = sessionModuleGraph <$> getSessionState sid
+
+supportedLanguagesAndExtensions :: ScionM [Extension]
+supportedLanguagesAndExtensions = do
+ exts <- getExtensions
+ case exts of
+ Just e -> return e
+ Nothing -> do
+ withSession (EmptyConfig []) $ \sid -> do
+ wh <- sessionWorker <$> getSessionState sid
+ (ans, _) <- io $ callWorker wh Extensions
+ case ans of
+ AvailExtensions exts -> do
+ setExtensions exts
+ return exts
+
+-- | Notify the worker that a file has changed. The worker will then
+-- update its internal state.
+fileModified :: SessionId -> FilePath -> ScionM ()
+fileModified sid path = do
+ -- TODO: check whether file is actually part of module graph
+ -- TODO: properly merge compilation results
+ st <- getSessionState sid
+ let wh = sessionWorker st
+ (ans, _) <- io $ callWorker wh Reload
+ case ans of
+ CompResult rslt graph -> do
+ modifySessionState sid $ \ss ->
+ (ss{ sessionModuleGraph = graph
+ , sessionLastCompilation = rslt }, ())
+
+
+
+-- -------------------------------------------------------------------
+
+-- Internal: mainly for testing purposes
+ping :: SessionId -> ScionM Bool
+ping sid = do
+ st <- getSessionState sid
+ let wh = sessionWorker st
+ (ans, _) <- io $ callWorker wh Ping {-$ mkMap [("method", "ping")
+ ,("params", MsgNull)
+ ,("id", 42)]-}
+ return $ case ans of Pong -> True; _ -> False --decodeKey ans "result" == Ok ("pong" :: T.Text)
+
+-- Internal: targets are derived from the SessionConfig
+setTargets :: SessionId -> [Target] -> ScionM ()
+setTargets sid _targets = do
+ st <- getSessionState sid
+ let _targets = sessionTargets (sessionConfig st)
+
+ return ()
+
+sessionTargets :: SessionConfig -> [Target]
+sessionTargets FileConfig{ sc_fileName = f} = [FileTarget f]
+sessionTargets CabalConfig{} = []
+
+-- -------------------------------------------------------------------
+
+-- | Start a worker process.
+--
+-- Blocks until the worker is ready.
+startWorker :: WorkerStarter
+ -> FilePath -- ^ Working directory.
+ -> SessionConfig
+ -> ScionM (WorkerHandle, CompilationResult, [ModuleSummary])
+startWorker start_worker homedir conf = do
+ verb <- getVerbosity
+ io $ bracketOnError
+ (start_worker homedir [])
+ close_all $
+ \(inp, out, err, proc) -> do
+ hSetBinaryMode inp True
+ hSetBinaryMode out True
+ if verb >= deafening then forkIO (printFromHandle err) else return undefined
+ -- Wait for worker to start up.
+ wait_for_READY out
+
+ sendMessageToHandle inp conf
+ ok <- recvMessageFromHandle out
+ --killThread dumper
+ case ok of
+ Nothing -> do
+ threadDelay 2000000
+ throwIO $ CannotStartWorker "Wrong worker or worker version"
+ Just (Left msg) -> do
+ scionError $ "Worker error: " ++ msg
+ Just (Right (rslt :: CompilationResult, graph :: [ModuleSummary])) ->
+ return
+ (WorkerHandle { workerStdin = inp
+ , workerStdout = out
+ , workerStderr = err
+ , workerProcess = proc
+ , workerFlags = []
+ },
+ rslt, graph)
+ where
+ close_all (inp, out, err, _) =
+ hClose inp >> hClose out >> hClose err
+ wait_for_READY h = do
+ handle (\(_e :: IOError) -> putStrLn "Could not start worker.") $ do
+ l <- S.hGetLine h
+ if l == str_READY then return () else do
+ -- ignore other lines
+ putStrLn $ "Worker: " ++ show l
+ wait_for_READY h
+
+ str_READY = S.pack (map (fromIntegral . ord) "READY")
+ printFromHandle hdl =
+ handle (\(_e :: IOError) -> return ()) $ do
+ forever $ do
+ hWaitForInput hdl (-1)
+ s <- S.hGetNonBlocking hdl 256
+ hPutStr stderr (show hdl ++ ": ")
+ S.hPutStr stderr s
+
+-- | Stop a worker with optional timeout (in milliseconds).
+--
+-- Send the worker a @quit@ message. If it doesn't respond within the
+-- specified timeout terminate its process. A timeout of @0@
+-- terminates the process immediately.
+--
+-- Note: This function does not block; it returns immediately. You
+-- can block on the returned 'MVar' to wait for the server to exit.
+stopWorker ::
+ WorkerHandle
+ -> Maybe Int -- ^ Timeout in milliseconds. If @Nothing@ a
+ -- default will be used (currently 60s).
+ -> IO (MVar ())
+ -- ^ The returned 'MVar' is written to when the server actually
+ -- stopped.
+stopWorker h mb_timeout = do
+ stopped <- newEmptyMVar
+ let timeout = fromMaybe (60 * 1000) mb_timeout
+
+ thr <- forkIO $ do
+ sendMessageToHandle (workerStdin h) Quit
+ (_ :: Maybe Answer) <- recvMessageFromHandle (workerStdout h)
+ tryPutMVar stopped () >> return ()
+ _ <- forkIO $ do
+ let exact_timeout_us = fromIntegral timeout * 1000 :: Integer
+ timeout_us
+ | exact_timeout_us > fromIntegral (maxBound :: Int) =
+ maxBound
+ | otherwise =
+ fromIntegral exact_timeout_us
+ threadDelay timeout_us
+ exited <- getProcessExitCode (workerProcess h)
+ unless (isJust exited) $ do
+ terminateProcess (workerProcess h)
+ killThread thr
+ tryPutMVar stopped () >> return ()
+ return stopped
+
+-- | Concurrently read lines from the handle until action completes.
+--
+-- Runs the given 'IO' computation and concurrently reads lines from
+-- the handle until the 'IO' computation returns.
+collectLines ::
+ Handle -- ^ The handle to read from.
+ -> IO a -- ^ The computation to run.
+ -> IO (a, L.ByteString)
+ -- ^ Result of the computation and the output that was read while
+ -- the computation was running.
+collectLines h act = do
+ chunks_var <- newMVar []
+ collector <- forkIO $ loop chunks_var
+ result <- act
+ lines_ <- takeMVar chunks_var -- blocks the thread if necessary
+ killThread collector
+ return (result, L.fromChunks $ reverse lines_)
+ where
+ loop var =
+ handle (\(_e :: IOError) -> return ()) $ do
+ hWaitForInput h (-1)
+ modifyMVar_ var $ \cs -> do
+ chunk <- S.hGetNonBlocking h (2*4096)
+ return (chunk:cs)
+ loop var
+
+-- | Invoke an operation on the worker. Waits for worker to respond.
+--
+-- Returns the worker's response and the output it generated.
+callWorker :: WorkerHandle -> Command -> IO (Answer, L.ByteString)
+callWorker h request = do
+ collectLines (workerStderr h) $ do
+ sendMessageToHandle (workerStdin h) request
+ ans_ <- recvMessageFromHandle (workerStdout h)
+ case ans_ of
+ Just ans -> return ans
+ Nothing -> return (Error "callWorker: Could not parse answer")
+
+ignoreMostErrors :: (ExceptionMonad m, MonadIO m) =>
+ m a -> m (Either String a)
+ignoreMostErrors act = do
+ gcatches (act >>= return . Right)
+ [HandlerM $ \(ex :: CabalException) -> return (Left (show ex)),
+ HandlerM $ \(ex :: ExitCode) -> return (Left (show ex)),
+ HandlerM $ \(ex :: IOError) -> return (Left (show ex)),
+ HandlerM $ \(ex :: ScionException) -> return (Left (show ex)),
+ HandlerM $ \(ex :: PatternMatchFail) -> return (Left (show ex)),
+ HandlerM $ \(ex :: ErrorCall) -> return (Left (show ex)),
+ HandlerM $ \(ex :: RecConError) -> return (Left (show ex))
+ ]
+
+
+-- | Find the (active) sessions that the given file is part of.
+fileSessions :: FilePath -> ScionM [SessionId]
+fileSessions path = do
+ filterM (fileInSession path) =<< activeSessions
+
+fileInSession :: FilePath -> SessionId -> ScionM Bool
+fileInSession path0 sid = do
+ home <- sessionHomeDir <$> getSessionState sid
+ path <- io $ canonical $ canonicalFilePath home </> path0
+ mods <- sessionModules sid
+ return $ not $ null [ m | m <- mods, ms_location m == path ]
+
+-- | Find a session for the given configuration (if any).
+--
+-- This uses linear search, so the assumption is that there won't be
+-- too many sessions active at any one time.
+--
+-- Note that no normalisation of any flags specified inside the
+-- session occurs. So searching for an existing session with possibly
+-- different flag assignments will fail.
+sessionForConfig :: SessionConfig -> ScionM (Maybe SessionId)
+sessionForConfig conf_ = do
+ sessions <- activeSessionsFull
+ let (conf, path_) = normaliseConf conf_
+ path <- io $ canonical path_
+ --message silent $ "Sessions: " ++ show conf ++ "\n" ++
+ -- show (map (sessionConfig . snd) (M.toList sessions))
+ case [ sid | (sid, s) <- M.toList sessions
+ , sessionConfig s == conf &&
+ (if path_ /= "" then path == sessionHomeDir s else True) ]
+ of [] -> return Nothing
+ (sid:_) -> return (Just sid)
+ where
+ normaliseConf c@FileConfig{ sc_fileName = f } =
+ (c{ sc_fileName = takeFileName f }, takeDirectory f)
+ normaliseConf c@CabalConfig{ sc_cabalFile = f } =
+ (c{ sc_cabalFile = takeFileName f }, takeDirectory f)
+ normaliseConf c = (c, "")
View
57 src/Scion/Types/Commands.hs
@@ -0,0 +1,57 @@
+module Scion.Types.Commands where
+
+import Scion.Types.Compiler
+import Scion.Types.Session
+
+import Control.Applicative
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+
+data Command
+ = Ping
+ | SetConfig SessionConfig
+ | Quit
+ | Reload
+ | Extensions
+ deriving Show
+
+data Answer
+ = Pong
+ | CompResult CompilationResult [ModuleSummary]
+ | Error String
+ | Quitting
+ | AvailExtensions [Extension]
+ deriving Show
+
+instance Binary Command where
+ put Ping = putWord16le 1
+ put (SetConfig cfg) = putWord16le 2 >> put cfg
+ put Quit = putWord16le 3
+ put Reload = putWord16le 4
+ put Extensions = putWord16le 5
+
+ get = do
+ tag <- getWord16le
+ case tag of
+ 1 -> pure Ping
+ 2 -> SetConfig <$> get
+ 3 -> pure Quit
+ 4 -> pure Reload
+ 5 -> pure Extensions
+
+instance Binary Answer where
+ put Pong = putWord16le 1
+ put (CompResult r g) = putWord16le 2 >> put r >> put g
+ put (Error msg) = putWord16le 3 >> put msg
+ put Quitting = putWord16le 4
+ put (AvailExtensions exts) = putWord16le 5 >> put exts
+
+ get = do
+ tag <- getWord16le
+ case tag of
+ 1 -> pure Pong
+ 2 -> CompResult <$> get <*> get
+ 3 -> Error <$> get
+ 4 -> pure Quitting
+ 5 -> AvailExtensions <$> get
View
22 src/Scion/Types/Compiler.hs
@@ -0,0 +1,22 @@
+module Scion.Types.Compiler where
+
+import Control.Applicative
+import Data.Binary
+import Data.Binary.Get()
+import Data.Binary.Put
+import Data.String ( IsString(fromString) )
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T