├── .gitignore
├── LICENSE
├── README.md
├── Setup.hs
├── elisp
    ├── ghc-cmd.el
    ├── ghc-con.el
    ├── ghc-ident.el
    ├── ghc-log.el
    ├── ghc-macros.el
    ├── ghc-mode.el
    ├── ghc-msgs.el
    ├── ghc-process.el
    ├── ghc-repl.el
    ├── ghc-session.el
    ├── ghc-status.el
    ├── ghc-string.el
    └── ghc.el
├── ghc-server.cabal
├── scripts
    └── test-ghcs
└── src
    ├── GHC
        ├── Compat.hs
        ├── Server.hs
        └── Server
        │   ├── Cabal.hs
        │   ├── Controller
        │       ├── Context.hs
        │       ├── Debug.hs
        │       ├── Eval.hs
        │       ├── Info.hs
        │       ├── Load.hs
        │       └── REPL.hs
        │   ├── Controllers.hs
        │   ├── Defaults.hs
        │   ├── Duplex.hs
        │   ├── Eval.hs
        │   ├── Info.hs
        │   ├── Logging.hs
        │   ├── Model
        │       ├── Find.hs
        │       ├── Ghc.hs
        │       └── Info.hs
        │   ├── TH.hs
        │   └── Types.hs
    └── main
        └── Main.hs


/.gitignore:
--------------------------------------------------------------------------------
 1 | *.o
 2 | *.hi
 3 | *~
 4 | dist/
 5 | cabal-dev/
 6 | .hsenv
 7 | TAGS
 8 | tags
 9 | *.tag
10 | *.dyn_hi
11 | *.dyn_o
12 | *.elc
13 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2014, ghc-server
 2 | All rights reserved.
 3 | 
 4 | Redistribution and use in source and binary forms, with or without
 5 | modification, are permitted provided that the following conditions are met:
 6 |     * Redistributions of source code must retain the above copyright
 7 |       notice, this list of conditions and the following disclaimer.
 8 |     * Redistributions in binary form must reproduce the above copyright
 9 |       notice, this list of conditions and the following disclaimer in the
10 |       documentation and/or other materials provided with the distribution.
11 |     * Neither the name of ghc-server nor the
12 |       names of its contributors may be used to endorse or promote products
13 |       derived from this software without specific prior written permission.
14 | 
15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
18 | DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | ghc-server
 2 | ==========
 3 | 
 4 | A server interface to GHC. Work in progress. No official release yet.
 5 | 
 6 | ### Purpose
 7 | 
 8 | Server that accepts commands and responds with structured data on
 9 | compiling, type info, compiler messages, etc. via s-expressions (and
10 | possibly JSON in the future).
11 | 
12 | ### Architecture
13 | 
14 | * Asynchonrous s-expression-based communication layer
15 | * Sessions per project
16 | * Possible to connect to remote instances over TCP
17 | * Supports hsenv and sandboxes
18 | 
19 | ### Features
20 | 
21 | * Type checking
22 | * Interactive REPL
23 | * Type info of top-level or sub-expressions
24 | * Go to definition
25 | * Kind info
26 | 
27 | See TODO.org for planned features.
28 | 
29 | ### Major GHC releases supported
30 | 
31 | I test compilation against the following GHC versions:
32 | 
33 | * GHC 7.4
34 | * GHC 7.8
35 | * GHC 7.6
36 | 
37 | This is achieved via a
38 | [wrapper module](https://github.com/chrisdone/ghc-server/blob/master/src/GHC/Compat.hs)
39 | called `GHC.Compat` which wraps any function or type that has changed
40 | between GHC versions.
41 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/elisp/ghc-cmd.el:
--------------------------------------------------------------------------------
  1 | ;;; ghc-cmd.el --- Commands.
  2 | 
  3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
  4 | 
  5 | ;; This file is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3, or (at your option)
  8 | ;; any later version.
  9 | 
 10 | ;; This file is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Code:
 19 | 
 20 | (require 'ghc-con)
 21 | (require 'ghc-session)
 22 | (require 'ghc-msgs)
 23 | (require 'ghc-status)
 24 | (require 'ghc-string)
 25 | 
 26 | (defun ghc-cmd-ping ()
 27 |   "Send a ping command and print delay in milliseconds."
 28 |   (ghc-con-send
 29 |    (ghc-con)
 30 |    (make-ghc-req
 31 |     :state nil
 32 |     :cmd `(ping ,(round (* 1000 (float-time))))
 33 |     :complete 'ghc-cmd-pong-complete)))
 34 | 
 35 | (defun ghc-cmd-pong-complete (request result)
 36 |   (ecase (car result)
 37 |     (pong
 38 |      (let ((start (nth 1 result))
 39 |            (end (round (* 1000 (float-time)))))
 40 |        (message "Ping reply: %dms" (- end start))))))
 41 | 
 42 | (defun ghc-cmd-set (opt)
 43 |   "Set some GHC option."
 44 |   (ghc-con-send
 45 |    (ghc-con)
 46 |    (make-ghc-req
 47 |     :cmd `(set ,opt)
 48 |     :complete 'ghc-cmd-set-ok)))
 49 | 
 50 | (defun ghc-cmd-set-ok (request _)
 51 |   "Handler for setting options."
 52 |   (message "Option set."))
 53 | 
 54 | 
 55 | (defun ghc-cmd-cd (dir)
 56 |   "Set some GHC option."
 57 |   (ghc-con-send
 58 |    (ghc-con)
 59 |    (make-ghc-req
 60 |     :cmd `(cd ,dir)
 61 |     :complete 'ghc-cmd-cd-ok)))
 62 | 
 63 | (defun ghc-cmd-cd-ok (request _)
 64 |   "Handler for setting options."
 65 |   (message "Changed directory."))
 66 | 
 67 | 
 68 | (defun ghc-cmd-load (target)
 69 |   "Load a target (file or module)."
 70 |   (let ((session (ghc-session)))
 71 |     (let ((default-directory (ghc-session-dir session)))
 72 |       (with-current-buffer (ghc-msgs-buffer (ghc-session-name session))
 73 |         (ghc-msgs-clear)))
 74 |     (ghc-con-send
 75 |      (ghc-con)
 76 |      (make-ghc-req
 77 |       :state (ghc-session)
 78 |       :cmd `(load-target ,target)
 79 |       :filter 'ghc-cmd-load-target-filter
 80 |       :complete 'ghc-cmd-load-target-complete
 81 |       :error 'ghc-cmd-load-target-error))))
 82 | 
 83 | (defun ghc-cmd-load-target-filter (request result)
 84 |   (let ((session (ghc-req-state request)))
 85 |     (ecase (car result)
 86 |       (msg
 87 |        (with-current-buffer (ghc-msgs-buffer (ghc-session-name session))
 88 |          (let ((span (nth 2 result)))
 89 |            (cond
 90 |             ((listp span)
 91 |              (ghc-msgs-insert
 92 |               (ghc-session-dir session)
 93 |               (elt span 0)
 94 |               (elt span 1)
 95 |               (elt span 3)
 96 |               (elt span 2)
 97 |               (elt span 4)
 98 |               (nth 3 result)
 99 |               (nth 1 result)))
100 |             (t (message (nth 3 result))))))))))
101 | 
102 | (defun ghc-cmd-load-target-complete (request result)
103 |   (ecase (car result)
104 |     (failed
105 |      (setf (ghc-session-status (ghc-req-state request))
106 |            (list 'compile-error))
107 |      (message "Loading module failed.")
108 |      (ghc-status-refresh))
109 |     (succeeded
110 |      (cond
111 |       ((= 0 (nth 1 result))
112 |        (setf (ghc-session-status (ghc-req-state request))
113 |              (list 'ok 0))
114 |        (message "OK."))
115 |       (t
116 |        (setf (ghc-session-status (ghc-req-state request))
117 |              (list 'ok (nth 0 result)))
118 |        (message "OK, %d warnings." (nth 0 result))))
119 | 
120 |      (ghc-status-refresh))))
121 | 
122 | (defun ghc-cmd-load-target-error (request result)
123 |   (message "Load error: %s" (ghc-string-chomp result)))
124 | 
125 | (defun ghc-cmd-eval (string)
126 |   "Evaluate an expression and show the result in the REPL."
127 |   (ghc-con-send
128 |    (ghc-con)
129 |    (make-ghc-req
130 |     :state (current-buffer)
131 |     :cmd `(eval ,string)
132 |     :complete 'ghc-cmd-eval-complete
133 |     :filter 'ghc-cmd-eval-filter
134 |     :error 'ghc-cmd-eval-error)))
135 | 
136 | (defun ghc-cmd-eval-filter (request type)
137 |   "Handler for a completed eval command."
138 |   (ecase (car type)
139 |     (msg
140 |      (message "Ignoring log result in eval."))
141 |     (type-result
142 |      (message ":: %s" (cadr type)))
143 |     (eval-import
144 |      (message "Imported, context:\n%s"
145 |               (mapconcat 'identity
146 |                          (cadr type)
147 |                          "\n")))
148 |     (eval-stderr
149 |      (message "Stderr: %s" (cadr type)))
150 |     (eval-stdout
151 |      (message "Stdout: %s" (cadr type)))))
152 | 
153 | (defun ghc-cmd-eval-complete (request result)
154 |   "Handler for a completed eval command."
155 |   (ecase (car result)
156 |     (unit
157 |      (message "Completed."))
158 |     (eval-result
159 |      (message "Eval result: %s" (ghc-string-chomp (cadr result))))
160 |     (decl-result
161 |      (message "Declared names: %s"
162 |               (mapconcat 'identity
163 |                          (cadr result)
164 |                          ", ")))))
165 | 
166 | (defun ghc-cmd-eval-error (request error)
167 |   "Handler for a completed eval command."
168 |   (message "Evaluation error: %s"
169 |            (ghc-string-chomp (replace-regexp-in-string "\n" " " error))))
170 | 
171 | (defun ghc-cmd-info (string)
172 |   "Get the info of the given thing."
173 |   (ghc-con-send (ghc-con)
174 |                 (make-ghc-req
175 |                  :state nil
176 |                  :cmd `(info ,string)
177 |                  :complete 'ghc-cmd-info-complete
178 |                  :error 'ghc-cmd-info-error)))
179 | 
180 | (defun ghc-cmd-info-complete (request result)
181 |   (message "%s" (ghc-string-chomp (cadr result))))
182 | 
183 | (defun ghc-cmd-info-error (request error)
184 |   (message "Info error: %s" error))
185 | 
186 | (defun ghc-cmd-type (string insert)
187 |   "Get the type of the given expression."
188 |   (ghc-con-send (ghc-con)
189 |                 (make-ghc-req
190 |                  :state (when insert
191 |                           (cons (point-marker)
192 |                                 string))
193 |                  :cmd `(type-of ,string)
194 |                  :complete 'ghc-cmd-type-complete
195 |                  :error 'ghc-cmd-type-error)))
196 | 
197 | (defun ghc-cmd-type-at (filename string start-line start-col end-line end-col insert-after)
198 |   "Get the type of the given expression."
199 |   (ghc-con-send (ghc-con)
200 |                 (make-ghc-req
201 |                  :state (when insert-after
202 |                           (cons (save-excursion (goto-char (line-beginning-position))
203 |                                                 (point-marker))
204 |                                 string))
205 |                  :cmd `(type-at ,filename
206 |                                 ,string
207 |                                 ,start-line ,start-col
208 |                                 ,end-line ,end-col)
209 |                  :complete 'ghc-cmd-type-complete
210 |                  :error 'ghc-cmd-type-error)))
211 | 
212 | (defun ghc-cmd-type-complete (request result)
213 |   "Handle type info request completion."
214 |   (let ((marker-and-ident (ghc-req-state request)))
215 |     (if marker-and-ident
216 |         (save-excursion
217 |           (goto-char (car marker-and-ident))
218 |           (insert (cdr marker-and-ident) " :: " (cadr result) "\n"))
219 |       (message "Type: %s" (ghc-cmd-fontify-as-mode (ghc-string-chomp result)
220 |                                                    'haskell-mode)))))
221 | 
222 | (defun ghc-cmd-type-error (request error)
223 |   (message "Type query error: %s"
224 |            (propertize (ghc-string-chomp error) 'face 'compilation-error)))
225 | 
226 | (defun ghc-cmd-kind (string)
227 |   "Get the kind of the given type expression."
228 |   (interactive (list (read-from-minibuffer "Kind of: ")))
229 |   (ghc-con-send (ghc-con)
230 |                 (make-ghc-req
231 |                  :state nil
232 |                  :cmd `(kind-of ,string)
233 |                  :complete 'ghc-cmd-kind-complete
234 |                  :error 'ghc-cmd-kind-error)))
235 | 
236 | (defun ghc-cmd-kind-complete (request result)
237 |   (message "Kind: %s" (ghc-cmd-fontify-as-mode result 'haskell-mode)))
238 | 
239 | (defun ghc-cmd-kind-error (request error)
240 |   (message "Kind query error: %s" error))
241 | 
242 | (defun ghc-cmd-goto-loc (filename string start-line start-col end-line end-col)
243 |   "Go to the location of the given name at location."
244 |   (ghc-con-send (ghc-con)
245 |                 (make-ghc-req
246 |                  :state nil
247 |                  :cmd `(loc-at ,filename
248 |                                ,string
249 |                                ,start-line ,start-col
250 |                                ,end-line ,end-col)
251 |                  :complete 'ghc-cmd-goto-loc-complete
252 |                  :error 'ghc-cmd-goto-loc-error)))
253 | 
254 | (defun ghc-cmd-goto-loc-complete (request result)
255 |   "Jump to the file and line/col."
256 |   (destructuring-bind (fp sl el sc ec) result
257 |     (find-file fp)
258 |     (goto-char (point-min))
259 |     (forward-line (1- sl))
260 |     (forward-char (1- sc))))
261 | 
262 | (defun ghc-cmd-goto-loc-error (request error)
263 |   "Error doing stuff."
264 |   (message "%s" (propertize error
265 |                             'face 'compilation-error)))
266 | 
267 | (defun ghc-cmd-fontify-as-mode (text mode)
268 |   "Fontify TEXT as MODE, returning the fontified text."
269 |   (with-temp-buffer
270 |     (funcall mode)
271 |     (insert text)
272 |     (font-lock-fontify-buffer)
273 |     (buffer-substring (point-min) (point-max))))
274 | 
275 | (defun ghc-cmd-uses (filename string start-line start-col end-line end-col insert-after)
276 |   "Get uses of the given identifier."
277 |   (ghc-con-send (ghc-con)
278 |                 (make-ghc-req
279 |                  :state (when insert-after
280 |                           (cons (save-excursion (goto-char (line-beginning-position))
281 |                                                 (point-marker))
282 |                                 string))
283 |                  :cmd `(uses ,filename
284 |                              ,string
285 |                              ,start-line ,start-col
286 |                              ,end-line ,end-col)
287 |                  :complete 'ghc-cmd-uses-complete
288 |                  :error 'ghc-cmd-uses-error)))
289 | 
290 | (defun ghc-cmd-uses-complete (request result)
291 |   "Handle type info request completion."
292 |   (message "Type: %s" (ghc-cmd-fontify-as-mode (ghc-string-chomp (format "%S" result))
293 |                                                'haskell-mode)))
294 | 
295 | (defun ghc-cmd-uses-error (request error)
296 |   (message "Type uses error: %s"
297 |            (propertize (ghc-string-chomp error) 'face 'compilation-error)))
298 | 
299 | (provide 'ghc-cmd)
300 | 


--------------------------------------------------------------------------------
/elisp/ghc-con.el:
--------------------------------------------------------------------------------
  1 | ;;; ghc-con.el --- Connections and requests.
  2 | 
  3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
  4 | 
  5 | ;; This file is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3, or (at your option)
  8 | ;; any later version.
  9 | 
 10 | ;; This file is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Code:
 19 | 
 20 | (require 'ghc-log)
 21 | (require 'ghc-session)
 22 | (require 'ghc-macros)
 23 | (require 'cl)
 24 | 
 25 | (defstruct ghc-req
 26 |   "A request handler."
 27 |   state cmd filter complete error session)
 28 | 
 29 | (defvar ghc-con-number
 30 |   0
 31 |   "A unique request number counter.")
 32 | 
 33 | (defvar ghc-con-requests
 34 |   (make-hash-table)
 35 |   "Mapping from request ids to requests.")
 36 | 
 37 | (defvar ghc-con-buffers
 38 |   (make-hash-table)
 39 |   "Mapping from process ids to string buffers.")
 40 | 
 41 | (defun ghc-con-send (p request)
 42 |   "Send a command request and handle the results."
 43 |   (let ((rid (setq ghc-con-number (1+ ghc-con-number))))
 44 |     (setf (ghc-req-session request) (ghc-session))
 45 |     (puthash rid request ghc-con-requests)
 46 |     (let ((msg (replace-regexp-in-string
 47 |                 "\n"
 48 |                 "\\\\n"
 49 |                 (format "%S" `(request ,rid
 50 |                                        ,(ghc-req-cmd request))))))
 51 |       (ghc-log "%s" msg)
 52 |       (process-send-string
 53 |        p
 54 |        (concat msg "\n")))))
 55 | 
 56 | (defun ghc-con-process-sentinel (p sig)
 57 |   "Handles connection events."
 58 |   (cond ((string= sig "open\n")
 59 |          (message "Connected to GHC server!")
 60 |          (let ((startup ghc-session-startup))
 61 |            (when startup
 62 |              (funcall (eval startup)))))
 63 |         ((string-match "^failed " sig)
 64 |          (message "Failed to connect to GHC server. Run M-x ghc/start to start a local one."))
 65 |         ((string= sig "deleted\n")
 66 |          (message "Disconnected from GHC server!"))
 67 |         (t
 68 |          (message "Connection error (%s)"
 69 |                   (replace-regexp-in-string "\n" " " sig)))))
 70 | 
 71 | (defun ghc-con-process-filter (p data)
 72 |   "Handles incoming data."
 73 |   (let* ((pid (process-id p))
 74 |          (buffer (concat (or (gethash pid ghc-con-buffers) "") data))
 75 |          (parts (split-string buffer "\n"))
 76 |          (lines (delete "" (butlast parts)))
 77 |          (remainder (car (last parts))))
 78 |     (dolist (line lines)
 79 |       (let ((response (read line)))
 80 |         (ghc-log "%s" line)
 81 |         (let* ((rid (cadr response))
 82 |                (request (gethash rid ghc-con-requests)))
 83 |           (if request
 84 |               (ghc-con-payload rid request (car response) (caddr response))
 85 |             (message "Bogus result for non-existant request from server: %S" response)))))
 86 |     (puthash pid remainder ghc-con-buffers)))
 87 | 
 88 | (defun ghc-con-payload (rid request type payload)
 89 |   "Handle the final payload, calling appropriate handlers."
 90 |   (let* ((cmd (ghc-req-cmd request))
 91 |          (filter (ghc-req-filter request))
 92 |          (complete (ghc-req-complete request))
 93 |          (error (ghc-req-error request))
 94 |          (session (ghc-req-session request))
 95 |          (default-directory (ghc-session-dir session)))
 96 |     (message "type: %S" type)
 97 |     (case type
 98 |       (result
 99 |        (if filter
100 |            (apply filter (list request payload))
101 |          (message "Partial results are not supported by this command %S: %S"
102 |                   cmd payload)))
103 |       (end-result
104 |        (remhash rid ghc-con-requests)
105 |        (if complete
106 |            (apply complete (list request payload))
107 |          (message "End results are not supported by this command %S: %S"
108 |                   cmd payload)))
109 |       (error-result
110 |        (remhash rid ghc-con-requests)
111 |        (if error
112 |            (apply error (list request payload))
113 |          (message "Error results are not handled by this command: %S\nThe error was: %S"
114 |                   cmd payload)))
115 |       (t
116 |        (message "Bogus result type: %S" payload)))))
117 | 
118 | (defun ghc-con-create (name prompt)
119 |   "Get or create a connection."
120 |   (let* ((name (format "*ghc-server:%s*" name))
121 |          (process (get-process name)))
122 |     (if (and process (process-live-p process))
123 |         process
124 |       (progn
125 |         (when process
126 |           (delete-process process))
127 |         (let ((proc (make-network-process
128 |                 :name name
129 |                 :host (if prompt
130 |                           (read-from-minibuffer "Host: " "localhost")
131 |                         "localhost")
132 |                 :service (let ((port (if prompt
133 |                                          (string-to-number
134 |                                           (read-from-minibuffer "Port: " "5233"))
135 |                                        (ghc-let-if (port (ghc-session-port (ghc-session)))
136 |                                                    port
137 |                                                    (error "No port specified. Run M-x ghc/start to start a local server or use C-u M-x ghc/connect to specify a host/port.")))))
138 |                            (setf (ghc-session-port (ghc-session))
139 |                                  port)
140 |                            port)
141 |                 :sentinel 'ghc-con-process-sentinel
142 |                 :filter 'ghc-con-process-filter)))
143 |           (message "Connected to GHC server!")
144 |           proc)))))
145 | 
146 | (defun ghc-con-make (&optional prompt)
147 |   "Make a connection and locally assign it."
148 |   (let ((session (ghc-session)))
149 |     (let* ((name (ghc-session-name session))
150 |            (con (ghc-con-create name prompt)))
151 |       (setf (ghc-session-con session) con)
152 |       con)))
153 | 
154 | (defun ghc-con ()
155 |   "Get the current GHC connection."
156 |   (ghc-let-if (session (ghc-session-get))
157 |               (let ((proc (ghc-session-con session)))
158 |                 (if (and proc (process-live-p proc))
159 |                     proc
160 |                   (or (ghc-con-make nil)
161 |                       (error (concat "Not connected to a server. Run M-x ghc/connect to connect, "
162 |                                      "or ghc/start to start a process.")))))
163 |               (ghc-con-make)))
164 | 
165 | (defun ghc-con-disconnect ()
166 |   "Disconnect from the server."
167 |   (ghc-let-when (session (ghc-session-get))
168 |                 (delete-process (ghc-session-con session))))
169 | 
170 | (provide 'ghc-con)
171 | 


--------------------------------------------------------------------------------
/elisp/ghc-ident.el:
--------------------------------------------------------------------------------
 1 | ;;; ghc-ident.el --- Ident manipulation.
 2 | 
 3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
 4 | 
 5 | ;; This file is free software; you can redistribute it and/or modify
 6 | ;; it under the terms of the GNU General Public License as published by
 7 | ;; the Free Software Foundation; either version 3, or (at your option)
 8 | ;; any later version.
 9 | 
10 | ;; This file is distributed in the hope that it will be useful,
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 | ;; GNU General Public License for more details.
14 | 
15 | ;; You should have received a copy of the GNU General Public License
16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 | 
18 | ;;; Code:
19 | 
20 | (require 'cl)
21 | 
22 | (defun ghc-ident-at-point ()
23 |   "Return the identifier under point, or nil if none found.
24 | May return a qualified name."
25 |   (let ((reg (ghc-ident-pos-at-point)))
26 |     (when reg
27 |       (let ((s (buffer-substring-no-properties (car reg) (cdr reg))))
28 |         (if (string= "" s)
29 |             nil
30 |           s)))))
31 | 
32 | (defun ghc-ident-pos-at-point ()
33 |   "Return the span of the identifier under point, or nil if none found.
34 | May return a qualified name."
35 |   (save-excursion
36 |     ;; Skip whitespace if we're on it.  That way, if we're at "map ", we'll
37 |     ;; see the word "map".
38 |     (if (and (not (eobp))
39 |              (eq ?  (char-syntax (char-after))))
40 |         (skip-chars-backward " \t"))
41 | 
42 |     (let ((case-fold-search nil))
43 |       (multiple-value-bind (start end)
44 |           (if (looking-at "\\s_")
45 |               (list (progn (skip-syntax-backward "_") (point))
46 |                     (progn (skip-syntax-forward "_") (point)))
47 |             (list
48 |              (progn (skip-syntax-backward "w'")
49 |                     (skip-syntax-forward "'") (point))
50 |              (progn (skip-syntax-forward "w'") (point))))
51 |         ;; If we're looking at a module ID that qualifies further IDs, add
52 |         ;; those IDs.
53 |         (goto-char start)
54 |         (while (and (looking-at "[[:upper:]]") (eq (char-after end) ?.)
55 |                     ;; It's a module ID that qualifies further IDs.
56 |                     (goto-char (1+ end))
57 |                     (save-excursion
58 |                       (when (not (zerop (skip-syntax-forward
59 |                                          (if (looking-at "\\s_") "_" "w'"))))
60 |                         (setq end (point))))))
61 |         ;; If we're looking at an ID that's itself qualified by previous
62 |         ;; module IDs, add those too.
63 |         (goto-char start)
64 |         (if (eq (char-after) ?.) (forward-char 1)) ;Special case for "."
65 |         (while (and (eq (char-before) ?.)
66 |                     (progn (forward-char -1)
67 |                            (not (zerop (skip-syntax-backward "w'"))))
68 |                     (skip-syntax-forward "'")
69 |                     (looking-at "[[:upper:]]"))
70 |           (setq start (point)))
71 |         ;; This is it.
72 |         (cons start end)))))
73 | 
74 | (provide 'ghc-ident)
75 | 


--------------------------------------------------------------------------------
/elisp/ghc-log.el:
--------------------------------------------------------------------------------
 1 | ;;; ghc-log.el --- Logging buffer.
 2 | 
 3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
 4 | 
 5 | ;; This file is free software; you can redistribute it and/or modify
 6 | ;; it under the terms of the GNU General Public License as published by
 7 | ;; the Free Software Foundation; either version 3, or (at your option)
 8 | ;; any later version.
 9 | 
10 | ;; This file is distributed in the hope that it will be useful,
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 | ;; GNU General Public License for more details.
14 | 
15 | ;; You should have received a copy of the GNU General Public License
16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 | 
18 | ;;; Code:
19 | 
20 | (defvar ghc-log-p
21 |   t
22 |   "Log requests/replies?")
23 | 
24 | (defun ghc-log (fmt &rest args)
25 |   "Log using `message' if `ghc-log-p' is t."
26 |   (when ghc-log-p
27 |     (let* ((name "*ghc-log*")
28 |            (buffer (get-buffer name)))
29 |       (when (not buffer)
30 |         (setq buffer
31 |               (with-current-buffer (get-buffer-create name)
32 |                 (emacs-lisp-mode))))
33 |       (with-current-buffer buffer
34 |         (goto-char (point-max))
35 |         (insert (apply #'format
36 |                        (cons fmt args))
37 |                 "\n")))))
38 | 
39 | (provide 'ghc-log)
40 | 


--------------------------------------------------------------------------------
/elisp/ghc-macros.el:
--------------------------------------------------------------------------------
 1 | ;;; ghc-macros.el --- Some macros used in the project.
 2 | 
 3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
 4 | 
 5 | ;; This file is free software; you can redistribute it and/or modify
 6 | ;; it under the terms of the GNU General Public License as published by
 7 | ;; the Free Software Foundation; either version 3, or (at your option)
 8 | ;; any later version.
 9 | 
10 | ;; This file is distributed in the hope that it will be useful,
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 | ;; GNU General Public License for more details.
14 | 
15 | ;; You should have received a copy of the GNU General Public License
16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 | 
18 | ;;; Code:
19 | 
20 | (defmacro ghc-let-if (name-expr then else)
21 |   `(let ((,(car name-expr) ,(cadr name-expr)))
22 |      (if ,(car name-expr)
23 |          ,then
24 |        ,else)))
25 | 
26 | (defmacro ghc-let-when (name-expr then)
27 |   `(let ((,(car name-expr) ,(cadr name-expr)))
28 |      (if ,(car name-expr)
29 |          ,then)))
30 | 
31 | (provide 'ghc-macros)
32 | 


--------------------------------------------------------------------------------
/elisp/ghc-mode.el:
--------------------------------------------------------------------------------
 1 | ;;; ghc-mode.el --- Minor mode for enabling GHC interactions.
 2 | 
 3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
 4 | 
 5 | ;; This file is free software; you can redistribute it and/or modify
 6 | ;; it under the terms of the GNU General Public License as published by
 7 | ;; the Free Software Foundation; either version 3, or (at your option)
 8 | ;; any later version.
 9 | 
10 | ;; This file is distributed in the hope that it will be useful,
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 | ;; GNU General Public License for more details.
14 | 
15 | ;; You should have received a copy of the GNU General Public License
16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 | 
18 | ;;; Code:
19 | 
20 | (defvar ghc-mode-map
21 |   (let ((map (make-sparse-keymap)))
22 |     (define-key map (kbd "C-c C-l") 'ghc/load)
23 |     (define-key map (kbd "C-c C-t") 'ghc/type-at)
24 |     (define-key map (kbd "M-.") 'ghc/goto-def)
25 |     (define-key map (kbd "C-c C-i") 'ghc/info)
26 |     (define-key map (kbd "C-c M-:") 'ghc/eval)
27 |     map)
28 |   "Keymap for using ghc-mode.")
29 | 
30 | ;;;###autoload
31 | (define-minor-mode ghc-mode
32 |   "Minor mode for enabling ghc-server interaction."
33 |   :lighter " GHC"
34 |   :keymap ghc-mode-map)
35 | 
36 | (provide 'ghc-mode)
37 | 


--------------------------------------------------------------------------------
/elisp/ghc-msgs.el:
--------------------------------------------------------------------------------
  1 | ;;; ghc-msgs.el --- Messages buffer.
  2 | 
  3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
  4 | 
  5 | ;; This file is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3, or (at your option)
  8 | ;; any later version.
  9 | 
 10 | ;; This file is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Code:
 19 | 
 20 | (require 'ghc-macros)
 21 | 
 22 | (require 'dired)
 23 | (require 'cl)
 24 | 
 25 | (defface ghc-msgs-current-span
 26 |   '((((class color) (min-colors 88) (background dark))
 27 |      :background "#333")
 28 |     (((class color) (min-colors 88) (background light))
 29 |      :background "lightgoldenrod2")
 30 |     (t :background "gray"))
 31 |   "Basic face for highlighting the current message."
 32 |   :group 'ghc)
 33 | 
 34 | (define-derived-mode ghc-msgs-mode help-mode "GHC-Messages"
 35 |   "Major mode for viewing compile messages from GHC."
 36 |   (setq buffer-read-only t)
 37 |   (setq next-error-last-buffer (current-buffer))
 38 |   (setq next-error-function 'ghc-msgs-next-error))
 39 | 
 40 | (defvar ghc-msgs-current-overlay
 41 |   nil
 42 |   "Currently selected error overlay. Buffer local.")
 43 | 
 44 | (define-key ghc-msgs-mode-map (kbd "n") 'ghc-msgs-goto-next-error)
 45 | (define-key ghc-msgs-mode-map (kbd "p") 'ghc-msgs-goto-prev-error)
 46 | (define-key ghc-msgs-mode-map (kbd "g") nil)
 47 | (define-key ghc-msgs-mode-map (kbd "RET") 'ghc-msgs-jump-to-error)
 48 | 
 49 | (defun ghc-msgs-next-error (arg reset)
 50 |   "Jump to the next error, called by compilation's library."
 51 |   (loop for i from 1 to arg
 52 |         do (ghc-msgs-goto-next-error reset))
 53 |   (ghc-msgs-jump-to-error))
 54 | 
 55 | (defun ghc-msgs-jump-to-error (&optional no-jump)
 56 |   "Jump to the error at point."
 57 |   (interactive)
 58 |   (ghc-let-when
 59 |    (span (get-text-property (point) 'span))
 60 |    (if no-jump
 61 |        (save-selected-window
 62 |          (ghc-msgs-jump-to-span span))
 63 |      (ghc-msgs-jump-to-span span))))
 64 | 
 65 | (defun ghc-msgs-jump-to-span (span)
 66 |   "Jump to the given span."
 67 |   (let ((original (current-buffer)))
 68 |     (when (ghc-msgs-find-buffer-of-file (nth 0 span))
 69 |       (ghc-msgs-goto-line-col (nth 1 span)
 70 |                               (nth 2 span))
 71 |       (with-current-buffer original
 72 |         (ghc-msgs-focus-span))
 73 |       (remove-overlays (point-min) (point-max) 'ghc-msgs-next-error t)
 74 |       (let ((o (make-overlay (point)
 75 |                              (save-excursion
 76 |                                (ghc-msgs-goto-line-col (nth 3 span)
 77 |                                                        (nth 4 span))
 78 |                                (point)))))
 79 |         (overlay-put o 'ghc-msgs-next-error t)
 80 |         (overlay-put o 'priority 999)
 81 |         (overlay-put o 'face 'ghc-msgs-current-span)
 82 |         (sit-for 0.5)
 83 |         (delete-overlay o)))))
 84 | 
 85 | (defun ghc-msgs-goto-line-col (line col)
 86 |   "Jump to the given LINE and COL."
 87 |   (goto-char (point-min))
 88 |   (forward-line (1- line))
 89 |   (goto-char (+ (line-beginning-position)
 90 |                 (1- col))))
 91 | 
 92 | (defun ghc-msgs-focus-span ()
 93 |   "Focus the current span."
 94 |   (ghc-let-when
 95 |    (o ghc-msgs-current-overlay)
 96 |    (delete-overlay o))
 97 |   (let ((o (make-overlay (get-text-property (point) 'start-marker)
 98 |                          (get-text-property (point) 'end-marker))))
 99 |     (overlay-put o 'face 'ghc-msgs-current-span)
100 |     (setq ghc-msgs-current-overlay o)))
101 | 
102 | (defun ghc-msgs-find-buffer-of-file (filename)
103 |   "Find or make a buffer of the given file and switch to it. If
104 |   the buffer's already visible in the frame, switch move focus to
105 |   that."
106 |   (let ((expanded (expand-file-name filename)))
107 |     (ghc-let-if
108 |      (window (car (remove-if-not
109 |                    (lambda (window)
110 |                      (ghc-let-when (name (buffer-file-name (window-buffer window)))
111 |                                    (string= name expanded)))
112 |                    (window-list))))
113 |      (select-window window)
114 |      (find-file-other-window filename))))
115 | 
116 | (defun ghc-msgs-goto-prev-error (&optional reset)
117 |   "Jump to the next error. Cycle to the start if RESET is
118 |   specified."
119 |   (interactive)
120 |   (cond
121 |    ((= (line-beginning-position)
122 |        (line-end-position))
123 |     (forward-char -1)
124 |     (let ((start-marker (get-text-property (point) 'start-marker)))
125 |       (when start-marker (goto-char start-marker))))
126 |    (t (let ((start-marker (get-text-property (point) 'start-marker)))
127 |         (when start-marker
128 |           (goto-char start-marker)
129 |           (unless (= (point) (point-min))
130 |             (forward-char -1)
131 |             (let ((start-marker (get-text-property (point) 'start-marker)))
132 |               (when start-marker
133 |                 (goto-char start-marker))))))))
134 |   (ghc-msgs-jump-to-error t))
135 | 
136 | (defun ghc-msgs-goto-next-error (&optional reset)
137 |   "Jump to the next error. Cycle to the start if RESET is
138 |   specified."
139 |   (interactive)
140 |   (let ((end-marker (get-text-property (point) 'end-marker)))
141 |     (when end-marker
142 |       (let ((dont-move (point)))
143 |         (goto-char end-marker)
144 |         (when (not (get-text-property (point) 'end-marker))
145 |           (if reset
146 |               (goto-char (point-min))
147 |             (goto-char dont-move))))))
148 |   (ghc-msgs-jump-to-error t))
149 | 
150 | (defun ghc-msgs-buffer (name)
151 |   "From a session NAME return a messages buffer."
152 |   (let* ((name (format "*ghc-msgs:%s*" name))
153 |          (buffer (get-buffer name)))
154 |     (or buffer
155 |         (with-current-buffer (get-buffer-create name)
156 |           (ghc-msgs-mode)
157 |           (current-buffer)))))
158 | 
159 | (defun ghc-msgs-clear ()
160 |   "Clear the buffer."
161 |   (let ((inhibit-read-only t))
162 |     (setq next-error-last-buffer (current-buffer))
163 |     (erase-buffer)))
164 | 
165 | (defun ghc-msgs-insert (dir file line-start col-start line-end col-end msg severity)
166 |   "Insert an error message into the buffer."
167 |   (setq next-error-last-buffer (current-buffer))
168 |   (let ((inhibit-read-only t)
169 |         (end-marker (make-marker))
170 |         (start-marker (make-marker)))
171 |     (let ((start (point)))
172 |       (insert
173 |        (propertize
174 |         (format "%s:"
175 |                 (dired-make-relative file dir))
176 |         'face (list 'underline
177 |                     (ecase severity
178 |                       (error 'compilation-error)
179 |                       (warning 'compilation-warning-face)))
180 |         'span (list file line-start col-start line-end col-end)
181 |         'end-marker end-marker
182 |         'start-marker start-marker))
183 |       (insert
184 |        (propertize
185 |         (format "%d:%d-%d:%d"
186 |                 line-start col-start
187 |                 line-end col-end)
188 |         'face '(compilation-line-number underline)
189 |         'span (list file line-start col-start line-end col-end)
190 |         'end-marker end-marker
191 |         'start-marker start-marker))
192 |       (insert
193 |        (propertize
194 |         (format ":\n%s\n"
195 |                 msg)
196 |         'span (list file line-start col-start line-end col-end)
197 |         'end-marker end-marker
198 |         'start-marker start-marker))
199 |       (set-marker start-marker start)
200 |       (set-marker end-marker (point))
201 |       (save-excursion
202 |         (goto-char start)
203 |         (forward-line)
204 |         (indent-rigidly (point) end-marker 2)))))
205 | 
206 | (provide 'ghc-msgs)
207 | 


--------------------------------------------------------------------------------
/elisp/ghc-process.el:
--------------------------------------------------------------------------------
 1 | ;;; ghc-process.el --- Start a ghc-server process locally
 2 | 
 3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
 4 | 
 5 | ;; This file is free software; you can redistribute it and/or modify
 6 | ;; it under the terms of the GNU General Public License as published by
 7 | ;; the Free Software Foundation; either version 3, or (at your option)
 8 | ;; any later version.
 9 | 
10 | ;; This file is distributed in the hope that it will be useful,
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 | ;; GNU General Public License for more details.
14 | 
15 | ;; You should have received a copy of the GNU General Public License
16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 | 
18 | ;;; Code:
19 | 
20 | (defun ghc-process-start (port dir name)
21 |   "Start a ghc-process."
22 |   (let ((default-directory dir))
23 |     (with-current-buffer (get-buffer-create (format "*ghc-server:%s*" name))
24 |       (shell (current-buffer))
25 |       (insert "ghc-server --port "
26 |               (format "%d" port))
27 |       (comint-send-input nil t)
28 |       (bury-buffer (current-buffer)))))
29 | 
30 | (defun ghc-process-free-port ()
31 |   "Return a free (unused) TCP port.
32 | 
33 | The port is chosen randomly from the ephemeral ports."
34 |   (let* (myserver
35 |          (base 5233)
36 |          (port base))
37 |     (while
38 |         (not
39 |          (processp
40 |           (condition-case sig
41 |               (setq myserver
42 |                     (make-network-process
43 |                      :name "*test-proc*"
44 |                      :server t
45 |                      :nowait 't
46 |                      :host 'local
47 |                      :service port
48 |                      :family 'ipv4))
49 |             (file-error
50 |              (if (equal
51 |                   "Cannot bind server socket address already in use"
52 |                   (mapconcat 'identity (cdr sig) " "))
53 |                  (setq port (+ base (random 5000)))))))))
54 |     (delete-process myserver)
55 |     port))
56 | 
57 | (provide 'ghc-process)
58 | 


--------------------------------------------------------------------------------
/elisp/ghc-repl.el:
--------------------------------------------------------------------------------
  1 | ;;; ghc-repl.el --- A REPL for GHC.
  2 | 
  3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
  4 | 
  5 | ;; This file is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3, or (at your option)
  8 | ;; any later version.
  9 | 
 10 | ;; This file is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Code:
 19 | 
 20 | (require 'ring)
 21 | 
 22 | (require 'ghc-con)
 23 | (require 'ghc-msgs)
 24 | 
 25 | (defvar ghc-repl-prompt-start
 26 |   nil
 27 |   "Marker for the start of the prompt.")
 28 | 
 29 | (defvar ghc-repl-prompt-ring
 30 |   nil
 31 |   "Ring used for the prompt history.")
 32 | 
 33 | (define-derived-mode ghc-repl-mode fundamental-mode "GHC-REPL"
 34 |   "Major mode for a prompt-based interaction with GHC."
 35 |   (set (make-local-variable 'ghc-repl-prompt-start)
 36 |        (make-marker))
 37 |   (set (make-local-variable 'ghc-repl-prompt-ring)
 38 |        (make-ring 512))
 39 |   (ghc-repl-prompt))
 40 | 
 41 | (define-key ghc-repl-mode-map (kbd "C-a") 'ghc-repl-bol)
 42 | (define-key ghc-repl-mode-map (kbd "M-p") 'ghc-repl-history-prev)
 43 | (define-key ghc-repl-mode-map (kbd "M-n") 'ghc-repl-history-next)
 44 | (define-key ghc-repl-mode-map (kbd "RET") 'ghc-repl-return)
 45 | (define-key ghc-repl-mode-map (kbd "C-c C-k") 'ghc-repl-clear)
 46 | 
 47 | (defun ghc-repl-history-prev (n)
 48 |   "Go back in history."
 49 |   (interactive "p")
 50 |   (ghc-repl-nav-history n))
 51 | 
 52 | (defun ghc-repl-history-next (n)
 53 |   "Go forward in history."
 54 |   (interactive "p")
 55 |   (ghc-repl-nav-history (- n)))
 56 | 
 57 | (defun ghc-repl-nav-history (offset)
 58 |   "Rotate the history ring and show the top of it."
 59 |   (let ((index (ghc-let-if (index (save-excursion
 60 |                                     (goto-char ghc-repl-prompt-start)
 61 |                                     (get-text-property (point) 'ghc-repl-prompt-index)))
 62 |                            (+ index offset)
 63 |                            0)))
 64 |     (ghc-repl-set-prompt
 65 |      (propertize (ring-ref ghc-repl-prompt-ring index)
 66 |                  'ghc-repl-prompt-index
 67 |                  index))))
 68 | 
 69 | (defun ghc-repl-push-history (text)
 70 |   "Push a history item onto the ring."
 71 |   (ring-insert ghc-repl-prompt-ring text))
 72 | 
 73 | (defun ghc-repl-set-prompt (text)
 74 |   "Set the text at the prompt."
 75 |   (goto-char ghc-repl-prompt-start)
 76 |   (delete-region ghc-repl-prompt-start
 77 |                  (point-max))
 78 |   (insert text))
 79 | 
 80 | (defun ghc-repl-bol ()
 81 |   "Go to beginning of line."
 82 |   (interactive)
 83 |   (if (>= (point) ghc-repl-prompt-start)
 84 |       (goto-char ghc-repl-prompt-start)
 85 |     (if (or (get-text-property (point) 'old-input)
 86 |             (get-text-property (1- (point)) 'old-input))
 87 |         (goto-char (or (get-text-property (point) 'start-point)
 88 |                        (get-text-property (1- (point)) 'start-point)))
 89 |       (goto-char (line-beginning-position)))))
 90 | 
 91 | (defun ghc-repl-return ()
 92 |   "Handle return in the REPL."
 93 |   (interactive)
 94 |   (if (get-text-property (point) 'old-input)
 95 |       (let ((text (buffer-substring-no-properties (get-text-property (point) 'start-point)
 96 |                                                   (get-text-property (point) 'end-point))))
 97 |         (goto-char (point-max))
 98 |         (ghc-repl-clear-prompt)
 99 |         (insert text))
100 |     (save-excursion
101 |       (let ((input (buffer-substring-no-properties ghc-repl-prompt-start
102 |                                                    (point-max))))
103 |         (ghc-repl-eval input)))))
104 | 
105 | (defun ghc-repl-clear-prompt ()
106 |   "Clear the current prompt."
107 |   (delete-region ghc-repl-prompt-start
108 |                  (point-max)))
109 | 
110 | (defun ghc-repl-clear ()
111 |   "Clear the buffer."
112 |   (interactive)
113 |   (let ((inhibit-read-only t))
114 |     (setq next-error-last-buffer (current-buffer))
115 |     (erase-buffer)
116 |     (ghc-repl-prompt)))
117 | 
118 | (defun ghc-repl-buffer (name)
119 |   "From a session NAME return a REPL buffer."
120 |   (let* ((name (format "*ghc-repl:%s*" name))
121 |          (buffer (get-buffer name)))
122 |     (or buffer
123 |         (with-current-buffer (get-buffer-create name)
124 |           (ghc-repl-mode)
125 |           (current-buffer)))))
126 | 
127 | (defun ghc-repl-prompt ()
128 |   "Insert the REPL prompt."
129 |   (let ((inhibit-read-only t))
130 |     (insert
131 |      (propertize "λ>"
132 |                  'face 'font-lock-keyword-face
133 |                  'read-only t)
134 |      (propertize " "
135 |                  'read-only t
136 |                  'rear-nonsticky t))
137 |     (set-marker ghc-repl-prompt-start (point))))
138 | 
139 | (defun ghc-repl-eval-filter (request type)
140 |   "Handler for a completed eval command."
141 |   (ecase (car type)
142 |     (type-result
143 |      (ghc-repl-complete-prompt)
144 |      (ghc-repl-result (concat ":: " (cadr type))))
145 |     (eval-import
146 |      (message "Imported, context:\n%s"
147 |               (mapconcat 'identity
148 |                          (cadr type)
149 |                          "\n")))
150 |     (log-result
151 |      (message "%s"
152 |               (propertize (nth 3 type) 'face 'compilation-warning)))
153 |     (eval-stdout
154 |      (ghc-repl-complete-prompt)
155 |      (ghc-repl-stdout (cadr type)))))
156 | 
157 | (defun ghc-repl-complete-prompt ()
158 |   "Complete a finished prompt, make it read-only, re-usable and
159 |   start a new prompt."
160 |   (let ((inhibit-read-only t))
161 |     (goto-char (point-max))
162 |     (unless (or (= (line-end-position) (line-beginning-position))
163 |                 (get-text-property (1- (point)) 'stdout)
164 |                 (get-text-property (1- (point)) 'repl-result))
165 |       (put-text-property ghc-repl-prompt-start (point-max)
166 |                          'old-input t)
167 |       (put-text-property ghc-repl-prompt-start (point-max)
168 |                          'start-point (marker-position ghc-repl-prompt-start))
169 |       (put-text-property ghc-repl-prompt-start (point-max)
170 |                          'end-point (point-max))
171 |       (let ((end (point)))
172 |         (insert (propertize "\n" 'prompt-complete-newline t))
173 |         (put-text-property ghc-repl-prompt-start end
174 |                            'read-only t)))))
175 | 
176 | (defun ghc-repl-eval-complete (request result)
177 |   "Handler for a completed eval command."
178 |   (with-current-buffer (ghc-repl-buffer (ghc-session-name (ghc-req-session request)))
179 |     (ghc-repl-complete-prompt)
180 |     (when result
181 |       (ecase (car result)
182 |         (new-context
183 |          (message "New context: %s" (mapconcat 'identity
184 |                                                (cadr result)
185 |                                                ", ")))
186 |         (eval
187 |          (ghc-repl-result result))
188 |         (decl-resul
189 |          (if (and (consp result)
190 |                   (not (equalp result (list "it"))))
191 |              (ghc-repl-output
192 |               (concat (propertize "Declared names: " 'face 'font-lock-comment-face)
193 |                       (format "%s"
194 |                               (mapconcat (lambda (name)
195 |                                            (propertize name 'face 'font-lock-reference-face))
196 |                                          result
197 |                                          (propertize ", "
198 |                                                      'face 'font-lock-comment-face)))))
199 |            (insert "\n")))))
200 |     (ghc-repl-prompt)))
201 | 
202 | (defun ghc-repl-result (result)
203 |   "Insert an evaluation result."
204 |   (let ((inhibit-read-only t))
205 |     (unless (and (looking-back "\n")
206 |                  (or (= (line-beginning-position) (line-end-position))
207 |                      (get-text-property (1- (point))
208 |                                         'prompt-complete-newline)
209 |                      (get-text-property (1- (point))
210 |                                         'repl-result)))
211 |       (insert "\n"))
212 |     (insert (propertize (ghc-repl-fontify-as-mode result 'haskell-mode)
213 |                         'repl-result t)
214 |             "\n")))
215 | 
216 | (defun ghc-repl-stdout (result)
217 |   "Insert stdout output."
218 |   (let ((inhibit-read-only t))
219 |     (insert (propertize result
220 |                         'face 'font-lock-string-face
221 |                         'stdout t))))
222 | 
223 | (defun ghc-repl-fontify-as-mode (text mode)
224 |   "Fontify TEXT as MODE, returning the fontified text."
225 |   (with-temp-buffer
226 |     (funcall mode)
227 |     (insert text)
228 |     (font-lock-fontify-buffer)
229 |     (buffer-substring (point-min) (point-max))))
230 | 
231 | (defun ghc-repl-output (result)
232 |   "Insert an evaluation output."
233 |   (insert result "\n"))
234 | 
235 | (defun ghc-repl-eval-error (request error)
236 |   "Handler for a completed eval command."
237 |   (message "%s"
238 |            (propertize (replace-regexp-in-string "\n" " " error)
239 |                        'face
240 |                        'compilation-error))
241 |   (with-current-buffer (ghc-repl-buffer (ghc-session-name (ghc-req-session request)))
242 |     (ghc-repl-complete-prompt)
243 |     (ghc-repl-prompt)))
244 | 
245 | (defun ghc-repl-eval (string)
246 |   "Evaluate an expression and show the result in the REPL."
247 |   (ghc-repl-push-history string)
248 |   (ghc-con-send
249 |    (ghc-con)
250 |    (make-ghc-req
251 |     :state (current-buffer)
252 |     :cmd `(eval ,string)
253 |     :complete 'ghc-repl-eval-complete
254 |     :filter 'ghc-repl-eval-filter
255 |     :error 'ghc-repl-eval-error)))
256 | 
257 | (provide 'ghc-repl)
258 | 


--------------------------------------------------------------------------------
/elisp/ghc-session.el:
--------------------------------------------------------------------------------
  1 | ;;; ghc-session.el --- Manage directory-specific sessions.
  2 | 
  3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
  4 | 
  5 | ;; This file is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3, or (at your option)
  8 | ;; any later version.
  9 | 
 10 | ;; This file is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Code:
 19 | 
 20 | (require 'ghc-macros)
 21 | (require 'cl)
 22 | 
 23 | (defvar ghc-session-startup
 24 |   nil
 25 |   "A startup function to run when connected.")
 26 | 
 27 | (defstruct ghc-session
 28 |   "A ghc-server session."
 29 |   name con dir port status)
 30 | 
 31 | (defmacro ghc-session-migrate (name)
 32 |   "Add a new slot to the given session. Used for development."
 33 |   `(setq ,name
 34 |          (apply 'vector (append (map 'list #'identity ,name)
 35 |                                 (list nil)))))
 36 | 
 37 | (defvar ghc-session
 38 |   nil
 39 |   "Buffer-local variable for current session.")
 40 | 
 41 | (defvar ghc-session-list
 42 |   nil
 43 |   "A list of all active sessions.")
 44 | 
 45 | (defun ghc-session ()
 46 |   "Get, or figure out and set, the current session."
 47 |   (or (ghc-session-get)
 48 |       (ghc-session-bet)
 49 |       (ghc-session-set)))
 50 | 
 51 | (defun ghc-session-get ()
 52 |   "Get the current session."
 53 |   ghc-session)
 54 | 
 55 | (defun ghc-session-bet ()
 56 |   "Take a gamble that the directory will match one of the
 57 |   sessions in the session list."
 58 |   (ghc-let-when
 59 |    (file (ghc-session-find-cabal-file))
 60 |    (let ((dir (file-name-directory file)))
 61 |      (set (make-local-variable 'ghc-session)
 62 |           (car (remove-if-not
 63 |                 (lambda (s)
 64 |                   (string= (ghc-session-dir s)
 65 |                            dir))
 66 |                 ghc-session-list))))))
 67 | 
 68 | (defun ghc-session-set ()
 69 |   "Set the current session."
 70 |   (let* ((file (ghc-session-find-cabal-file))
 71 |          (dir (if file
 72 |                   (file-name-directory file)
 73 |                 default-directory))
 74 |          (name (if file
 75 |                    (ghc-session-unique-name
 76 |                     (replace-regexp-in-string "\\.cabal$"
 77 |                                               ""
 78 |                                               (file-name-nondirectory file)))
 79 |                  (ghc-session-unique-name "ghc-server")))
 80 |          (session (make-ghc-session :name name :con nil :dir dir)))
 81 |     (add-to-list 'ghc-session-list session)
 82 |     (set (make-local-variable 'ghc-session)
 83 |          session)))
 84 | 
 85 | (defun ghc-session-unique-name (name)
 86 |   "Generate a unique name by avoiding conflicts with anything in
 87 |   `ghc-session-list'."
 88 |   (if (remove-if-not (lambda (existing) (string= (ghc-session-name existing) name))
 89 |                      ghc-session-list)
 90 |       (ghc-session-unique-name (concat name "'"))
 91 |     name))
 92 | 
 93 | (defun ghc-session-find-cabal-file (&optional dir)
 94 |   "Search for package description file upwards starting from DIR.
 95 | If DIR is nil, `default-directory' is used as starting point for
 96 | directory traversal.  Upward traversal is aborted if file owner
 97 | changes.  Uses`haskell-cabal-find-pkg-desc' internally."
 98 |   (catch 'found
 99 |     (let ((user (nth 2 (file-attributes (or dir default-directory))))
100 |           ;; Abbreviate, so as to stop when we cross ~/.
101 |           (root (abbreviate-file-name (or dir default-directory))))
102 |       ;; Traverse current dir up to root as long as file owner doesn't
103 |       ;; change.
104 |       (while (and root (equal user (nth 2 (file-attributes root))))
105 |         (let ((cabal-file (ghc-session-find-pkg-desc root)))
106 |           (when cabal-file
107 |             (throw 'found cabal-file)))
108 | 
109 |         (let ((proot (file-name-directory (directory-file-name root))))
110 |           (if (equal proot root) ;; fix-point reached?
111 |               (throw 'found nil)
112 |             (setq root proot))))
113 |       nil)))
114 | 
115 | (defun ghc-session-find-pkg-desc (dir &optional allow-multiple)
116 |   "Find a package description file in the directory DIR.
117 | Returns nil if none or multiple \".cabal\" files were found.  If
118 | ALLOW-MULTIPLE is non nil, in case of multiple \".cabal\" files,
119 | a list is returned instead of failing with a nil result."
120 |   (let* ((cabal-files
121 |           (remove-if 'file-directory-p
122 |                      (remove-if-not 'file-exists-p
123 |                                     (directory-files dir t ".\\.cabal\\'")))))
124 |     (cond
125 |      ((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found
126 |      (allow-multiple cabal-files) ;; pass-thru multiple candidates
127 |      (t nil))))
128 | 
129 | (provide 'ghc-session)
130 | 


--------------------------------------------------------------------------------
/elisp/ghc-status.el:
--------------------------------------------------------------------------------
  1 | ;;; ghc-status.el --- Project status view.
  2 | 
  3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
  4 | 
  5 | ;; This file is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3, or (at your option)
  8 | ;; any later version.
  9 | 
 10 | ;; This file is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Code:
 19 | 
 20 | (require 'ghc-repl)
 21 | (require 'ghc-session)
 22 | (require 'ghc-msgs)
 23 | 
 24 | (define-derived-mode ghc-status-mode help-mode "GHC-Status"
 25 |   "Major mode for viewing project status from GHC."
 26 |   (setq buffer-read-only t)
 27 |   (ghc-status-revert))
 28 | 
 29 | (define-key ghc-status-mode-map (kbd "g") 'ghc-status-revert)
 30 | (define-key ghc-status-mode-map (kbd "G") 'magit-status)
 31 | (define-key ghc-status-mode-map (kbd "r") 'ghc-status-repl)
 32 | (define-key ghc-status-mode-map (kbd "c") 'ghc-status-cabal)
 33 | (define-key ghc-status-mode-map (kbd "m") 'ghc-status-messages)
 34 | (define-key ghc-status-mode-map (kbd "l") 'ghc-status-log)
 35 | 
 36 | (defun ghc-status-log ()
 37 |   (interactive)
 38 |   (switch-to-buffer (format "*ghc-server:%s*" (ghc-session-name (ghc-session)))))
 39 | 
 40 | (defun ghc-status-cabal ()
 41 |   "Open the .cabal file."
 42 |   (interactive)
 43 |   (find-file (ghc-session-find-cabal-file)))
 44 | 
 45 | (defun ghc-status-messages ()
 46 |   "Open the messages buffer."
 47 |   (interactive)
 48 |   (let ((default-directory (ghc-session-dir (ghc-session))))
 49 |     (switch-to-buffer (ghc-msgs-buffer (ghc-session-name (ghc-session))))))
 50 | 
 51 | (defun ghc-status-repl ()
 52 |   "Start the REPL."
 53 |   (interactive)
 54 |   (let ((default-directory (ghc-session-dir ghc-session)))
 55 |     (switch-to-buffer (ghc-repl-buffer (ghc-session-name ghc-session)))))
 56 | 
 57 | (defun ghc-status-buffer (name)
 58 |   "From a session NAME return a status buffer."
 59 |   (let* ((name (format "*ghc-status:%s*" name))
 60 |          (buffer (get-buffer name)))
 61 |     (or buffer
 62 |         (setq buffer
 63 |               (with-current-buffer (get-buffer-create name)
 64 |                 (ghc-status-mode)
 65 |                 (current-buffer))))
 66 |     buffer))
 67 | 
 68 | (defun ghc-status-refresh ()
 69 |   "Refresh the status buffer, open it if it's not open."
 70 |   (let ((default-directory (ghc-session-dir (ghc-session))))
 71 |     (with-current-buffer (ghc-status-buffer (ghc-session-name (ghc-session)))
 72 |       (ghc-status-revert))))
 73 | 
 74 | (defun ghc-status-revert ()
 75 |   "Revert status."
 76 |   (interactive)
 77 |   (let ((inhibit-read-only t))
 78 |     (erase-buffer)
 79 |     (let ((s (ghc-session)))
 80 |       (insert (propertize "Name:         " 'face 'font-lock-keyword)
 81 |               (ghc-session-name s)
 82 |               "\n")
 83 |       (insert (propertize "Directory:    " 'face 'font-lock-keyword)
 84 |               (ghc-session-dir s)
 85 |               "\n")
 86 |       (if (ghc-session-con s)
 87 |           (insert (propertize "Connection:   " 'face 'font-lock-keyword)
 88 |                   (if (eq 'open (process-status (ghc-session-con s)))
 89 |                       (apply 'format "%s:%d" (process-contact (ghc-session-con s)))
 90 |                     (propertize "Disconnected" 'face 'font-lock-warning-face))
 91 |                   "\n")
 92 |         (insert (propertize "Connection:   " 'face 'font-lock-keyword)
 93 |                 "—"
 94 |                 "\n"))
 95 |       (insert (propertize "Status:       " 'face 'font-lock-keyword)
 96 |               (ghc-let-if (status (ghc-session-status s))
 97 |                           (ecase (car status)
 98 |                             (ok (if (= 0 (cadr status))
 99 |                                     "OK"
100 |                                   (concat "OK "
101 |                                           (propertize (format "(%d warnings)" (cadr status))
102 |                                                       'face 'compilation-warning))))
103 |                             (compile-error (propertize "Compile error"
104 |                                                        'face 'compilation-error)))
105 |                           "?")
106 |               "\n"))
107 |     (insert "\n")
108 |     (insert (propertize "Keys:         " 'face 'font-lock-keyword)
109 |             (propertize "g" 'face 'font-lock-keyword)
110 |             " - refresh, "
111 |             (propertize "r" 'face 'font-lock-keyword)
112 |             " - repl, "
113 |             (propertize "m" 'face 'font-lock-keyword)
114 |             " - messages\n              "
115 |             (propertize "b" 'face 'font-lock-keyword)
116 |             " - build, "
117 |             (propertize "c" 'face 'font-lock-keyword)
118 |             " - open .cabal file, "
119 |             (propertize "G" 'face 'font-lock-keyword)
120 |             " - magit")
121 |     (insert "\n")
122 |     (goto-char (point-min))))
123 | 
124 | (provide 'ghc-status)
125 | 


--------------------------------------------------------------------------------
/elisp/ghc-string.el:
--------------------------------------------------------------------------------
 1 | ;;; ghc-string.el --- Some string utilities.
 2 | 
 3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
 4 | 
 5 | ;; This file is free software; you can redistribute it and/or modify
 6 | ;; it under the terms of the GNU General Public License as published by
 7 | ;; the Free Software Foundation; either version 3, or (at your option)
 8 | ;; any later version.
 9 | 
10 | ;; This file is distributed in the hope that it will be useful,
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 | ;; GNU General Public License for more details.
14 | 
15 | ;; You should have received a copy of the GNU General Public License
16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 | 
18 | ;;; Code:
19 | 
20 | (defun ghc-string-chomp (str)
21 |   "Chomp leading and tailing whitespace from STR."
22 |   (while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'"
23 |                        str)
24 |     (setq str (replace-match "" t t str)))
25 |   str)
26 | 
27 | (provide 'ghc-string)
28 | 


--------------------------------------------------------------------------------
/elisp/ghc.el:
--------------------------------------------------------------------------------
  1 | ;;; ghc.el --- Communication with ghc-server.
  2 | 
  3 | ;; Copyright (c) 2014 Chris Done. All rights reserved.
  4 | 
  5 | ;; This file is free software; you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation; either version 3, or (at your option)
  8 | ;; any later version.
  9 | 
 10 | ;; This file is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | ;;; Code:
 19 | 
 20 | (require 'ghc-con)
 21 | (require 'ghc-cmd)
 22 | (require 'ghc-mode)
 23 | (require 'ghc-repl)
 24 | (require 'ghc-status)
 25 | (require 'ghc-ident)
 26 | (require 'ghc-process)
 27 | 
 28 | (require 'tramp)
 29 | 
 30 | (defun ghc/start ()
 31 |   "Start a service process."
 32 |   (interactive)
 33 |   (let ((port (ghc-process-free-port))
 34 |         (session (ghc-session)))
 35 |     (ghc-process-start
 36 |      port
 37 |      (ghc-session-dir session)
 38 |      (ghc-session-name session))
 39 |     (setf (ghc-session-port (ghc-session))
 40 |           port)))
 41 | 
 42 | (defun ghc/connect (prompt)
 43 |   "Connect if not connected."
 44 |   (interactive "P")
 45 |   (ghc-con-make prompt))
 46 | 
 47 | (defun ghc/disconnect ()
 48 |   "Disconnect."
 49 |   (interactive)
 50 |   (ghc-con-disconnect))
 51 | 
 52 | (defun ghc/ping ()
 53 |   "Ping to check if connection's working."
 54 |   (interactive)
 55 |   (ghc-cmd-ping))
 56 | 
 57 | (defun ghc/cd (dir)
 58 |   "Change ghc working directory."
 59 |   (interactive "D")
 60 |   (ghc-cmd-cd (expand-file-name dir)))
 61 | 
 62 | (defun ghc/load ()
 63 |   "Load the current module."
 64 |   (interactive)
 65 |   (save-buffer)
 66 |   (if (eq major-mode 'haskell-mode)
 67 |       (ghc-cmd-load (let ((name (file-relative-name
 68 |                                  (buffer-file-name)
 69 |                                  (ghc-session-dir (ghc-session)))))
 70 |                       (if (tramp-tramp-file-p name)
 71 |                           (let ((vec (tramp-dissect-file-name name)))
 72 |                             (tramp-file-name-localname vec))
 73 |                         name)))
 74 |     (ghc-cmd-load (read-from-minibuffer "Load: "))))
 75 | 
 76 | (defun ghc/set (opt)
 77 |   "Set some GHC option e.g. -Wall."
 78 |   (interactive (list (read-from-minibuffer "Option: ")))
 79 |   (ghc-cmd-set opt))
 80 | 
 81 | (defun ghc/eval (string)
 82 |   "Evaluate an expression and show the result in the REPL."
 83 |   (interactive (list (read-from-minibuffer "Eval: ")))
 84 |   (ghc-cmd-eval string))
 85 | 
 86 | (defun ghc/info (string)
 87 |   "Get the info of the given thing."
 88 |   (interactive (list (or (ghc-ident-at-point)
 89 |                          (read-from-minibuffer "Info of: "))))
 90 |   (ghc-cmd-info string))
 91 | 
 92 | (defun ghc/kind (string)
 93 |   "Get the kind of the given type expression."
 94 |   (interactive (list (read-from-minibuffer "Kind of: ")))
 95 |   (ghc-cmd-kind string))
 96 | 
 97 | (defun ghc/type (prefix-arg)
 98 |   "Get the type of the given type expression."
 99 |   (interactive "P")
100 |   (let ((string (or (ghc-ident-at-point)
101 |                     (read-from-minibuffer "Type of: "))))
102 |     (ghc-cmd-type string prefix-arg)))
103 | 
104 | (defun ghc/type-at (prefix-arg)
105 |   "Get the type of the identifier at point, or at region."
106 |   (interactive "P")
107 |   (let ((pos (or (when (region-active-p)
108 |                    (cons (region-beginning)
109 |                          (region-end)))
110 |                  (ghc-ident-pos-at-point)
111 |                  (cons (point)
112 |                        (point)))))
113 |     (when pos
114 |       (save-excursion
115 |         (ghc-cmd-type-at
116 |          (file-relative-name (buffer-file-name) (ghc-session-dir (ghc-session)))
117 |          (buffer-substring-no-properties (car pos)
118 |                                          (cdr pos))
119 |          (progn (goto-char (car pos))
120 |                 (line-number-at-pos))
121 |          (current-column)
122 |          (progn (goto-char (cdr pos))
123 |                 (line-number-at-pos))
124 |          (current-column)
125 |          prefix-arg)))))
126 | 
127 | (defun ghc/uses (prefix-arg)
128 |   "Display the uses of the identifer at point."
129 |   (interactive "P")
130 |   (let ((pos (or (when (region-active-p)
131 |                    (cons (region-beginning)
132 |                          (region-end)))
133 |                  (ghc-ident-pos-at-point)
134 |                  (cons (point)
135 |                        (point)))))
136 |     (when pos
137 |       (save-excursion
138 |         (ghc-cmd-uses
139 |          (file-relative-name (buffer-file-name) (ghc-session-dir (ghc-session)))
140 |          (buffer-substring-no-properties (car pos)
141 |                                          (cdr pos))
142 |          (progn (goto-char (car pos))
143 |                 (line-number-at-pos))
144 |          (current-column)
145 |          (progn (goto-char (cdr pos))
146 |                 (line-number-at-pos))
147 |          (current-column)
148 |          prefix-arg)))))
149 | 
150 | (defun ghc/goto-def ()
151 |   "Go to the definition of the identifer at point."
152 |   (interactive)
153 |   (let ((pos (or (when (region-active-p)
154 |                    (cons (region-beginning)
155 |                          (region-end)))
156 |                  (ghc-ident-pos-at-point)
157 |                  (cons (point)
158 |                        (point)))))
159 |     (when pos
160 |       (save-excursion
161 |         (ghc-cmd-goto-loc
162 |          (file-relative-name (buffer-file-name) (ghc-session-dir (ghc-session)))
163 |          (buffer-substring-no-properties (car pos)
164 |                                          (cdr pos))
165 |          (progn (goto-char (car pos))
166 |                 (line-number-at-pos))
167 |          (current-column)
168 |          (progn (goto-char (cdr pos))
169 |                 (line-number-at-pos))
170 |          (current-column))))))
171 | 
172 | (defun ghc/msgs ()
173 |   "Create/show the messages buffer."
174 |   (interactive)
175 |   (let ((default-directory (ghc-session-dir (ghc-session))))
176 |     (switch-to-buffer-other-window (ghc-msgs-buffer (ghc-session-name (ghc-session))))))
177 | 
178 | (defun ghc/status ()
179 |   "Create/show the status buffer."
180 |   (interactive)
181 |   (let ((default-directory (ghc-session-dir (ghc-session))))
182 |     (switch-to-buffer-other-window (ghc-status-buffer (ghc-session-name (ghc-session))))))
183 | 
184 | (defun ghc/repl ()
185 |   "Create/show the REPL buffer."
186 |   (interactive)
187 |   (let ((default-directory (ghc-session-dir (ghc-session))))
188 |     (switch-to-buffer (ghc-repl-buffer (ghc-session-name (ghc-session))))))
189 | 
190 | (provide 'ghc)
191 | 


--------------------------------------------------------------------------------
/ghc-server.cabal:
--------------------------------------------------------------------------------
 1 | name:                ghc-server
 2 | version:             0.0
 3 | synopsis:            GHC service
 4 | description:         GHC service
 5 |                      .
 6 |                      Supported major GHC versions: 7.4, 7.6, 7.8
 7 | license:             BSD3
 8 | license-file:        LICENSE
 9 | author:              Chris Done
10 | maintainer:          chrisdone@gmail.com
11 | copyright:           2014 Chris Done
12 | category:            Development
13 | build-type:          Simple
14 | cabal-version:       >= 1.10
15 | 
16 | library
17 |   hs-source-dirs:    src/
18 |   ghc-options:       -O2 -Wall -threaded
19 |   exposed-modules:   GHC.Server
20 |                      GHC.Server.Controllers
21 |                      GHC.Server.Types
22 |                      GHC.Server.Logging
23 |   other-modules:     GHC.Compat
24 |                      GHC.Server.Cabal
25 |                      GHC.Server.Duplex
26 |                      GHC.Server.Model.Ghc
27 |                      GHC.Server.Model.Info
28 |                      GHC.Server.Model.Find
29 |                      GHC.Server.Controller.Eval
30 |                      GHC.Server.Controller.Info
31 |                      GHC.Server.Controller.Load
32 |                      GHC.Server.Controller.Context
33 |                      GHC.Server.Controller.Debug
34 |                      GHC.Server.Controller.REPL
35 |                      GHC.Server.Defaults
36 |                      GHC.Server.TH
37 |   default-language: Haskell2010
38 |   default-extensions: FlexibleInstances, TemplateHaskell
39 |   build-depends:     Cabal
40 |                    , atto-lisp
41 |                    , attoparsec
42 |                    , base >= 4 && <5
43 |                    , bytestring
44 |                    , containers
45 |                    , directory
46 |                    , ghc
47 |                    , ghc-paths
48 |                    , monad-logger
49 |                    , mtl
50 |                    , network
51 |                    , stm
52 |                    , syb
53 |                    , template-haskell
54 |                    , text
55 |                    , unordered-containers
56 |                    , directory
57 |   if impl(ghc<7.4)
58 |     build-depends: ghc >= 7.4
59 |   if impl(ghc>=7.4)
60 |     build-depends:
61 |       -- Hard versions
62 |       ghc ==7.4.* || == 7.6.* || == 7.8.*
63 | 
64 | executable ghc-server
65 |   hs-source-dirs:    src/main
66 |   if impl(ghc>=7.8)
67 |     ghc-options:       -O2 -Wall -threaded -dynamic
68 |   if impl(ghc<7.8)
69 |     ghc-options:       -O2 -Wall -threaded
70 |   main-is:           Main.hs
71 |   build-depends:     base >= 4 && < 5
72 |                    , ghc-server
73 |                    , monad-logger
74 |   default-language: Haskell2010
75 | 


--------------------------------------------------------------------------------
/scripts/test-ghcs:
--------------------------------------------------------------------------------
 1 | set -e
 2 | 
 3 | v="7.4.2"
 4 | echo "Testing against GHC $v ..."
 5 | oldpath=$PATH
 6 | PATH=/opt/ghc/$v/bin:$PATH
 7 | echo "Setting PATH ..."
 8 | /opt/cabal/1.18/bin/cabal clean > /dev/null
 9 | echo "Cabal installing with -O0 ..."
10 | ghc --version
11 | /opt/cabal/1.18/bin/cabal install --dependencies-only --force-reinstalls --ghc-options="-O0" -j4 > /dev/null
12 | /opt/cabal/1.18/bin/cabal install --ghc-options="-O0 -Werror -Wall"
13 | PATH=$oldpath
14 | 
15 | v="7.6.3"
16 | echo "Testing against GHC $v ..."
17 | oldpath=$PATH
18 | PATH=/opt/ghc/$v/bin:$PATH
19 | echo "Setting PATH ..."
20 | /opt/cabal/1.18/bin/cabal clean > /dev/null
21 | echo "Cabal installing with -O0 ..."
22 | ghc --version
23 | /opt/cabal/1.18/bin/cabal install --dependencies-only --force-reinstalls --ghc-options="-O0" -j4 > /dev/null
24 | /opt/cabal/1.18/bin/cabal install --ghc-options="-O0 -Werror -Wall"
25 | PATH=$oldpath
26 | 
27 | v="7.8.2"
28 | echo "Testing against GHC $v ..."
29 | oldpath=$PATH
30 | PATH=/opt/ghc/$v/bin:$PATH
31 | echo "Setting PATH ..."
32 | /opt/cabal/1.18/bin/cabal clean > /dev/null
33 | echo "Cabal installing with -O0 ..."
34 | ghc --version
35 | /opt/cabal/1.18/bin/cabal install --dependencies-only --force-reinstalls --ghc-options="-O0" -j4 > /dev/null
36 | /opt/cabal/1.18/bin/cabal install --ghc-options="-O0 -Werror -Wall"
37 | PATH=$oldpath
38 | 
39 | echo "Tested all GHCs."
40 | 


--------------------------------------------------------------------------------
/src/GHC/Compat.hs:
--------------------------------------------------------------------------------
  1 | {-# OPTIONS -fno-warn-orphans #-}
  2 | {-# LANGUAGE CPP #-}
  3 | {-# LANGUAGE ConstraintKinds #-}
  4 | 
  5 | -- | Compatibility layer for GHC. Supports GHC 7.4, 7.6, 7.8.
  6 | --
  7 | -- None of the ghc-server project should import from the GHC API
  8 | -- directly, it should import via this layer. It exports everything
  9 | -- from the GHC API that is needed. Ideally, only this module will use
 10 | -- CPP, too.
 11 | --
 12 | -- Some symbols are not exported, usurped by compatible
 13 | -- re-definitions. These compatibility wrappers are added on a
 14 | -- case-by-case basis. Otherwise, everything is re-exported.
 15 | --
 16 | -- Each function has a type signature. Under each type signature lies
 17 | -- an implementation dependent upon a specific major GHC version. When
 18 | -- a new GHC version is added to the test builds, a new #if section
 19 | -- will needed to be added for that specific version. If not, there
 20 | -- will be a build error. This helps to ensure specific versions are
 21 | -- dealt with.
 22 | 
 23 | module GHC.Compat
 24 |   (module GHC
 25 |   ,module GHC.Paths
 26 |   ,module Var
 27 |   ,module Outputable
 28 |   ,module Packages
 29 |   ,module Name
 30 |   ,module BasicTypes
 31 |   ,module DynFlags
 32 |   ,module GhcMonad
 33 |   ,module SrcLoc
 34 |   ,module FastString
 35 |   ,module MonadUtils
 36 |   ,module Exception
 37 |   ,module HscTypes
 38 |   ,module NameSet
 39 |   ,module TcHsSyn
 40 |   ,module TcRnTypes
 41 |   ,module Desugar
 42 |   ,LogAction
 43 |   ,GhcVersion(..)
 44 |   ,parseImportDecl
 45 |   ,io
 46 |   ,typeKind
 47 |   ,setContext
 48 |   ,defaultErrorHandler
 49 |   ,showSDocForUser
 50 |   ,setLogAction
 51 |   ,showSDoc
 52 |   ,getInfo
 53 |   ,addToContext
 54 |   ,showSeverity
 55 |   ,showppr
 56 |   ,exprTypeCore
 57 |   ,ghcVersion)
 58 |   where
 59 | 
 60 | import           BasicTypes hiding (Version)
 61 | import qualified Control.Monad.Trans as Trans
 62 | import qualified CoreSyn
 63 | import qualified CoreUtils
 64 | import           Data.List (nub)
 65 | import           Desugar
 66 | import qualified DynFlags
 67 | import           ErrUtils
 68 | import           Exception
 69 | import           FastString
 70 | import qualified GHC
 71 | import           GHC.Paths
 72 | import           GhcMonad
 73 | import           HscTypes
 74 | import qualified MonadUtils (MonadIO)
 75 | import           MonadUtils hiding (MonadIO)
 76 | import           Name
 77 | import           NameSet
 78 | import qualified Outputable hiding ((<>))
 79 | import           Packages
 80 | import           SrcLoc
 81 | import           TcHsSyn
 82 | import           Var (Var,idDetails)
 83 | 
 84 | import           TcRnTypes
 85 | #if __GLASGOW_HASKELL__ > 704
 86 | import           System.IO
 87 | #endif
 88 | 
 89 | import           DynFlags
 90 |   hiding (LogAction)
 91 | 
 92 | import           Outputable
 93 |   hiding (showSDocForUser
 94 |          ,showSDoc
 95 |          ,(<>))
 96 | 
 97 | import           GHC
 98 |   hiding (parseImportDecl
 99 |          ,typeKind
100 |          ,setContext
101 |          ,defaultErrorHandler
102 |          ,getInfo)
103 | 
104 | -- | Wraps 'GHC.typeKind'.
105 | typeKind :: GhcMonad m => String -> m Kind
106 | #if __GLASGOW_HASKELL__ == 704
107 | typeKind expr = fmap snd (GHC.typeKind True expr)
108 | #endif
109 | #if __GLASGOW_HASKELL__ == 706
110 | typeKind expr = fmap snd (GHC.typeKind True expr)
111 | #endif
112 | #if __GLASGOW_HASKELL__ == 708
113 | typeKind expr = fmap snd (GHC.typeKind True expr)
114 | #endif
115 | 
116 | -- | Wraps 'GHC.parseImportDecl'.
117 | parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
118 | #if __GLASGOW_HASKELL__ == 704
119 | parseImportDecl = GHC.parseImportDecl
120 | #endif
121 | #if __GLASGOW_HASKELL__ == 706
122 | parseImportDecl = GHC.parseImportDecl
123 | #endif
124 | #if __GLASGOW_HASKELL__ == 708
125 | parseImportDecl = GHC.parseImportDecl
126 | #endif
127 | 
128 | -- | Wraps 'GHC.setContext'.
129 | setContext :: GhcMonad m => [ImportDecl RdrName] -> m ()
130 | #if __GLASGOW_HASKELL__ == 704
131 | setContext = GHC.setContext . map IIDecl
132 | #endif
133 | #if __GLASGOW_HASKELL__ == 706
134 | setContext = GHC.setContext . map IIDecl
135 | #endif
136 | #if __GLASGOW_HASKELL__ == 708
137 | setContext = GHC.setContext . map IIDecl
138 | #endif
139 | 
140 | -- | Add an import declaration to the context with `setContext`.
141 | addToContext :: GhcMonad m => ImportDecl RdrName -> m ()
142 | #if __GLASGOW_HASKELL__ == 704
143 | addToContext i =
144 |   do ctx <- getContext
145 |      GHC.setContext (nub (IIDecl i : ctx))
146 | #endif
147 | #if __GLASGOW_HASKELL__ == 706
148 | addToContext i =
149 |   do ctx <- getContext
150 |      GHC.setContext (nub (IIDecl i : ctx))
151 | #endif
152 | #if __GLASGOW_HASKELL__ == 708
153 | addToContext i =
154 |   do ctx <- getContext
155 |      GHC.setContext (nub (IIDecl i : ctx))
156 | #endif
157 | 
158 | -- | Wraps 'GHC.defaultErrorHandler'.
159 | defaultErrorHandler :: (MonadIO m,ExceptionMonad m) => m a -> m a
160 | #if __GLASGOW_HASKELL__ == 704
161 | defaultErrorHandler = GHC.defaultErrorHandler defaultLogAction
162 | #endif
163 | #if __GLASGOW_HASKELL__ == 706
164 | defaultErrorHandler = GHC.defaultErrorHandler putStrLn (FlushOut (hFlush stdout))
165 | #endif
166 | #if __GLASGOW_HASKELL__ == 708
167 | defaultErrorHandler = GHC.defaultErrorHandler putStrLn (FlushOut (hFlush stdout))
168 | #endif
169 | 
170 | -- | Wraps 'Outputable.showSDocForUser'.
171 | showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
172 | #if __GLASGOW_HASKELL__ == 704
173 | showSDocForUser _ = Outputable.showSDocForUser
174 | #endif
175 | #if __GLASGOW_HASKELL__ == 706
176 | showSDocForUser = Outputable.showSDocForUser
177 | #endif
178 | #if __GLASGOW_HASKELL__ == 708
179 | showSDocForUser = Outputable.showSDocForUser
180 | #endif
181 | 
182 | #if __GLASGOW_HASKELL__ == 704
183 | type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> Message -> IO ()
184 | #endif
185 | #if __GLASGOW_HASKELL__ == 706
186 | type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
187 | #endif
188 | #if __GLASGOW_HASKELL__ == 708
189 | type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
190 | #endif
191 | 
192 | -- | Sets the log action for the session.
193 | setLogAction :: GhcMonad m => LogAction -> m ()
194 | #if __GLASGOW_HASKELL__ == 704
195 | setLogAction logger =
196 |   do dflags <- getSessionDynFlags
197 |      _ <- setSessionDynFlags dflags { log_action = logger dflags }
198 |      return ()
199 | #endif
200 | #if __GLASGOW_HASKELL__ == 706
201 | setLogAction logger =
202 |   do dflags <- getSessionDynFlags
203 |      _ <- setSessionDynFlags dflags { log_action = logger }
204 |      return ()
205 | #endif
206 | #if __GLASGOW_HASKELL__ == 708
207 | setLogAction logger =
208 |   do dflags <- getSessionDynFlags
209 |      _ <- setSessionDynFlags dflags { log_action = logger }
210 |      return ()
211 | #endif
212 | 
213 | -- | Pretty print something to string.
214 | showppr :: Outputable a => DynFlags -> a -> String
215 | showppr dflags = showSDocForUser dflags neverQualify . ppr
216 | 
217 | -- | Wraps 'Outputable.showSDoc'.
218 | showSDoc :: DynFlags -> SDoc -> String
219 | #if __GLASGOW_HASKELL__ == 704
220 | showSDoc _ = Outputable.showSDoc
221 | #endif
222 | #if __GLASGOW_HASKELL__ == 706
223 | showSDoc = Outputable.showSDoc
224 | #endif
225 | #if __GLASGOW_HASKELL__ == 708
226 | showSDoc = Outputable.showSDoc
227 | #endif
228 | 
229 | -- | An instance of a class.
230 | #if __GLASGOW_HASKELL__ == 704
231 | type SomeInstance = Instance
232 | #endif
233 | #if __GLASGOW_HASKELL__ == 706
234 | type SomeInstance = ClsInst
235 | #endif
236 | #if __GLASGOW_HASKELL__ == 708
237 | type SomeInstance = ClsInst
238 | #endif
239 | 
240 | -- | Wraps 'GHC.getInfo'.
241 | getInfo :: GhcMonad m => Name -> m (Maybe (TyThing, Fixity, [SomeInstance]))
242 | #if __GLASGOW_HASKELL__ == 702
243 | getInfo = GHC.getInfo
244 | #endif
245 | #if __GLASGOW_HASKELL__ == 704
246 | getInfo = GHC.getInfo
247 | #endif
248 | #if __GLASGOW_HASKELL__ == 706
249 | getInfo = GHC.getInfo
250 | #endif
251 | #if __GLASGOW_HASKELL__ == 708
252 | getInfo = fmap (fmap (\(a,b,c,_) -> (a,b,c))) . GHC.getInfo False
253 | #endif
254 | 
255 | -- Missing instances
256 | 
257 | #if __GLASGOW_HASKELL__ == 704
258 | instance Trans.MonadIO Ghc where liftIO = GhcMonad.liftIO
259 | #endif
260 | #if __GLASGOW_HASKELL__ == 706
261 | instance Trans.MonadIO Ghc where liftIO = GhcMonad.liftIO
262 | #endif
263 | 
264 | -- | Show the severity to a string: output, info, etc.
265 | showSeverity :: Severity -> String
266 | showSeverity t =
267 |   case t of
268 |     SevOutput -> "output"
269 |     SevInfo -> "info"
270 |     SevError -> "error"
271 |     SevWarning -> "warning"
272 |     SevFatal -> "fatal"
273 | #if __GLASGOW_HASKELL__ > 704
274 |     SevDump -> "dump"
275 | #endif
276 | #if __GLASGOW_HASKELL__ > 706
277 |     SevInteractive -> "interactive"
278 | #endif
279 | 
280 | -- | MonadIO abstraction.
281 | type MonadIO m = (Trans.MonadIO m,MonadUtils.MonadIO m)
282 | 
283 | instance Eq InteractiveImport where
284 |   IIModule i == IIModule j = i == j
285 |   IIDecl (ImportDecl name pkg src safe qal impl ias hid) ==
286 |     IIDecl (ImportDecl name1 pkg1 src1 safe1 qal1 impl1 ias1 hid1) =
287 |     (name1,pkg1,src1,safe1,qal1,impl1,ias1,hid1)  ==
288 |     (name,pkg,src,safe,qal,impl,ias,hid)
289 |   _ == _ = False
290 | 
291 | -- | Non-name-conflicting 'CoreUtils.exprType'.
292 | exprTypeCore :: CoreSyn.CoreExpr -> Type
293 | exprTypeCore = CoreUtils.exprType
294 | 
295 | -- | Used sometimes to dynamically detect existence for features that
296 | -- simply don't exist in older versions.
297 | data GhcVersion
298 |   = Ghc74
299 |   | Ghc76
300 |   | Ghc78
301 |   deriving (Eq,Enum,Ord)
302 | 
303 | ghcVersion :: GhcVersion
304 | #if __GLASGOW_HASKELL__ == 708
305 | ghcVersion = Ghc78
306 | #endif
307 | #if __GLASGOW_HASKELL__ == 706
308 | ghcVersion = Ghc76
309 | #endif
310 | #if __GLASGOW_HASKELL__ == 704
311 | ghcVersion = Ghc74
312 | #endif
313 | 
314 | -- | Non-conflicting combinator.
315 | io :: Trans.MonadIO m => IO a -> m a
316 | io = Trans.liftIO
317 | 


--------------------------------------------------------------------------------
/src/GHC/Server.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | {-# LANGUAGE GADTs #-}
  3 | {-# LANGUAGE ScopedTypeVariables #-}
  4 | {-# LANGUAGE TemplateHaskell #-}
  5 | 
  6 | -- | Server interface to GHC.
  7 | 
  8 | module GHC.Server
  9 |   (startServer)
 10 |   where
 11 | 
 12 | import           GHC.Compat
 13 | import           GHC.Server.Controllers
 14 | import           GHC.Server.Model.Ghc
 15 | import           GHC.Server.Logging
 16 | import           GHC.Server.TH
 17 | import           GHC.Server.Types
 18 | 
 19 | import           Control.Concurrent
 20 | import qualified Control.Exception as E
 21 | import           Control.Concurrent.STM
 22 | import           Control.Monad.Logger
 23 | import           Control.Monad.Reader
 24 | import           Data.AttoLisp (FromLisp(..),Lisp,lisp)
 25 | import qualified Data.AttoLisp as L
 26 | import qualified Data.Attoparsec as P
 27 | import           Data.ByteString (ByteString)
 28 | import qualified Data.ByteString as SB
 29 | import           Data.HashMap.Strict (HashMap)
 30 | import qualified Data.HashMap.Strict as M
 31 | import           Data.Monoid
 32 | import qualified Data.Text as T
 33 | import           Network
 34 | import           System.IO
 35 | 
 36 | --------------------------------------------------------------------------------
 37 | -- Serving
 38 | 
 39 | -- | Start the server.
 40 | startServer :: Int -> LoggingT IO ()
 41 | startServer port =
 42 |   do socket <- io (listenOn (PortNumber (fromIntegral port)))
 43 |      ghcChan <- io startGhc
 44 |      modInfos <- io (atomically (newTVar mempty))
 45 |      let state = State modInfos
 46 |      $(logInfo)
 47 |        ("Listening on port " <>
 48 |         T.pack (show port) <>
 49 |         " ...")
 50 |      forever (do (h,host,_port) <- io (accept socket)
 51 |                  io (startClient state ghcChan host h))
 52 | 
 53 | -- | Run a command handling client.
 54 | startClient :: State -> Chan (Ghc ()) -> String -> Handle -> IO ()
 55 | startClient state ghcChan host h =
 56 |   void (forkIO (runLogging go))
 57 |   where go =
 58 |           do $(logInfo) ("New connection from " <> T.pack host)
 59 |              activeCommands <- io (atomically (newTVar mempty))
 60 |              io (hSetBuffering h LineBuffering)
 61 |              fix (\loop ->
 62 |                     do mline <- (io (E.catch (fmap Just (SB.hGetLine h))
 63 |                                              (\(_ :: IOException) ->
 64 |                                                 return Nothing)))
 65 |                        case mline of
 66 |                          Just line ->
 67 |                            do handleLispLine state ghcChan h activeCommands line
 68 |                               loop
 69 |                          _ -> return ())
 70 |              $(logInfo) ("Connection closed to " <> T.pack host)
 71 | 
 72 | --------------------------------------------------------------------------------
 73 | -- GHC slave
 74 | 
 75 | -- | Start the GHC slave.
 76 | startGhc :: IO (Chan (Ghc ()))
 77 | startGhc =
 78 |   do chan <- newChan
 79 |      void (forkIO (runGhc (Just libdir)
 80 |                           (do runLogging initializeGhc
 81 |                               forever (protect (join (io (readChan chan)))))))
 82 |      return chan
 83 |   where protect m =
 84 |           gcatch m
 85 |                  (\(SomeException e) ->
 86 |                     runLogging
 87 |                       ($(logInfo)
 88 |                          ("GHC exception: " <>
 89 |                           T.pack (show e))))
 90 | 
 91 | --------------------------------------------------------------------------------
 92 | -- Command handling
 93 | 
 94 | -- | Handle an incoming Lisp-encoded line.
 95 | handleLispLine :: State
 96 |                -> Chan (Ghc ())
 97 |                -> Handle
 98 |                -> TVar (HashMap Integer SomeChan)
 99 |                -> ByteString
100 |                -> LoggingT IO ()
101 | handleLispLine state ghcChan h activeCommands line =
102 |   case fromLispString line of
103 |     Left e ->
104 |       $(logError) ("Erroneous input Lisp: " <> T.pack e)
105 |     Right (Incoming ix input :: Incoming Lisp) ->
106 |       case input of
107 |         Request (SomeCommand c) ->
108 |           do $(logDebug)
109 |                ("Some command: " <>
110 |                 T.pack (show c))
111 |              inputChan <- io (newInputChan c)
112 |              io (atomically
113 |                    (modifyTVar activeCommands
114 |                                (M.insert ix (SomeChan inputChan))))
115 |              void (io (forkIO (do runLogging ($(dispatch ''Command) ghcChan ix h inputChan c state)
116 |                                   atomically
117 |                                     (modifyTVar activeCommands
118 |                                                 (M.delete ix)))))
119 |         FeedIn i ->
120 |           do $(logDebug)
121 |                ("Command " <>
122 |                 T.pack (show ix) <>
123 |                 " feed: " <>
124 |                 T.pack (show i))
125 |              cmds <- io (atomically (readTVar activeCommands))
126 |              case M.lookup ix cmds of
127 |                Nothing ->
128 |                  $(logError)
129 |                    ("No active command for " <>
130 |                     T.pack (show ix))
131 |                Just (SomeChan chan) ->
132 |                  do $(logError)
133 |                       ("Feeding " <>
134 |                        T.pack (show ix))
135 |                     case L.parseEither parseLisp i of
136 |                       Right i' ->
137 |                         io (writeChan chan i')
138 |                       Left err ->
139 |                         $(logError)
140 |                           ("Couldn't parse input feed into proper type: " <>
141 |                            T.pack (show err))
142 |   where newInputChan :: Command (Duplex i o r) -> IO (Chan i)
143 |         newInputChan _ = newChan
144 | 
145 | --------------------------------------------------------------------------------
146 | -- Lisp parsing
147 | 
148 | -- | Parse a single s-expr followed by optional whitespace and end of
149 | --   file.
150 | parseLispOnly :: ByteString -> Either String Lisp
151 | parseLispOnly b =
152 |   case P.parseOnly lisp b of
153 |     Left err ->
154 |       Left ("Bad s-expression: " <> err)
155 |     Right ok -> Right ok
156 | 
157 | -- | Parse a single s-expr.
158 | fromLispString :: FromLisp a
159 |                => SB.ByteString -> Either String a
160 | fromLispString = parseLispOnly >=> L.parseEither parseLisp
161 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Cabal.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | 
 3 | -- | Cabal integration.
 4 | 
 5 | module GHC.Server.Cabal where
 6 | 
 7 | import Data.Maybe
 8 | import Data.Monoid
 9 | import Data.Version
10 | import Distribution.Package
11 | import Distribution.PackageDescription
12 | import Distribution.Simple.Configure
13 | import Distribution.Simple.LocalBuildInfo
14 | import Language.Haskell.Extension
15 | 
16 | -- | Get the name of the package being developed.
17 | getPackageName :: IO String
18 | getPackageName =
19 |   do lconfig <- getPersistBuildConfig "dist"
20 |      return (case pkgName (package (localPkgDescr lconfig))  of
21 |                PackageName str -> str)
22 | 
23 | -- | Get package databases and resolved package dependencies.
24 | getDependencyInfo :: IO ([FilePath],[String],[PackageId])
25 | getDependencyInfo =
26 |   do lconfig <- getPersistBuildConfig "dist"
27 |      let libdeps = getDeps lconfig
28 |          lpkgdsc = localPkgDescr lconfig
29 |          libinfo = fmap (libBuildInfo) (library lpkgdsc)
30 |          extensions = maybe [] (map showExt . defaultExtensions) libinfo
31 |          libsourceDirs = fmap (hsSourceDirs) libinfo
32 |      return (fromMaybe [] libsourceDirs,
33 |              extensions,
34 |              map snd (fromMaybe [] libdeps))
35 | 
36 | -- | Convert an extension to a paramter.
37 | showExt :: Extension -> String
38 | showExt g =
39 |   case g of
40 |     EnableExtension e -> "-X" <> show e
41 |     DisableExtension e -> "-XNo" <> show e
42 |     UnknownExtension e -> "-X" <> show e
43 | 
44 | -- | Render package id to foo-1.2.3
45 | renderPackageId :: PackageId -> String
46 | renderPackageId pid = unPkgName (pkgName pid) <> "-" <> showVersion (pkgVersion pid)
47 |   where unPkgName (PackageName n) = n
48 | 
49 | -- | Get dependencies. FIXME: Deal with targets.
50 | getDeps :: LocalBuildInfo -> Maybe [(InstalledPackageId, PackageId)]
51 | #if MIN_VERSION_Cabal(1,18,0)
52 | getDeps = fmap (componentPackageDeps . (\(_,x,_) -> x)) . listToMaybe . componentsConfigs
53 | #else
54 | getDeps = fmap componentPackageDeps . libraryConfig
55 | #endif
56 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Controller/Context.hs:
--------------------------------------------------------------------------------
 1 | -- | Context-configuring controller. Directory, packages, options, etc.
 2 | 
 3 | module GHC.Server.Controller.Context (set,packageConf,setCurrentDir) where
 4 | 
 5 | import           GHC.Compat
 6 | import           GHC.Server.Duplex
 7 | import           GHC.Server.Types
 8 | 
 9 | import           Control.Monad
10 | import           Data.Monoid
11 | import           Data.Text (Text)
12 | import qualified Data.Text as T
13 | import           System.Directory
14 | 
15 | -- | Set the options.
16 | set :: Text -> Unit
17 | set flag =
18 |   withGhc (setFlag (T.unpack flag))
19 | 
20 | -- | Set the package conf.
21 | packageConf :: FilePath -> Unit
22 | packageConf pkgconf =
23 |   withGhc (do setFlag ("-package-conf=" <> pkgconf)
24 |               df <- getSessionDynFlags
25 |               (dflags,_pkgs) <- io (initPackages df)
26 |               _ <- setSessionDynFlags dflags
27 |               return ())
28 | 
29 | -- | Set the current directory.
30 | setCurrentDir :: FilePath -> Unit
31 | setCurrentDir dir =
32 |   withGhc (do io (setCurrentDirectory dir)
33 |               workingDirectoryChanged
34 |               setTargets []
35 |               _ <- load LoadAllTargets
36 |               return ())
37 | 
38 | -- | Apply a flag.
39 | setFlag :: GhcMonad m => String -> m ()
40 | setFlag flag =
41 |   do df <- getSessionDynFlags
42 |      (dflags,_,_) <- parseDynamicFlags
43 |                        df
44 |                        (map (mkGeneralLocated "flag")
45 |                             [flag])
46 |      void (setSessionDynFlags dflags)
47 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Controller/Debug.hs:
--------------------------------------------------------------------------------
 1 | -- | Debugging controller.
 2 | 
 3 | module GHC.Server.Controller.Debug where
 4 | 
 5 | import GHC.Server.Types
 6 | 
 7 | -- | Ping/pong.
 8 | ping :: Integer -> Returns Integer
 9 | ping = return
10 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Controller/Eval.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE ScopedTypeVariables #-}
 2 | 
 3 | -- | Run eval.
 4 | 
 5 | module GHC.Server.Controller.Eval
 6 |   (eval)
 7 |   where
 8 | 
 9 | import           GHC.Compat
10 | import           GHC.Server.Duplex
11 | import           GHC.Server.Types
12 | 
13 | import           Data.Text (Text)
14 | import qualified Data.Text as T
15 | 
16 | -- | Eval something for the REPL.
17 | eval :: Text -> Duplex Text Text EvalResult
18 | eval e = withGhc (tryImportOrDecls e)
19 | 
20 | -- | Try to run the expression as an import line:
21 | --
22 | -- import F
23 | --
24 | -- Or as a declaration:
25 | --
26 | -- data X = X
27 | --
28 | -- Otherwise try evaluating it as an expression.
29 | tryImportOrDecls :: (GhcMonad m)
30 |                  => Text -> m EvalResult
31 | tryImportOrDecls e =
32 |   do dflags <- getSessionDynFlags
33 |      result <- gtry (parseImportDecl (T.unpack e))
34 |      case result of
35 |        Right imp ->
36 |          do addToContext imp
37 |             ctx <- getContext
38 |             return (NewContext (map (showppr dflags) ctx))
39 |        Left (ex :: SomeException) -> throw ex
40 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Controller/Info.hs:
--------------------------------------------------------------------------------
 1 | -- | Information about modules, identifiers, etc.
 2 | 
 3 | module GHC.Server.Controller.Info where
 4 | 
 5 | import GHC.Compat
 6 | import GHC.Server.Duplex
 7 | import GHC.Server.Model.Find
 8 | import GHC.Server.Types
 9 | 
10 | import Data.Text (Text)
11 | 
12 | -- | Location of identifier at point.
13 | locationAt :: FilePath -> Text -> Int -> Int -> Int -> Int -> Returns SrcSpan
14 | locationAt fp ident sl sc el ec =
15 |   do infos <- getModuleInfos
16 |      result <- withGhc (findLoc infos fp ident sl sc el ec)
17 |      case result of
18 |        Left err -> error err
19 |        Right sp -> return sp
20 | 
21 | -- | Type of identifier at point.
22 | typeAt :: FilePath -> Text -> Int -> Int -> Int -> Int -> Returns Text
23 | typeAt fp ident sl sc el ec =
24 |   do infos <- getModuleInfos
25 |      result <- withGhc (findType infos fp ident sl sc el ec)
26 |      case result of
27 |        Left err -> error err
28 |        Right sp -> return sp
29 | 
30 | -- | Find uses.
31 | usesAt :: FilePath -> Text -> Int -> Int -> Int -> Int -> Returns Text
32 | usesAt fp ident sl sc el ec =
33 |   do infos <- getModuleInfos
34 |      result <- withGhc (findVar infos fp ident sl sc el ec)
35 |      case result of
36 |        Left err -> error err
37 |        Right _ -> error "uses: Not implemented yet."
38 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Controller/Load.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleContexts #-}
 2 | {-# LANGUAGE TemplateHaskell #-}
 3 | {-# LANGUAGE OverloadedStrings #-}
 4 | {-# LANGUAGE ConstraintKinds #-}
 5 | 
 6 | -- | Loading targets.
 7 | 
 8 | module GHC.Server.Controller.Load where
 9 | 
10 | import           GHC.Compat
11 | import           GHC.Server.Defaults
12 | import           GHC.Server.Duplex
13 | import           GHC.Server.Logging
14 | import           GHC.Server.Model.Ghc
15 | import           GHC.Server.Model.Info
16 | import           GHC.Server.Types
17 | 
18 | import           Control.Arrow
19 | import           Control.Concurrent.STM
20 | import           Control.Monad
21 | import           Control.Monad.Logger
22 | import           Control.Monad.Reader
23 | import           Data.Map (Map)
24 | import qualified Data.Map as M
25 | import           Data.Monoid
26 | import           Data.Text (Text)
27 | import qualified Data.Text as T
28 | 
29 | -- | Load a module.
30 | loadTarget :: Text -> Producer Msg (SuccessFlag,Integer)
31 | loadTarget filepath =
32 |   withGhc (do df <- getSessionDynFlags
33 |               warnings <- liftIO (atomically (newTVar (0,0)))
34 |               (result,loaded) <- withMessages (recordMessage warnings)
35 |                                               doLoad
36 |               case result of
37 |                 Succeeded ->
38 |                   do var <- getModuleInfosVar
39 |                      void (forkGhc (runLogging (collectInfo var loaded)))
40 |                 _ -> return ()
41 |               count <- liftIO (atomically (readTVar warnings))
42 |               return (result,snd count))
43 |   where recordMessage warnings df sev sp doc =
44 |           do send (Msg sev sp (T.pack (showSDoc df doc)))
45 |              case sev of
46 |                SevWarning ->
47 |                  liftIO (atomically
48 |                            (modifyTVar' warnings
49 |                                         (second (+ 1))))
50 |                SevError ->
51 |                  liftIO (atomically
52 |                            (modifyTVar' warnings
53 |                                         (first (+ 1))))
54 |                _ -> return ()
55 |         doLoad =
56 |           do target <- guessTarget (T.unpack filepath)
57 |                                    Nothing
58 |              setTargets [target]
59 |              result <- load LoadAllTargets
60 |              loaded <- getModuleGraph >>= filterM isLoaded . map ms_mod_name
61 |              mapM parseImportDecl (necessaryImports <> loadedImports loaded) >>=
62 |                setContext
63 |              return (result,loaded)
64 | 
65 | -- | Collect type info data for the loaded modules.
66 | collectInfo :: (GhcMonad m,MonadLogger m)
67 |             => TVar (Map ModuleName ModInfo) -> [ModuleName] -> m ()
68 | collectInfo var loaded =
69 |   do ($(logDebug)
70 |         ("Collecting module data for " <>
71 |          T.pack (show (length loaded)) <>
72 |          " modules ..."))
73 |      forM_ loaded
74 |            (\name ->
75 |               do info <- getModInfo name
76 |                  io (atomically
77 |                        (modifyTVar var
78 |                                    (M.insert name info))))
79 |      $(logDebug) ("Done collecting module data.")
80 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Controller/REPL.hs:
--------------------------------------------------------------------------------
 1 | -- | REPL-context controller.
 2 | 
 3 | module GHC.Server.Controller.REPL
 4 |   (typeOf,kindOf,infoOf)
 5 |   where
 6 | 
 7 | import           GHC.Compat
 8 | import           GHC.Server.Duplex
 9 | import           GHC.Server.Types
10 | 
11 | import           Data.Maybe
12 | import           Data.Text (Text)
13 | import qualified Data.Text as T
14 | 
15 | -- | Type of identifier.
16 | typeOf :: Text -> Returns Text
17 | typeOf expr =
18 |   withGhc (do typ <- exprType (T.unpack expr)
19 |               df <- getSessionDynFlags
20 |               return (formatType df typ))
21 | 
22 | -- | Kind of the identifier.
23 | kindOf :: Text -> Returns Text
24 | kindOf expr =
25 |   withGhc (do typ <- typeKind (T.unpack expr)
26 |               df <- getSessionDynFlags
27 |               return (formatType df typ))
28 | 
29 | -- | Info of the identifier.
30 | infoOf :: Text -> Returns [Text]
31 | infoOf ident =
32 |   withGhc (do names <- parseName (T.unpack ident)
33 |               df <- getSessionDynFlags
34 |               infos <- fmap (concatMap (\(t,f,cs) ->
35 |                                           showppr df t :
36 |                                           showppr df f :
37 |                                           map (showppr df) cs) .
38 |                              catMaybes)
39 |                             (mapM getInfo names)
40 |               let spans' =
41 |                     map ((\x ->
42 |                             case x of
43 |                               (RealSrcSpan i) -> printSpan i
44 |                               _ -> "???") .
45 |                          getSrcSpan)
46 |                         names
47 |                     where printSpan s =
48 |                             "Defined in " ++
49 |                             unpackFS (srcSpanFile s)
50 |               return (map T.pack
51 |                           (zipWith (\x y ->
52 |                                       unlines [x,y])
53 |                                    spans'
54 |                                    infos)))
55 | 
56 | -- | Pretty print a type.
57 | formatType :: DynFlags -> Type -> Text
58 | formatType dflags = T.pack . unwords . lines . showppr dflags . snd .
59 |                     splitForAllTys
60 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Controllers.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | -- | All server commands. Some commands are re-exported from below
 4 | -- this hierarchy.
 5 | 
 6 | module GHC.Server.Controllers
 7 |   (loadTarget
 8 |   ,ping
 9 |   ,eval
10 |   ,typeOf
11 |   ,kindOf
12 |   ,locationAt
13 |   ,typeAt
14 |   ,usesAt
15 |   ,infoOf
16 |   ,set
17 |   ,packageConf
18 |   ,setCurrentDir)
19 |   where
20 | 
21 | import GHC.Server.Controller.Context
22 | import GHC.Server.Controller.Debug
23 | import GHC.Server.Controller.Eval
24 | import GHC.Server.Controller.Info
25 | import GHC.Server.Controller.Load
26 | import GHC.Server.Controller.REPL
27 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Defaults.hs:
--------------------------------------------------------------------------------
1 | -- | Defaults used throughout the project.
2 | 
3 | module GHC.Server.Defaults where
4 | 
5 | -- | Basic standard imports.
6 | necessaryImports :: [String]
7 | necessaryImports = ["import Prelude"]
8 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Duplex.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleContexts #-}
 2 | {-# LANGUAGE RankNTypes #-}
 3 | {-# LANGUAGE ConstraintKinds #-}
 4 | 
 5 | -- | The Duplex monad, used for full duplex communication between
 6 | -- server and client commands.
 7 | 
 8 | module GHC.Server.Duplex where
 9 | 
10 | import GHC.Compat
11 | import GHC.Server.Types
12 | 
13 | import Control.Concurrent
14 | import Control.Concurrent.STM
15 | import Control.Monad.Reader
16 | import Data.Map (Map)
17 | 
18 | --------------------------------------------------------------------------------
19 | -- Duplexing monad
20 | 
21 | -- | Receive an input.
22 | recv :: (MonadDuplex i o m)
23 |      => m i
24 | recv =
25 |   do inp <-  (asks duplexIn)
26 |      io (readChan inp)
27 | 
28 | -- | Send an output.
29 | send :: (MonadDuplex i o m)
30 |      => o -> m ()
31 | send o =
32 |   do out <-  (asks duplexOut)
33 |      io (writeChan out o)
34 | 
35 | -- | Transform over Ghc, running the transformed GHC in isolation.
36 | withGhc :: (Inputish i,Outputish o)
37 |         => DuplexT Ghc i o r -> Duplex i o r
38 | withGhc m =
39 |   do st <- ask
40 |      ghcChan <- asks duplexRunGhc
41 |      io (do result <- newEmptyMVar
42 |             writeChan ghcChan
43 |                       (do v <- runReaderT (runDuplexT m)
44 |                                           st
45 |                           io (putMVar result v))
46 |             takeMVar result)
47 | 
48 | 
49 | -- | Run a Ghc action in another thread. Transform over Ghc, running
50 | -- the transformed GHC in isolation.
51 | forkGhc :: (MonadDuplex i o m)
52 |         => Ghc () -> m ThreadId
53 | forkGhc m =
54 |   do st <- ask
55 |      ghcChan <- asks duplexRunGhc
56 |      io (forkIO (do result <- newEmptyMVar
57 |                     writeChan ghcChan
58 |                               (do v <- m
59 |                                   io (putMVar result v))
60 |                     takeMVar result))
61 | 
62 | -- | Run a Ghc action in another thread. Transform over Ghc, running
63 | -- the transformed GHC in isolation.
64 | forkWithGhc :: (MonadDuplex i o m)
65 |             => DuplexT Ghc i o () -> m ThreadId
66 | forkWithGhc m =
67 |   do st <- ask
68 |      ghcChan <- asks duplexRunGhc
69 |      io (forkIO (do result <- newEmptyMVar
70 |                     writeChan ghcChan
71 |                               (do v <- runReaderT (runDuplexT m)
72 |                                                   st
73 |                                   io (putMVar result v))
74 |                     takeMVar result))
75 | 
76 | -- | Get the global module infos value.
77 | getModuleInfos :: (MonadDuplex i o m) => m (Map ModuleName ModInfo)
78 | getModuleInfos =
79 |   do var <- getModuleInfosVar
80 |      infos <- liftIO (atomically (readTVar var))
81 |      return infos
82 | 
83 | -- | Get the global module infos value.
84 | getModuleInfosVar :: (MonadDuplex i o m) => m (TVar (Map ModuleName ModInfo))
85 | getModuleInfosVar =
86 |   asks (stateModuleInfos . duplexState)
87 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Eval.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE ScopedTypeVariables #-}
 2 | 
 3 | -- | Run eval.
 4 | 
 5 | module GHC.Server.Eval where
 6 | 
 7 | import           GHC.Compat
 8 | import           GHC.Server.Types
 9 | 
10 | import           Data.Text (Text)
11 | import qualified Data.Text as T
12 | 
13 | -- | Try to run the expression as an import line:
14 | --
15 | -- import F
16 | --
17 | -- Or as a declaration:
18 | --
19 | -- data X = X
20 | --
21 | -- Otherwise try evaluating it as an expression.
22 | tryImportOrDecls :: (GhcMonad m)
23 |                  => Text -> m EvalResult
24 | tryImportOrDecls e =
25 |   do dflags <- getSessionDynFlags
26 |      result <- gtry (parseImportDecl (T.unpack e))
27 |      case result of
28 |        Right imp ->
29 |          do addToContext imp
30 |             ctx <- getContext
31 |             return (NewContext (map (showppr dflags) ctx))
32 |        Left (ex :: SomeException) -> throw ex
33 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Info.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE RankNTypes #-}
  3 | 
  4 | -- | Get information on modules, identifiers, etc.
  5 | 
  6 | module GHC.Server.Info (getModInfo) where
  7 | 
  8 | import           GHC.Compat
  9 | import           GHC.Server.Types
 10 | 
 11 | import qualified Data.ByteString.Char8 as S8
 12 | import           Data.Generics (GenericQ, mkQ, extQ, gmapQ)
 13 | import           Data.List
 14 | import           Data.Maybe
 15 | import           Data.Monoid
 16 | import           Data.Typeable
 17 | 
 18 | -- | Get info about the module: summary, types, etc.
 19 | getModInfo :: GhcMonad m => ModuleName -> m ModInfo
 20 | getModInfo name =
 21 |   do m <- getModSummary name
 22 |      p <- parseModule m
 23 |      typechecked <- typecheckModule p
 24 |      allTypes <- processAllTypeCheckedModule typechecked
 25 |      let i = tm_checked_module_info typechecked
 26 |      return (ModInfo m allTypes i)
 27 | 
 28 | -- | Get ALL source spans in the module.
 29 | processAllTypeCheckedModule :: GhcMonad m
 30 |                             => TypecheckedModule -> m [SpanInfo]
 31 | processAllTypeCheckedModule tcm =
 32 |   do let tcs = tm_typechecked_source tcm
 33 |          bs =
 34 |            listifyAllSpans tcs :: [LHsBind Id]
 35 |          es =
 36 |            listifyAllSpans tcs :: [LHsExpr Id]
 37 |          ps =
 38 |            listifyAllSpans tcs :: [LPat Id]
 39 |      bts <- mapM (getTypeLHsBind tcm) bs
 40 |      ets <- mapM (getTypeLHsExpr tcm) es
 41 |      pts <- mapM (getTypeLPat tcm) ps
 42 |      doThatThing $ sortBy cmp $ catMaybes $
 43 |        concat [ets,bts,pts]
 44 |   where cmp (_,a,_) (_,b,_)
 45 |           | a `isSubspanOf` b = LT
 46 |           | b `isSubspanOf` a = GT
 47 |           | otherwise = EQ
 48 | 
 49 | #if __GLASGOW_HASKELL__ >= 706
 50 | toTup :: DynFlags -> (Maybe Id,SrcSpan, Type) -> Maybe SpanInfo
 51 | toTup dflags (n,spn,typ) =
 52 |   fmap (\s ->
 53 |           s {spaninfoVar = n
 54 |             ,spaninfoType =
 55 |                S8.pack (showppr dflags typ)})
 56 |        (getSrcSpan' spn)
 57 | #else
 58 | toTup :: DynFlags -> (Maybe Id, SrcSpan, Type) -> Maybe SpanInfo
 59 | toTup dflags (n,spn,typ) =
 60 |   fmap (\s ->
 61 |           s {spaninfoType = S8.pack (showppr dflags typ)
 62 |             ,spaninfoVar = n})
 63 |        (getSrcSpan' spn)
 64 | #endif
 65 | 
 66 | getSrcSpan' :: SrcSpan -> Maybe SpanInfo
 67 | getSrcSpan' (RealSrcSpan spn) =
 68 |   Just (SpanInfo (srcSpanStartLine spn)
 69 |                  (srcSpanStartCol spn - 1)
 70 |                  (srcSpanEndLine spn)
 71 |                  (srcSpanEndCol spn - 1)
 72 |                  mempty
 73 |                  Nothing)
 74 | getSrcSpan' _ = Nothing
 75 | 
 76 | getTypeLHsBind :: (GhcMonad m)
 77 |                => TypecheckedModule
 78 |                -> LHsBind Id
 79 |                -> m (Maybe (Maybe Id,SrcSpan,Type))
 80 | #if __GLASGOW_HASKELL__ >= 708
 81 | getTypeLHsBind _ (L spn FunBind{fun_id=pid, fun_matches = MG _ _ typ}) =
 82 |   return (Just (Just (unLoc pid),spn,typ))
 83 | #else
 84 | getTypeLHsBind _ (L spn FunBind{fun_id=pid, fun_matches = MatchGroup _ typ}) =
 85 |   return (Just (Just (unLoc pid),spn,typ))
 86 | #endif
 87 | getTypeLHsBind _ _ = return Nothing
 88 | 
 89 | #if __GLASGOW_HASKELL__ >= 708
 90 | getTypeLHsExpr :: (GhcMonad m)
 91 |                => TypecheckedModule
 92 |                -> LHsExpr Id
 93 |                -> m (Maybe (Maybe Id,SrcSpan,Type))
 94 | getTypeLHsExpr _ e =
 95 |   do hs_env <- getSession
 96 |      (_,mbe) <- liftIO (deSugarExpr hs_env e)
 97 |      case mbe of
 98 |        Nothing -> return Nothing
 99 |        Just expr ->
100 |          return (Just (case unLoc e of
101 |                          HsVar i -> Just i
102 |                          _ -> Nothing
103 |                       ,getLoc e
104 |                       ,exprTypeCore expr))
105 | #else
106 | getTypeLHsExpr :: (GhcMonad m)
107 |                => TypecheckedModule
108 |                -> LHsExpr Id
109 |                -> m (Maybe (Maybe Id,SrcSpan,Type))
110 | getTypeLHsExpr tcm e = do
111 |     hs_env <- getSession
112 |     (_, mbe) <- liftIO $ deSugarExpr hs_env modu rn_env ty_env e
113 |     return ()
114 |     case mbe of
115 |         Nothing -> return Nothing
116 |         Just expr -> return $ Just (case unLoc e of
117 |                                       HsVar i -> Just i
118 |                                       _ -> Nothing,getLoc e, exprTypeCore expr)
119 |     where
120 |     modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
121 |     rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm
122 |     ty_env = tcg_type_env $ fst $ tm_internals_ tcm
123 | #endif
124 | 
125 | getTypeLPat :: (GhcMonad m)
126 |             => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))
127 | getTypeLPat _ (L spn pat) =
128 |   return (Just (Nothing,spn,hsPatType pat))
129 | 
130 | -- | Get ALL source spans in the source.
131 | listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]
132 | listifyAllSpans tcs = listifyStaged TypeChecker p tcs
133 |     where
134 |     p (L spn _) = isGoodSrcSpan spn
135 | 
136 | listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
137 | listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
138 | 
139 | ------------------------------------------------------------------------------
140 | -- The following was taken from 'ghc-syb-utils'
141 | --
142 | -- ghc-syb-utils:
143 | --     https://github.com/nominolo/ghc-syb
144 | 
145 | -- | Ghc Ast types tend to have undefined holes, to be filled
146 | --   by later compiler phases. We tag Asts with their source,
147 | --   so that we can avoid such holes based on who generated the Asts.
148 | data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
149 | 
150 | -- | Like 'everything', but avoid known potholes, based on the 'Stage' that
151 | --   generated the Ast.
152 | everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
153 | everythingStaged stage k z f x
154 |   | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z
155 |   | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
156 |   where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
157 |         postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool
158 |         fixity     = const (stage<Renamer)                     :: Fixity -> Bool
159 | 
160 | -- | I prefer to separate vulgar CPP nonsense outside of respectable functions.
161 | doThatThing ::  GhcMonad m => [(Maybe Id, SrcSpan, Type)] -> m [SpanInfo]
162 | doThatThing x = do
163 |     dflags <- getSessionDynFlags
164 |     return (mapMaybe (toTup dflags) x)
165 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Logging.hs:
--------------------------------------------------------------------------------
 1 | -- |
 2 | 
 3 | module GHC.Server.Logging where
 4 | 
 5 | import Control.Monad.Logger
 6 | import Control.Monad.Reader
 7 | 
 8 | --------------------------------------------------------------------------------
 9 | -- Logging functions
10 | 
11 | -- | Run the logging monad.
12 | runLogging :: MonadIO m => LoggingT m () -> m ()
13 | runLogging = runStdoutLoggingT
14 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Model/Find.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | {-# LANGUAGE TemplateHaskell #-}
  3 | {-# LANGUAGE BangPatterns #-}
  4 | 
  5 | -- | Finding identifiers, types, etc.
  6 | 
  7 | module GHC.Server.Model.Find where
  8 | 
  9 | import           GHC.Compat
 10 | import           GHC.Server.Types
 11 | import           System.Directory
 12 | 
 13 | import           Control.Monad.Logger
 14 | import           Data.ByteString (ByteString)
 15 | import           Data.List
 16 | import           Data.Map (Map)
 17 | import qualified Data.Map as M
 18 | import           Data.Maybe
 19 | import           Data.Text (Text)
 20 | import qualified Data.Text as T
 21 | import qualified Data.Text.Encoding as T
 22 | 
 23 | -- | Try to find the location of the given identifier at the given
 24 | -- position in the module, without looking at any external place.
 25 | findVar :: (GhcMonad m,MonadLogger m)
 26 |         => Map ModuleName ModInfo
 27 |         -> FilePath
 28 |         -> Text
 29 |         -> Int
 30 |         -> Int
 31 |         -> Int
 32 |         -> Int
 33 |         -> m (Either String Var)
 34 | findVar infos fp _string sl sc el ec =
 35 |   do mname <- guessModule infos fp
 36 |      case mname of
 37 |        Nothing ->
 38 |          $(logDebug) (("Couldn't guess the module name."))
 39 |        _ -> return ()
 40 |      case mname >>=
 41 |           flip M.lookup infos of
 42 |        Nothing ->
 43 |          return (Left ("No module info for the current file! Try loading it?"))
 44 |        Just info ->
 45 |          do d <- getSessionDynFlags
 46 |             case resolveName (modinfoSpans info)
 47 |                              sl
 48 |                              sc
 49 |                              el
 50 |                              ec of
 51 |               Nothing ->
 52 |                 return (Left "Couldn't resolve name.")
 53 |               Just name ->
 54 |                 case getSrcSpan name of
 55 |                   UnhelpfulSpan{} ->
 56 |                     return (Left ("Found a name, but no location information. The module is: " ++
 57 |                                   maybe "<unknown>"
 58 |                                         (showppr d . moduleName)
 59 |                                         (nameModule_maybe (getName name))))
 60 |                   _ -> return (Right name)
 61 | 
 62 | -- | Try to find the location of the given identifier at the given
 63 | -- position in the module.
 64 | findLoc :: (GhcMonad m,MonadLogger m)
 65 |         => Map ModuleName ModInfo
 66 |         -> FilePath
 67 |         -> Text
 68 |         -> Int
 69 |         -> Int
 70 |         -> Int
 71 |         -> Int
 72 |         -> m (Either String SrcSpan)
 73 | findLoc infos fp string sl sc el ec =
 74 |   do mname <- guessModule infos fp
 75 |      case mname of
 76 |        Nothing ->
 77 |          $(logDebug) (("Couldn't guess the module name."))
 78 |        _ -> return ()
 79 |      case mname >>=
 80 |           flip M.lookup infos of
 81 |        Nothing ->
 82 |          return (Left ("No module info for the current file! Try loading it?"))
 83 |        Just info ->
 84 |          do mname' <- findName infos info string sl sc el ec
 85 |             d <- getSessionDynFlags
 86 |             case mname' of
 87 |               Left reason -> return (Left reason)
 88 |               Right name ->
 89 |                 case getSrcSpan name of
 90 |                   UnhelpfulSpan{} ->
 91 |                     return (Left ("Found a name, but no location information. The module is: " ++
 92 |                                   maybe "<unknown>"
 93 |                                         (showppr d . moduleName)
 94 |                                         (nameModule_maybe name)))
 95 |                   span' -> return (Right span')
 96 | 
 97 | -- | Try to resolve the name located at the given position, or
 98 | -- otherwise resolve based on the current module's scope.
 99 | findName :: GhcMonad m
100 |          => Map ModuleName ModInfo
101 |          -> ModInfo
102 |          -> Text
103 |          -> Int
104 |          -> Int
105 |          -> Int
106 |          -> Int
107 |          -> m (Either String Name)
108 | findName infos mi string sl sc el ec =
109 |   case resolveName (modinfoSpans mi)
110 |                    sl
111 |                    sc
112 |                    el
113 |                    ec of
114 |     Nothing -> tryExternalModuleResolution
115 |     Just name ->
116 |       case getSrcSpan name of
117 |         UnhelpfulSpan{} -> tryExternalModuleResolution
118 |         _ -> return (Right (getName name))
119 |   where tryExternalModuleResolution =
120 |           case find (matchName (T.unpack string))
121 |                     (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
122 |             Nothing ->
123 |               return (Left "Couldn't resolve to any modules.")
124 |             Just imported -> resolveNameFromModule infos imported
125 |         matchName :: String -> Name -> Bool
126 |         matchName str name =
127 |           str ==
128 |           occNameString (getOccName name)
129 | 
130 | -- | Try to resolve the name from another (loaded) module's exports.
131 | resolveNameFromModule :: GhcMonad m
132 |                       => Map ModuleName ModInfo
133 |                       -> Name
134 |                       -> m (Either String Name)
135 | resolveNameFromModule infos name =
136 |   do d <- getSessionDynFlags
137 |      case nameModule_maybe name of
138 |        Nothing ->
139 |          return (Left ("No module for " ++
140 |                        showppr d name))
141 |        Just modL ->
142 |          do case M.lookup (moduleName modL) infos of
143 |               Nothing ->
144 |                 do (return (Left ("No locally loaded module for " ++
145 |                                   showppr d modL ++
146 |                                   ". It's in this package: " ++
147 |                                   showppr d (modulePackageId modL))))
148 |               Just info ->
149 |                 case find (matchName name)
150 |                           (modInfoExports (modinfoInfo info)) of
151 |                   Just name' ->
152 |                     return (Right name')
153 |                   Nothing ->
154 |                     return (Left "No matching export in any local modules.")
155 |   where matchName :: Name -> Name -> Bool
156 |         matchName x y =
157 |           occNameString (getOccName x) ==
158 |           occNameString (getOccName y)
159 | 
160 | -- | Try to resolve the type display from the given span.
161 | resolveName :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Var
162 | resolveName spans' sl sc el ec =
163 |   listToMaybe (mapMaybe spaninfoVar (filter inside (reverse spans')))
164 |   where inside (SpanInfo sl' sc' el' ec' _ _) =
165 |           ((sl' == sl && sc' >= sc) || (sl' > sl)) &&
166 |           ((el' == el && ec' <= ec) || (el' < el))
167 | 
168 | -- | Try to find the type of the given span.
169 | findType :: GhcMonad m
170 |          => Map ModuleName ModInfo
171 |          -> FilePath
172 |          -> Text
173 |          -> Int
174 |          -> Int
175 |          -> Int
176 |          -> Int
177 |          -> m (Either String Text)
178 | findType infos fp string sl sc el ec =
179 |   do mname <- guessModule infos fp
180 |      case mname >>=
181 |           flip M.lookup infos of
182 |        Nothing ->
183 |          return (Left ("Didn't find any module info. Is this module loaded?"))
184 |        Just info ->
185 |          do let !mty =
186 |                   resolveType (modinfoSpans info)
187 |                               sl
188 |                               sc
189 |                               el
190 |                               ec
191 |             case mty of
192 |               Just ty ->
193 |                 return (Right (T.decodeUtf8 ty))
194 |               Nothing ->
195 |                 do d <- getSessionDynFlags
196 |                    fmap (Right . T.pack . showppr d)
197 |                         (exprType (T.unpack string))
198 | 
199 | -- | Try to resolve the type display from the given span.
200 | resolveType :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe ByteString
201 | resolveType spans' sl sc el ec =
202 |   fmap spaninfoType (find inside (reverse spans'))
203 |   where inside (SpanInfo sl' sc' el' ec' _ _) =
204 |           ((sl' == sl && sc' >= sc) || (sl' > sl)) &&
205 |           ((el' == el && ec' <= ec) || (el' < el))
206 | 
207 | -- | Guess a module name from a file path.
208 | guessModule :: GhcMonad m
209 |             => Map ModuleName ModInfo -> FilePath -> m (Maybe ModuleName)
210 | guessModule infos fp =
211 |   do target <- guessTarget fp Nothing
212 |      case targetId target of
213 |        TargetModule mn -> return (Just mn)
214 |        _ ->
215 |          case find ((Just fp ==) .
216 |                     ml_hs_file .
217 |                     ms_location .
218 |                     modinfoSummary .
219 |                     snd)
220 |                    (M.toList infos) of
221 |            Just (mn,_) -> return (Just mn)
222 |            Nothing ->
223 |              do fp <- liftIO (makeRelativeToCurrentDirectory fp)
224 |                 target <- guessTarget fp Nothing
225 |                 case targetId target of
226 |                   TargetModule mn ->
227 |                     return (Just mn)
228 |                   _ ->
229 |                     case find ((Just fp ==) .
230 |                                ml_hs_file .
231 |                                ms_location .
232 |                                modinfoSummary .
233 |                                snd)
234 |                               (M.toList infos) of
235 |                       Just (mn,_) ->
236 |                         return (Just mn)
237 |                       Nothing ->
238 |                         return Nothing
239 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Model/Ghc.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE ConstraintKinds #-}
  2 | {-# LANGUAGE FlexibleContexts #-}
  3 | {-# LANGUAGE TemplateHaskell #-}
  4 | {-# LANGUAGE OverloadedStrings #-}
  5 | 
  6 | -- | Ghc monad actions.
  7 | 
  8 | module GHC.Server.Model.Ghc (initializeGhc,withMessages,loadedImports) where
  9 | 
 10 | import           GHC.Compat
 11 | import           GHC.Server.Cabal
 12 | import           GHC.Server.Defaults
 13 | import           GHC.Server.Types
 14 | 
 15 | import           Control.Concurrent.STM
 16 | import           Control.Monad.Logger
 17 | import           Control.Monad.Reader
 18 | import           Data.List
 19 | import           Data.Monoid
 20 | import qualified Data.Text as T
 21 | import           Linker
 22 | import           System.Environment
 23 | 
 24 | -- | Initialize the GHC service.
 25 | initializeGhc :: (MonadLogger m,GhcMonad m)
 26 |                    => m ()
 27 | initializeGhc =
 28 |   do (libincs,exts,pkgs) <- liftIO getDependencyInfo
 29 |      initialDynFlags <- getSessionDynFlags
 30 |      userFlags <- fmap (<> concat [exts,initFlags,deps pkgs,src libincs]) makeUserFlags
 31 |      (dflags',_,_) <- parseDynamicFlags
 32 |                         (initialDynFlags {hscTarget = HscAsm
 33 |                                          ,ghcLink = LinkInMemory
 34 |                                          ,ghcMode = CompManager
 35 |                                          ,optLevel = 0})
 36 |                         (map (mkGeneralLocated "flag") userFlags)
 37 |      let dflags'' = dflags'
 38 |      _ <- setSessionDynFlags dflags''
 39 |      (dflags''',packageids) <- liftIO (initPackages dflags'')
 40 |      _ <- setSessionDynFlags dflags'''
 41 |      mapM parseImportDecl necessaryImports >>=
 42 |        setContext
 43 |      liftIO (initDynLinker dflags''')
 44 |      $(logInfo)
 45 |        ("User flags: " <>
 46 |         T.pack (unwords userFlags))
 47 |      $(logInfo)
 48 |        ("Packages: " <>
 49 |         T.pack (unwords (map (showppr dflags''') packageids)))
 50 |   where initFlags =
 51 |           ["-fobject-code"
 52 |           ,"-dynamic-too"
 53 |           ,"-v1"
 54 |           ,"-optP-include"
 55 |           ,"-optPdist/build/autogen/cabal_macros.h"] <>
 56 |           ["-fdefer-type-errors" | ghcVersion >= Ghc78]
 57 |         deps [] = []
 58 |         deps xs =
 59 |           ["-hide-all-packages"] <>
 60 |           map (\pkg -> "-package " <> renderPackageId pkg) xs
 61 |         src [] = []
 62 |         src xs = map (\x -> "-i" <> x) xs
 63 | 
 64 | -- | Handle any messages coming from GHC. GHC seems to disregard
 65 | -- resetting the 'log_action' for some reason, so we set a log action
 66 | -- which will read from a var for its action and that var will be
 67 | -- reset once the action is done. Any further messages broadcast on
 68 | -- that handler will be printed in debugging mode as bogus.
 69 | withMessages :: (MonadDuplex i o m,GhcMonad m)
 70 |              => (DynFlags -> Severity -> SrcSpan -> SDoc -> Duplex i o ()) -> m a -> m a
 71 | withMessages handler m =
 72 |   do handlerV <- liftIO (atomically (newTVar handler))
 73 |      st <- ask
 74 |      oldFlags <- getSessionDynFlags
 75 |      setLogAction
 76 |        (\df sv sp _ msg ->
 77 |           do f <- atomically (readTVar handlerV)
 78 |              runReaderT (runDuplexT (f df (translateSeverity df sv msg) sp msg))
 79 |                         st)
 80 |      v <- m
 81 |      newFlags <- getSessionDynFlags
 82 |      void (setSessionDynFlags newFlags {log_action = log_action oldFlags})
 83 |      liftIO (atomically
 84 |                (writeTVar handlerV
 85 |                           (\df _ _ sdoc ->
 86 |                              $(logDebug) ("Bogus output after log action has been reset: " <>
 87 |                              T.pack (showSDoc df sdoc)))))
 88 |      return v
 89 | 
 90 | -- | GHC gives unhelpful severity in the presence of
 91 | -- -fdefer-type-errors, so we try to reclaim error information by
 92 | -- doing dirty wirty parsing.
 93 | translateSeverity :: DynFlags -> Severity -> SDoc -> Severity
 94 | translateSeverity df sv msg =
 95 |   case sv of
 96 |     SevWarning
 97 |       | isError msgstr -> SevError
 98 |       | otherwise -> SevWarning
 99 |     s -> s
100 |   where msgstr = showSDoc df msg
101 | 
102 | 
103 | -- | Is the message actually an error?
104 | isError :: [Char] -> Bool
105 | isError s =
106 |   isPrefixOf "No instance for "
107 |              (trim s) ||
108 |   isPrefixOf "Couldn't match "
109 |              (trim s) ||
110 |   isPrefixOf "Ambiguous "
111 |              (trim s) ||
112 |   isPrefixOf "Could not deduce "
113 |              (trim s)
114 |   where trim = unwords . words
115 | 
116 | -- | Print list of loaded imports.
117 | loadedImports :: [ModuleName] -> [String]
118 | loadedImports = map (\m -> "import " <> moduleNameString m)
119 | 
120 | -- | Make user flags, if HSENV is activated then use the
121 | -- PACKAGE_DB_FOR_GHC environment variable for package flags.
122 | makeUserFlags :: GhcMonad m => m [String]
123 | makeUserFlags =
124 |   do env <- liftIO getEnvironment
125 |      case lookup "HSENV" env >>
126 |           lookup "PACKAGE_DB_FOR_GHC" env of
127 |        Just uflags -> return (words uflags)
128 |        Nothing ->
129 |          case lookup "GHC_PACKAGE_PATH" env of
130 |            Just path ->
131 |              return ["-hide-all-packages","-pkg-db=" <> path]
132 |            Nothing -> return []
133 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Model/Info.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE RankNTypes #-}
  4 | 
  5 | -- | Get information on modules, identifiers, etc.
  6 | 
  7 | module GHC.Server.Model.Info (getModInfo) where
  8 | 
  9 | import           GHC.Compat
 10 | import           GHC.Server.Types
 11 | 
 12 | import qualified Data.Text as T
 13 | import           Control.Monad.Logger
 14 | import qualified Data.ByteString.Char8 as S8
 15 | import           Data.Generics (GenericQ, mkQ, extQ, gmapQ)
 16 | import           Data.List
 17 | import           Data.Maybe
 18 | import           Data.Monoid
 19 | import           Data.Typeable
 20 | 
 21 | -- | Get info about the module: summary, types, etc.
 22 | getModInfo :: (MonadLogger m,GhcMonad m) => ModuleName -> m ModInfo
 23 | getModInfo name =
 24 |   do df <- getSessionDynFlags
 25 |      $(logDebug) ("Generating info for module " <> T.pack (showppr df name))
 26 |      m <- getModSummary name
 27 |      p <- parseModule m
 28 |      typechecked <- typecheckModule p
 29 |      allTypes <- processAllTypeCheckedModule typechecked
 30 |      let i = tm_checked_module_info typechecked
 31 |      return (ModInfo m allTypes i)
 32 | 
 33 | -- | Get ALL source spans in the module.
 34 | processAllTypeCheckedModule :: GhcMonad m
 35 |                             => TypecheckedModule -> m [SpanInfo]
 36 | processAllTypeCheckedModule tcm =
 37 |   do let tcs = tm_typechecked_source tcm
 38 |          bs =
 39 |            listifyAllSpans tcs :: [LHsBind Id]
 40 |          es =
 41 |            listifyAllSpans tcs :: [LHsExpr Id]
 42 |          ps =
 43 |            listifyAllSpans tcs :: [LPat Id]
 44 |      bts <- mapM (getTypeLHsBind tcm) bs
 45 |      ets <- mapM (getTypeLHsExpr tcm) es
 46 |      pts <- mapM (getTypeLPat tcm) ps
 47 |      doThatThing $ sortBy cmp $ catMaybes $
 48 |        concat [ets,bts,pts]
 49 |   where cmp (_,a,_) (_,b,_)
 50 |           | a `isSubspanOf` b = LT
 51 |           | b `isSubspanOf` a = GT
 52 |           | otherwise = EQ
 53 | 
 54 | #if __GLASGOW_HASKELL__ >= 706
 55 | toTup :: DynFlags -> (Maybe Id,SrcSpan, Type) -> Maybe SpanInfo
 56 | toTup dflags (n,spn,typ) =
 57 |   fmap (\s ->
 58 |           s {spaninfoVar = n
 59 |             ,spaninfoType =
 60 |                S8.pack (showppr dflags typ)})
 61 |        (getSrcSpan' spn)
 62 | #else
 63 | toTup :: DynFlags -> (Maybe Id, SrcSpan, Type) -> Maybe SpanInfo
 64 | toTup dflags (n,spn,typ) =
 65 |   fmap (\s ->
 66 |           s {spaninfoType = S8.pack (showppr dflags typ)
 67 |             ,spaninfoVar = n})
 68 |        (getSrcSpan' spn)
 69 | #endif
 70 | 
 71 | getSrcSpan' :: SrcSpan -> Maybe SpanInfo
 72 | getSrcSpan' (RealSrcSpan spn) =
 73 |   Just (SpanInfo (srcSpanStartLine spn)
 74 |                  (srcSpanStartCol spn - 1)
 75 |                  (srcSpanEndLine spn)
 76 |                  (srcSpanEndCol spn - 1)
 77 |                  mempty
 78 |                  Nothing)
 79 | getSrcSpan' _ = Nothing
 80 | 
 81 | getTypeLHsBind :: (GhcMonad m)
 82 |                => TypecheckedModule
 83 |                -> LHsBind Id
 84 |                -> m (Maybe (Maybe Id,SrcSpan,Type))
 85 | #if __GLASGOW_HASKELL__ >= 708
 86 | getTypeLHsBind _ (L spn FunBind{fun_id=pid, fun_matches = MG _ _ typ}) =
 87 |   return (Just (Just (unLoc pid),spn,typ))
 88 | #else
 89 | getTypeLHsBind _ (L spn FunBind{fun_id=pid, fun_matches = MatchGroup _ typ}) =
 90 |   return (Just (Just (unLoc pid),spn,typ))
 91 | #endif
 92 | getTypeLHsBind _ _ = return Nothing
 93 | 
 94 | #if __GLASGOW_HASKELL__ >= 708
 95 | getTypeLHsExpr :: (GhcMonad m)
 96 |                => TypecheckedModule
 97 |                -> LHsExpr Id
 98 |                -> m (Maybe (Maybe Id,SrcSpan,Type))
 99 | getTypeLHsExpr _ e =
100 |   do hs_env <- getSession
101 |      (_,mbe) <- liftIO (deSugarExpr hs_env e)
102 |      case mbe of
103 |        Nothing -> return Nothing
104 |        Just expr ->
105 |          return (Just (case unLoc e of
106 |                          HsVar i -> Just i
107 |                          _ -> Nothing
108 |                       ,getLoc e
109 |                       ,exprTypeCore expr))
110 | #else
111 | getTypeLHsExpr :: (GhcMonad m)
112 |                => TypecheckedModule
113 |                -> LHsExpr Id
114 |                -> m (Maybe (Maybe Id,SrcSpan,Type))
115 | getTypeLHsExpr tcm e = do
116 |     hs_env <- getSession
117 |     (_, mbe) <- liftIO $ deSugarExpr hs_env modu rn_env ty_env e
118 |     return ()
119 |     case mbe of
120 |         Nothing -> return Nothing
121 |         Just expr -> return $ Just (case unLoc e of
122 |                                       HsVar i -> Just i
123 |                                       _ -> Nothing,getLoc e, exprTypeCore expr)
124 |     where
125 |     modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
126 |     rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm
127 |     ty_env = tcg_type_env $ fst $ tm_internals_ tcm
128 | #endif
129 | 
130 | getTypeLPat :: (GhcMonad m)
131 |             => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))
132 | getTypeLPat _ (L spn pat) =
133 |   return (Just (Nothing,spn,hsPatType pat))
134 | 
135 | -- | Get ALL source spans in the source.
136 | listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]
137 | listifyAllSpans tcs = listifyStaged TypeChecker p tcs
138 |     where
139 |     p (L spn _) = isGoodSrcSpan spn
140 | 
141 | listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
142 | listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
143 | 
144 | ------------------------------------------------------------------------------
145 | -- The following was taken from 'ghc-syb-utils'
146 | --
147 | -- ghc-syb-utils:
148 | --     https://github.com/nominolo/ghc-syb
149 | 
150 | -- | Ghc Ast types tend to have undefined holes, to be filled
151 | --   by later compiler phases. We tag Asts with their source,
152 | --   so that we can avoid such holes based on who generated the Asts.
153 | data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
154 | 
155 | -- | Like 'everything', but avoid known potholes, based on the 'Stage' that
156 | --   generated the Ast.
157 | everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
158 | everythingStaged stage k z f x
159 |   | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z
160 |   | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
161 |   where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
162 |         postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool
163 |         fixity     = const (stage<Renamer)                     :: Fixity -> Bool
164 | 
165 | -- | I prefer to separate vulgar CPP nonsense outside of respectable functions.
166 | doThatThing ::  GhcMonad m => [(Maybe Id, SrcSpan, Type)] -> m [SpanInfo]
167 | doThatThing x = do
168 |     dflags <- getSessionDynFlags
169 |     return (mapMaybe (toTup dflags) x)
170 | 


--------------------------------------------------------------------------------
/src/GHC/Server/TH.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell #-}
 2 | {-# LANGUAGE QuasiQuotes #-}
 3 | {-# LANGUAGE OverloadedStrings #-}
 4 | {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 5 | 
 6 | -- | Macros.
 7 | 
 8 | module GHC.Server.TH where
 9 | 
10 | import           GHC.Server.Logging
11 | import           GHC.Server.Types
12 | 
13 | import           Control.Concurrent
14 | import           Control.Monad.Logger
15 | import           Control.Monad.Reader
16 | import qualified Data.AttoLisp as L
17 | import qualified Data.ByteString.Lazy.Char8 as L8
18 | import           Data.Char
19 | import           Data.Monoid
20 | import qualified Data.Text as T
21 | import           Language.Haskell.TH
22 | 
23 | -- | Dispatch
24 | dispatch :: Name -> Q Exp
25 | dispatch t =
26 |   do info <- reify t
27 |      case info of
28 |        TyConI (DataD _ _ _ cs _) ->
29 |          [|\ghcChan' ix' h' inputChan' cmd' state' ->
30 |              do $(logDebug)
31 |                   ("Command: " <>
32 |                    T.pack (show cmd'))
33 |                 $(caseE [|cmd'|]
34 |                         (map (\(ForallC _ [EqualP _ returnType] (NormalC name args)) ->
35 |                                 let argNames =
36 |                                       zipWith (const . mkName . ("x" <>) . show)
37 |                                               [0 :: Int ..]
38 |                                               args
39 |                                 in match (conP name (map varP argNames))
40 |                                          (normalB [|(do outChan <- liftIO newChan
41 |                                                         void (liftIO (forkIO (runLogging
42 |                                                                                 (do contents <- liftIO (getChanContents outChan)
43 |                                                                                     forM_ contents
44 |                                                                                           (\o ->
45 |                                                                                              do $(logDebug)
46 |                                                                                                   ("Sending " <>
47 |                                                                                                    T.pack (show (L.encode (Outgoing ix' (FeedOut o)))))
48 |                                                                                                 liftIO (L8.hPutStrLn
49 |                                                                                                           h'
50 |                                                                                                           (L.encode (Outgoing $([|ix'|]) (FeedOut o)))))
51 |                                                                                     $(logDebug) ("Finished consuming outChan.")))))
52 |                                                         r <- liftIO (runReaderT (runDuplexT ($(foldl (\f a ->
53 |                                                                                                         appE f a)
54 |                                                                                                      (varE (mkName (decapitalize (nameBase name))))
55 |                                                                                                      (map varE argNames)) :: $(return returnType)))
56 |                                                                                 (DuplexState inputChan'
57 |                                                                                              outChan
58 |                                                                                              ghcChan'
59 |                                                                                              state'))
60 |                                                         $(logDebug)
61 |                                                           ("Result: " <>
62 |                                                            T.pack (show r))
63 |                                                         liftIO (L8.hPutStrLn h'
64 |                                                                              (L.encode (Outgoing ix' (EndResult r)))))|])
65 |                                          [])
66 |                              cs))|]
67 |        _ -> error "Dispatch argument should be a GADT type."
68 |   where decapitalize :: String -> String
69 |         decapitalize [] = []
70 |         decapitalize (x:xs) = toLower x : xs
71 | 


--------------------------------------------------------------------------------
/src/GHC/Server/Types.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | {-# LANGUAGE MultiParamTypeClasses #-}
  3 | {-# LANGUAGE FlexibleInstances #-}
  4 | {-# LANGUAGE CPP #-}
  5 | {-# LANGUAGE OverloadedStrings #-}
  6 | {-# LANGUAGE DeriveFunctor #-}
  7 | {-# LANGUAGE GADTs #-}
  8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  9 | {-# LANGUAGE ConstraintKinds #-}
 10 | {-# LANGUAGE ExistentialQuantification #-}
 11 | {-# LANGUAGE StandaloneDeriving #-}
 12 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 13 | 
 14 | -- | All server types.
 15 | 
 16 | module GHC.Server.Types
 17 |   (-- * Project state
 18 |    -- $state
 19 |    State(..)
 20 |   ,ModInfo(..)
 21 |   ,SpanInfo(..)
 22 |   -- * Commands
 23 |   ,Command(..)
 24 |   -- * Duplex monad
 25 |   -- $duplex
 26 |   ,MonadDuplex
 27 |   ,MonadGhc(..)
 28 |   ,DuplexT(..)
 29 |   ,DuplexState(..)
 30 |   ,Duplex
 31 |   ,Producer
 32 |   ,Returns
 33 |   ,Unit
 34 |   -- * Transport types
 35 |   ,Incoming(..)
 36 |   ,Outgoing(..)
 37 |   ,Input(..)
 38 |   ,Output(..)
 39 |   ,Outputish
 40 |   ,Inputish
 41 |   -- * Generic types
 42 |   ,SomeCommand(..)
 43 |   ,SomeChan(..)
 44 |   -- * Result types
 45 |   ,EvalResult(..)
 46 |   ,Msg(..))
 47 |   where
 48 | 
 49 | 
 50 | import           GHC.Compat
 51 | 
 52 | import           Control.Concurrent
 53 | import           Control.Concurrent.STM.TVar
 54 | import           Control.Monad.Logger
 55 | import           Control.Monad.Reader
 56 | import           Data.AttoLisp (FromLisp(..),ToLisp(..))
 57 | import qualified Data.AttoLisp as L
 58 | import           Data.Attoparsec.Number
 59 | import           Data.ByteString (ByteString)
 60 | import           Data.Map (Map)
 61 | import           Data.Text (Text)
 62 | import qualified Data.Text as T
 63 | 
 64 | --------------------------------------------------------------------------------
 65 | -- Project state
 66 | -- $state
 67 | --
 68 | -- All state is stored in one pure value which has 'TVar' slots. It is
 69 | -- passed to all command handlers as a reader value. The value itself
 70 | -- should never change for a given instance of ghc-server.
 71 | 
 72 | -- | Project-wide state.
 73 | data State =
 74 |   State {stateModuleInfos :: !(TVar (Map ModuleName ModInfo))
 75 |          -- ^ A mapping from local module names to information about that
 76 |          -- module such as scope, types, exports, imports, etc.  Regenerated
 77 |          -- after every module reload.
 78 |         }
 79 | 
 80 | -- | Info about a module. This information is generated every time a
 81 | -- module is loaded.
 82 | data ModInfo =
 83 |   ModInfo {modinfoSummary :: !ModSummary
 84 |            -- ^ Summary generated by GHC. Can be used to access more
 85 |            -- information about the module.
 86 |           ,modinfoSpans :: ![SpanInfo]
 87 |            -- ^ Generated set of information about all spans in the
 88 |            -- module that correspond to some kind of identifier for
 89 |            -- which there will be type info and/or location info.
 90 |           ,modinfoInfo :: !ModuleInfo
 91 |            -- ^ Again, useful from GHC for accessing information
 92 |            -- (exports, instances, scope) from a module.
 93 |           }
 94 | 
 95 | -- | Type of some span of source code. Most of these fields are
 96 | -- unboxed but Haddock doesn't show that.
 97 | data SpanInfo =
 98 |   SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int
 99 |             -- ^ Start line of the span.
100 |            ,spaninfoStartCol :: {-# UNPACK #-} !Int
101 |             -- ^ Start column of the span.
102 |            ,spaninfoEndLine :: {-# UNPACK #-} !Int
103 |             -- ^ End line of the span (absolute).
104 |            ,spaninfoEndCol :: {-# UNPACK #-} !Int
105 |             -- ^ End column of the span (absolute).
106 |            ,spaninfoType :: {-# UNPACK #-} !ByteString
107 |             -- ^ A pretty-printed representation fo the type.
108 |            ,spaninfoVar :: !(Maybe Id)
109 |             -- ^ The actual 'Var' associated with the span, if
110 |             -- any. This can be useful for accessing a variety of
111 |             -- information about the identifier such as module,
112 |             -- locality, definition location, etc.
113 |            }
114 | 
115 | --------------------------------------------------------------------------------
116 | -- Duplex types
117 | -- $duplex
118 | --
119 | -- All commands are handled in this monad. It supports full duplex
120 | -- communication between the server and a client. This is useful for
121 | -- things like streaming arbitrary many results in a compilation job,
122 | -- or in doing input/output for evaluation in a REPL.
123 | 
124 | -- | State for the duplex.
125 | data DuplexState i o =
126 |   DuplexState {duplexIn :: !(Chan i)
127 |                -- ^ A channel which is written to whenever a line is
128 |                -- received on the client's 'Handle'. This is read from
129 |                -- by the function 'GHC.Server.recv'.
130 |               ,duplexOut :: !(Chan o)
131 |                -- ^ A channel written to by the function
132 |                -- 'Ghc.Server.send', which will encode whatever is
133 |                -- written to it, @o@, into the transport format used
134 |                -- (probably 'Lisp') and then write it to the client's
135 |                -- 'Handle'.
136 |               ,duplexRunGhc :: !(Chan (Ghc ()))
137 |                -- ^ A channel on which one can put actions for the GHC
138 |                -- slave to perform. There is only one GHC slave per
139 |                -- ghc-server instance, and the GHC API is not
140 |                -- thread-safe, so we process one command at a time via
141 |                -- this interface.
142 |               ,duplexState :: !State
143 |                -- ^ The global project 'State'.
144 |               }
145 | 
146 | -- | Full duplex command handling monad. This is the monad
147 | -- used for any command handlers. This is an instance of 'GhcMonad'
148 | -- and 'MonadLogger' and 'MonadIO', so you can do GHC commands in it
149 | -- via 'GHC.Server.Duplex.withGHC', you can log via the usual
150 | -- monad-logger functions, and you can do IO via 'GHC.Compat.io'.
151 | newtype DuplexT m i o r =
152 |   DuplexT {runDuplexT :: ReaderT (DuplexState i o) m r}
153 |   deriving (Functor,Applicative,Monad,MonadIO)
154 | 
155 | -- | Anything that can access the duplexing state, do IO and log. In
156 | -- other words, any 'DuplexT' transformer.
157 | type MonadDuplex i o m =
158 |   (MonadReader (DuplexState i o) m
159 |   ,MonadIO m
160 |   ,Inputish i
161 |   ,Outputish o
162 |   ,MonadLogger m
163 |   ,MonadGhc m)
164 | 
165 | -- | This monad can run GHC actions inside it.
166 | class MonadGhc m where
167 |   liftGhc :: Ghc r -> m r
168 | 
169 | instance MonadGhc (DuplexT IO i o) where
170 |   liftGhc m =
171 |     do ghcChan <- asks duplexRunGhc
172 |        io (do result <- newEmptyMVar
173 |               io (writeChan ghcChan
174 |                             (do v <- m
175 |                                 io (putMVar result v)))
176 |               takeMVar result)
177 | 
178 | instance MonadGhc (DuplexT Ghc i o) where
179 |   liftGhc m =
180 |     DuplexT (ReaderT (const m))
181 | 
182 | instance ExceptionMonad (DuplexT Ghc i o) where
183 |   gcatch (DuplexT (ReaderT fm)) fh =
184 |     DuplexT (ReaderT (\r ->
185 |                         gcatch (fm r)
186 |                                (\e ->
187 |                                   let DuplexT (ReaderT fh') = fh e
188 |                                   in fh' r)))
189 |   gmask getsF =
190 |     DuplexT (ReaderT (\r ->
191 |                         gmask (\f ->
192 |                                  case getsF (\(DuplexT (ReaderT x')) ->
193 |                                                DuplexT (ReaderT (f . x'))) of
194 |                                    DuplexT (ReaderT rf) -> rf r)))
195 | 
196 | instance Monad m => MonadReader (DuplexState i o) (DuplexT m i o) where
197 |   ask = DuplexT ask
198 |   local f (DuplexT m) = DuplexT (local f m)
199 | 
200 | instance MonadIO m => MonadLogger (DuplexT m i o) where
201 |   monadLoggerLog loc source level msg =
202 |     liftIO (runStdoutLoggingT (monadLoggerLog loc source level msg))
203 | 
204 | instance HasDynFlags (DuplexT Ghc i o) where
205 |   getDynFlags =
206 |     DuplexT (ReaderT (const getDynFlags))
207 | 
208 | instance GhcMonad (DuplexT Ghc i o) where
209 |   getSession =
210 |     DuplexT (ReaderT (const getSession))
211 |   setSession s =
212 |     DuplexT (ReaderT (const (setSession s)))
213 | 
214 | instance ExceptionMonad (LoggingT Ghc) where
215 |   gcatch (LoggingT fm) fh =
216 |     LoggingT (\r ->
217 |                gcatch (fm r)
218 |                       (\e ->
219 |                          let (LoggingT fh') = fh e
220 |                          in fh' r))
221 |   gmask getsF =
222 |     LoggingT (\r ->
223 |                gmask (\f ->
224 |                         case getsF (\(LoggingT x') ->
225 |                                       LoggingT (f . x')) of
226 |                           (LoggingT rf) -> rf r))
227 | 
228 | instance HasDynFlags (LoggingT Ghc) where
229 |   getDynFlags =
230 |     LoggingT (const getDynFlags)
231 | 
232 | instance GhcMonad (LoggingT Ghc) where
233 |   getSession =
234 |     LoggingT (const getSession)
235 |   setSession s =
236 |     LoggingT (const (setSession s))
237 | 
238 | -- | Duplex transformed over IO. Default command handler monad.
239 | type Duplex i o r = DuplexT IO i o r
240 | 
241 | -- | Command that only produces output and a result, consumes no input.
242 | type Producer o r = Duplex () o r
243 | 
244 | -- | Command that only returns a result.
245 | type Returns r = Duplex () () r
246 | 
247 | -- | Command that returns no results at all.
248 | type Unit = Duplex () () ()
249 | 
250 | --------------------------------------------------------------------------------
251 | -- Transport layer types
252 | 
253 | -- | A input payload wrapper.
254 | data Incoming i =
255 |   Incoming !Integer
256 |            !(Input i)
257 |   deriving (Show)
258 | 
259 | -- | An output input payload wrapper.
260 | data Outgoing o =
261 |   Outgoing !Integer
262 |            !(Output o)
263 |   deriving (Show)
264 | 
265 | -- | An input value for some serialization type.
266 | data Input i
267 |   = Request !SomeCommand
268 |   | FeedIn !i
269 |   deriving (Show)
270 | 
271 | -- | An input value for some serialization type.
272 | data Output o
273 |   = EndResult !o
274 |   | FeedOut !o
275 |   | ErrorResult !SomeException
276 |   deriving (Show)
277 | 
278 | -- | Outputable things.
279 | type Outputish a = (ToLisp a,Show a)
280 | 
281 | -- | Inputable things.
282 | type Inputish a = (FromLisp a,Show a)
283 | 
284 | -- | Generic command.
285 | data SomeCommand =
286 |   forall i o r. (Inputish i,Outputish o,Outputish r) => SomeCommand (Command (Duplex i o r))
287 | 
288 | -- | A generic channel.
289 | data SomeChan = forall a. Inputish a => SomeChan (Chan a)
290 | 
291 | --------------------------------------------------------------------------------
292 | -- Transport serialization code
293 | 
294 | instance FromLisp l => FromLisp (Incoming l) where
295 |   parseLisp (L.List (L.Symbol "request" :i:input:_)) =
296 |     do input' <- parseLisp input
297 |        x <- parseLisp i
298 |        return (Incoming x (Request input'))
299 |   parseLisp (L.List (L.Symbol "feed" :i:input:_)) =
300 |     do input' <- parseLisp input
301 |        x <- parseLisp i
302 |        return (Incoming x (FeedIn input'))
303 |   parseLisp l = L.typeMismatch "Incoming" l
304 | 
305 | instance ToLisp l => ToLisp (Outgoing l) where
306 |   toLisp (Outgoing ix output) =
307 |     case output of
308 |       EndResult o ->
309 |         L.List [L.Symbol "end-result",toLisp ix,toLisp o]
310 |       FeedOut o ->
311 |         L.List [L.Symbol "result",toLisp ix,toLisp o]
312 |       ErrorResult o ->
313 |         L.List [L.Symbol "error-result",toLisp ix,toLisp o]
314 | 
315 | deriving instance Show SomeCommand
316 | instance L.FromLisp SomeCommand where
317 |   parseLisp (L.List (L.Symbol "ping":i:_)) =
318 |     do x <- L.parseLisp i
319 |        return (SomeCommand (Ping x))
320 |   parseLisp (L.List (L.Symbol "eval":L.String x:_)) =
321 |     return (SomeCommand (Eval x))
322 |   parseLisp (L.List (L.Symbol "type-of":L.String x:_)) =
323 |     return (SomeCommand (TypeOf x))
324 |   parseLisp (L.List (L.Symbol "type-at":L.String fp:L.String string:L.Number (I sl):L.Number (I sc):L.Number (I el):L.Number (I ec):_)) =
325 |     return (SomeCommand
326 |               (TypeAt (T.unpack fp)
327 |                       string
328 |                       (fromIntegral sl)
329 |                       (fromIntegral sc)
330 |                       (fromIntegral el)
331 |                       (fromIntegral ec)))
332 |   parseLisp (L.List (L.Symbol "uses":L.String fp:L.String string:L.Number (I sl):L.Number (I sc):L.Number (I el):L.Number (I ec):_)) =
333 |     return (SomeCommand
334 |               (UsesAt (T.unpack fp)
335 |                       string
336 |                       (fromIntegral sl)
337 |                       (fromIntegral sc)
338 |                       (fromIntegral el)
339 |                       (fromIntegral ec)))
340 |   parseLisp (L.List (L.Symbol "loc-at":L.String fp:L.String string:L.Number (I sl):L.Number (I sc):L.Number (I el):L.Number (I ec):_)) =
341 |     return (SomeCommand
342 |               (LocationAt (T.unpack fp)
343 |                           string
344 |                           (fromIntegral sl)
345 |                           (fromIntegral sc)
346 |                           (fromIntegral el)
347 |                           (fromIntegral ec)))
348 |   parseLisp (L.List (L.Symbol "kind-of":L.String x:_)) =
349 |     return (SomeCommand (KindOf x))
350 |   parseLisp (L.List (L.Symbol "info":L.String x:_)) =
351 |     return (SomeCommand (InfoOf x))
352 |   parseLisp (L.List (L.Symbol "load-target":L.String t:_)) =
353 |     return (SomeCommand (LoadTarget t))
354 |   parseLisp (L.List (L.Symbol "set":L.String opt:_)) =
355 |     return (SomeCommand (Set opt))
356 |   parseLisp (L.List (L.Symbol "package-conf":L.String pkgconf:_)) =
357 |     return (SomeCommand (PackageConf (T.unpack pkgconf)))
358 |   parseLisp (L.List (L.Symbol "cd":L.String dir:_)) =
359 |     return (SomeCommand (SetCurrentDir (T.unpack dir)))
360 |   parseLisp l = L.typeMismatch "Cmd" l
361 | 
362 | instance ToLisp SomeException where
363 |   toLisp e = toLisp (show e)
364 | 
365 | --------------------------------------------------------------------------------
366 | -- Commands
367 | 
368 | -- | Command.
369 | data Command a where
370 |   LoadTarget    :: Text -> Command (Producer Msg (SuccessFlag,Integer))
371 |    -- Load a module.
372 |   Eval          :: Text -> Command (Duplex Text Text EvalResult)
373 |   -- Eval something for the REPL.
374 |   Ping          :: Integer -> Command (Returns Integer)
375 |   -- Ping/pong. Handy for debugging.
376 |   TypeOf        :: Text -> Command (Returns Text)
377 |   -- Type of identifier.
378 |   LocationAt    :: FilePath -> Text -> Int -> Int -> Int -> Int -> Command (Returns SrcSpan)
379 |   -- Location of identifier at point.
380 |   TypeAt        :: FilePath -> Text -> Int -> Int -> Int -> Int -> Command (Returns Text)
381 |   -- Type of identifier at point.
382 |   UsesAt        :: FilePath -> Text -> Int -> Int -> Int -> Int -> Command (Returns Text)
383 |   -- Find uses.
384 |   KindOf        :: Text -> Command (Returns Text)
385 |   -- Kind of the identifier.
386 |   InfoOf        :: Text -> Command (Returns [Text])
387 |   -- Info of the identifier.
388 |   Set           :: Text -> Command (Returns ())
389 |   -- Set the options.
390 |   PackageConf   :: FilePath -> Command (Returns ())
391 |   -- Set the package conf.
392 |   SetCurrentDir :: FilePath -> Command (Returns ())
393 |   -- Set the current directory.
394 | 
395 | deriving instance Show (Command a)
396 | 
397 | -- | Evaluation result.
398 | data EvalResult =
399 |   NewContext [String]
400 |   deriving (Show)
401 | 
402 | instance ToLisp EvalResult where
403 |   toLisp (NewContext is) =
404 |     L.List [L.Symbol "new-context",toLisp is]
405 | 
406 | -- | A message.
407 | data Msg =
408 |   Msg !Severity
409 |       !SrcSpan
410 |       !Text
411 |   deriving (Show)
412 | 
413 | deriving instance Show Severity
414 | 
415 | instance ToLisp Msg where
416 |   toLisp (Msg sev span' text') =
417 |     L.List [L.Symbol "msg",toLisp sev,toLisp span',toLisp text']
418 | 
419 | instance ToLisp Severity where
420 |   toLisp t = L.Symbol (T.pack (showSeverity t))
421 | 
422 | instance Show SuccessFlag where
423 |   show Succeeded = "Succeeded"
424 |   show Failed = "Failed"
425 | 
426 | instance ToLisp SuccessFlag where
427 |   toLisp Succeeded = L.Symbol "succeeded"
428 |   toLisp Failed = L.Symbol "failed"
429 | 
430 | --------------------------------------------------------------------------------
431 | -- Spans
432 | 
433 | instance ToLisp SrcSpan where
434 |   toLisp (RealSrcSpan realsrcspan) = toLisp realsrcspan
435 |   toLisp (UnhelpfulSpan fs) = toLisp fs
436 | 
437 | instance ToLisp RealSrcSpan where
438 |   toLisp span' =
439 |     L.List [toLisp (srcSpanFile span')
440 |            ,toLisp (srcSpanStartLine span')
441 |            ,toLisp (srcSpanEndLine span')
442 |            ,toLisp (srcSpanStartCol span')
443 |            ,toLisp (srcSpanEndCol span')]
444 | 
445 | instance ToLisp FastString where
446 |   toLisp = toLisp . unpackFS
447 | 


--------------------------------------------------------------------------------
/src/main/Main.hs:
--------------------------------------------------------------------------------
 1 | -- | Main entry point to the program.
 2 | 
 3 | module Main where
 4 | 
 5 | import GHC.Server
 6 | import GHC.Server.Logging
 7 | 
 8 | import Data.Maybe
 9 | import System.Environment
10 | 
11 | -- | Main entry point.
12 | main :: IO ()
13 | main = do args <- fmap parse getArgs
14 |           runLogging (startServer (fromMaybe 5233 (lookup "port" args)))
15 |   where parse = go
16 |           where go ("--port":port:xs) = ("port",read port) : go xs
17 |                 go (_:xs) = go xs
18 |                 go [] = []
19 | 


--------------------------------------------------------------------------------