hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

adding defstruct.

Browse Source
This commit is contained in:
Kazu Yamamoto 2010-10-28 16:24:45 +09:00
parent a133d60484
commit a5d12ad707
2 changed files with 61 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
elisp/ghc-doc.el
View File

@ -23,8 +23,9 @@
(call-process "ghc-pkg" nil t nil "find-module" "--simple-output" mod) (call-process "ghc-pkg" nil t nil "find-module" "--simple-output" mod)
(goto-char (point-min)) (goto-char (point-min))
(when (re-search-forward "\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\)$") (when (re-search-forward "\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\)$")
(cons (match-string-no-properties 1) (ghc-make-pkg-ver
(match-string-no-properties 2))))) :pkg (match-string-no-properties 1)
:ver (match-string-no-properties 2)))))
(defun ghc-resolve-document-path (pkg) (defun ghc-resolve-document-path (pkg)
(with-temp-buffer (with-temp-buffer
@ -39,20 +40,20 @@
(defconst ghc-doc-hackage-format (defconst ghc-doc-hackage-format
"http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html") "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html")
(defun ghc-display-document (pkg mod haskell-org) (ghc-defstruct pkg-ver pkg ver)
(when (and pkg mod)
(let* ((mod- (ghc-replace-character mod ?. ?-))
(url (if haskell-org
(format ghc-doc-hackage-format (car pkg) (cdr pkg) mod-)
(let* ((pkg-with-ver (format "%s-%s" (car pkg) (cdr pkg)))
(path (ghc-resolve-document-path pkg-with-ver)))
(if (file-exists-p (format "%s/%s.html" path mod-))
(format ghc-doc-local-format path mod-)
;; fall back to online version if local file
;; doesn't exist:
(format ghc-doc-hackage-format (car pkg) (cdr pkg) mod-))))))
(browse-url url))))
(defun ghc-display-document (pkg-ver mod haskell-org)
(when (and pkg-ver mod)
(let* ((mod- (ghc-replace-character mod ?. ?-))
(pkg (ghc-pkg-ver-get-pkg pkg-ver))
(ver (ghc-pkg-ver-get-ver pkg-ver))
(pkg-with-ver (format "%s-%s" pkg ver))
(path (ghc-resolve-document-path pkg-with-ver))
(local (format ghc-doc-local-format path mod-))
(remote (format ghc-doc-hackage-format pkg ver mod-))
(file (format "%s/%s.html" path mod-))
(url (if (or haskell-org (not (file-exists-p file))) remote local)))
(browse-url url))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

45
elisp/ghc-func.el
View File

@ -90,4 +90,49 @@
(defconst ghc-null 0) (defconst ghc-null 0)
(defconst ghc-newline 10) (defconst ghc-newline 10)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ghc-keyword-number-pair (spec)
(let ((len (length spec)) key ret)
(dotimes (i len (nreverse ret))
(setq key (intern (concat ":" (symbol-name (car spec)))))
(setq ret (cons (cons key i) ret))
(setq spec (cdr spec)))))
(defmacro ghc-defstruct (type &rest spec)
`(progn
(ghc-defstruct-constructor ,type ,@spec)
(ghc-defstruct-s/getter ,type ,@spec)))
(defmacro ghc-defstruct-constructor (type &rest spec)
`(defun ,(intern (concat "ghc-make-" (symbol-name type))) (&rest args)
(let* ((alist (quote ,(ghc-keyword-number-pair spec)))
(struct (make-list (length alist) nil))
key val key-num)
(while args ;; cannot use dolist
(setq key (car args))
(setq args (cdr args))
(setq val (car args))
(setq args (cdr args))
(unless (keywordp key)
(error "'%s' is not a keyword" key))
(setq key-num (assoc key alist))
(if key-num
(setcar (nthcdr (cdr key-num) struct) val)
(error "'%s' is unknown" key)))
struct)))
(defmacro ghc-defstruct-s/getter (type &rest spec)
`(let* ((type-name (symbol-name ',type))
(keys ',spec)
(len (length keys))
member-name setter getter)
(dotimes (i len)
(setq member-name (symbol-name (car keys)))
(setq setter (intern (format "ghc-%s-set-%s" type-name member-name)))
(fset setter (list 'lambda '(struct value) (list 'setcar (list 'nthcdr i 'struct) 'value) 'struct))
(setq getter (intern (format "ghc-%s-get-%s" type-name member-name)))
(fset getter (list 'lambda '(struct) (list 'nth i 'struct)))
(setq keys (cdr keys)))))
(provide 'ghc-func) (provide 'ghc-func)