Skip to content

Commit 923e3f1

Browse files
gracjangracjan
committed
Merge pull request #1212 from sergv/c2hs-fixes
C2hs fixes
2 parents c72c4db + 7d1235e commit 923e3f1

File tree

3 files changed

+262
-276
lines changed

3 files changed

+262
-276
lines changed

‎haskell-c2hs.el

Lines changed: 151 additions & 147 deletions
Original file line numberDiff line numberDiff line change
@@ -22,179 +22,183 @@
2222
;; This mode is mostly intended for highlighting {#...#} hooks.
2323
;;
2424
;; Quick setup:
25-
;; (autoload 'c2hs-mode "c2hs-mode" nil t)
26-
;; (add-to-list 'auto-mode-alist '("\\.chs\\'" . c2hs-mode))
25+
;; (autoload 'haskell-c2hs-mode "haskell-c2hs-mode" nil t)
26+
;; (add-to-list 'auto-mode-alist '("\\.chs\\'" . haskell-c2hs-mode))
2727
;;
2828

2929
(require 'haskell-mode)
3030
(require 'haskell-font-lock)
3131
(require 'haskell-utils)
3232

3333
;;;###autoload
34-
(add-to-list 'auto-mode-alist '("\\.chs\\'" . c2hs-mode))
34+
(add-to-list 'auto-mode-alist '("\\.chs\\'" . haskell-c2hs-mode))
3535

36-
(defface c2hs-hook-pair-face
36+
(defface haskell-c2hs-hook-pair-face
3737
'((t (:inherit 'font-lock-preprocessor-face)))
3838
"Face for highlighting {#...#} pairs."
3939
:group 'haskell)
4040

41-
(defface c2hs-hook-name-face
41+
(defface haskell-c2hs-hook-name-face
4242
'((t (:inherit 'font-lock-keyword-face)))
4343
"Face for highlighting c2hs hook names."
4444
:group 'haskell)
4545

46-
(defvar c2hs-font-lock-keywords
47-
`((,(haskell--rx-let ((ws (any ?\s ?\t ?\n ?\r))
48-
(anychar (or (not (any ?#))
49-
(seq "#"
50-
(not (any ?\})))))
51-
(any-nonquote (or (not (any ?# ?\"))
52-
(seq "#"
53-
(not (any ?\} ?\")))))
54-
(cid (seq (any (?a . ?z) (?A . ?Z) ?_)
55-
(* (any (?a . ?z) (?A . ?Z) (?0 . ?9) ?_))))
56-
(hsid-type (seq (? "'")
57-
(any (?A . ?Z))
58-
(* (any (?a . ?z) (?A . ?Z) (?0 . ?9) ?_ ?'))))
59-
(equals-str-val (seq (* ws)
60-
"="
61-
(* ws)
62-
"\""
63-
(* any-nonquote)
64-
"\"")))
65-
(group-n 1 "{#")
66-
(* ws)
67-
(or (seq (group-n 2
68-
"import"
69-
(opt (+ ws)
70-
"qualified"))
71-
(+ ws))
72-
(seq (group-n 2
73-
"context")
74-
(opt (+ ws)
75-
(group-n 3
76-
"lib")
77-
equals-str-val)
78-
(opt (+ ws)
79-
(group-n 4
80-
"prefix")
81-
equals-str-val)
82-
(opt (+ ws)
83-
(group-n 5
84-
"add"
85-
(+ ws)
86-
"prefix")
87-
equals-str-val))
88-
(seq (group-n 2
89-
"type")
90-
(+ ws)
91-
cid)
92-
(seq (group-n 2
93-
"sizeof")
94-
(+ ws)
95-
cid)
96-
(seq (group-n 2
97-
"enum"
98-
(+ ws)
99-
"define")
100-
(+ ws)
101-
cid)
102-
;; TODO: vanilla enum fontification is incomplete
103-
(seq (group-n 2
104-
"enum")
105-
(+ ws)
106-
cid
107-
(opt (+ ws)
108-
(group-n 3
109-
"as")))
110-
;; TODO: fun hook highlighting is incompelete
111-
(seq (group-n 2
112-
(or "call"
113-
"fun")
114-
(opt (+ ws)
115-
"pure")
116-
(opt (+ ws)
117-
"unsafe"))
118-
(+ ws)
119-
cid
120-
(opt (+ ws)
121-
(group-n 3
122-
"as")
123-
(opt (+ ws)
124-
(group-n 8
125-
"^"))))
126-
(group-n 2
127-
"get")
128-
(group-n 2
129-
"set")
130-
(seq (group-n 2
131-
"pointer")
132-
(or (seq (* ws)
133-
(group-n 3 "*")
134-
(* ws))
135-
(+ ws))
136-
cid
137-
(opt (+ ws)
138-
(group-n 4 "as")
139-
(+ ws)
140-
hsid-type)
141-
(opt (+ ws)
142-
(group-n 5
143-
(or "foreign"
144-
"stable")))
145-
(opt
146-
(or (seq (+ ws)
147-
(group-n 6
148-
"newtype"))
149-
(seq (* ws)
150-
"->"
151-
(* ws)
152-
hsid-type)))
153-
(opt (+ ws)
154-
(group-n 7
155-
"nocode")))
156-
(group-n 2
157-
"class")
158-
(group-n 2
159-
"alignof")
160-
(group-n 2
161-
"offsetof")
162-
(seq (group-n 2
163-
"const")
164-
(+ ws)
165-
cid)
166-
(seq (group-n 2
167-
"typedef")
168-
(+ ws)
169-
cid
170-
(+ ws)
171-
hsid-type)
172-
(group-n 2
173-
"nonGNU")
174-
;; TODO: default hook not implemented
175-
)
176-
(* anychar)
177-
(group-n 9 "#}"))
46+
(defvar haskell-c2hs-font-lock-keywords
47+
`((,(eval-when-compile
48+
(let* ((ws '(any ?\s ?\t ?\n ?\r))
49+
(anychar '(or (not (any ?#))
50+
(seq "#"
51+
(not (any ?\})))))
52+
(any-nonquote '(or (not (any ?# ?\"))
53+
(seq "#"
54+
(not (any ?\} ?\")))))
55+
(cid '(seq (any (?a . ?z) (?A . ?Z) ?_)
56+
(* (any (?a . ?z) (?A . ?Z) (?0 . ?9) ?_))))
57+
(hsid-type '(seq (? "'")
58+
(any (?A . ?Z))
59+
(* (any (?a . ?z) (?A . ?Z) (?0 . ?9) ?_ ?'))))
60+
(equals-str-val `(seq (* ,ws)
61+
"="
62+
(* ,ws)
63+
"\""
64+
(* ,any-nonquote)
65+
"\"")))
66+
(eval
67+
`(rx
68+
(seq
69+
(group-n 1 "{#")
70+
(* ,ws)
71+
(or (seq (group-n 2
72+
"import"
73+
(opt (+ ,ws)
74+
"qualified"))
75+
(+ ,ws))
76+
(seq (group-n 2
77+
"context")
78+
(opt (+ ,ws)
79+
(group-n 3
80+
"lib")
81+
,equals-str-val)
82+
(opt (+ ,ws)
83+
(group-n 4
84+
"prefix")
85+
,equals-str-val)
86+
(opt (+ ,ws)
87+
(group-n 5
88+
"add"
89+
(+ ,ws)
90+
"prefix")
91+
,equals-str-val))
92+
(seq (group-n 2
93+
"type")
94+
(+ ,ws)
95+
,cid)
96+
(seq (group-n 2
97+
"sizeof")
98+
(+ ,ws)
99+
,cid)
100+
(seq (group-n 2
101+
"enum"
102+
(+ ,ws)
103+
"define")
104+
(+ ,ws)
105+
,cid)
106+
;; TODO: vanilla enum fontification is incomplete
107+
(seq (group-n 2
108+
"enum")
109+
(+ ,ws)
110+
,cid
111+
(opt (+ ,ws)
112+
(group-n 3
113+
"as")))
114+
;; TODO: fun hook highlighting is incompelete
115+
(seq (group-n 2
116+
(or "call"
117+
"fun")
118+
(opt (+ ,ws)
119+
"pure")
120+
(opt (+ ,ws)
121+
"unsafe"))
122+
(+ ,ws)
123+
,cid
124+
(opt (+ ,ws)
125+
(group-n 3
126+
"as")
127+
(opt (+ ,ws)
128+
(group-n 8
129+
"^"))))
130+
(group-n 2
131+
"get")
132+
(group-n 2
133+
"set")
134+
(seq (group-n 2
135+
"pointer")
136+
(or (seq (* ,ws)
137+
(group-n 3 "*")
138+
(* ,ws))
139+
(+ ,ws))
140+
,cid
141+
(opt (+ ,ws)
142+
(group-n 4 "as")
143+
(+ ,ws)
144+
,hsid-type)
145+
(opt (+ ,ws)
146+
(group-n 5
147+
(or "foreign"
148+
"stable")))
149+
(opt
150+
(or (seq (+ ,ws)
151+
(group-n 6
152+
"newtype"))
153+
(seq (* ,ws)
154+
"->"
155+
(* ,ws)
156+
,hsid-type)))
157+
(opt (+ ,ws)
158+
(group-n 7
159+
"nocode")))
160+
(group-n 2
161+
"class")
162+
(group-n 2
163+
"alignof")
164+
(group-n 2
165+
"offsetof")
166+
(seq (group-n 2
167+
"const")
168+
(+ ,ws)
169+
,cid)
170+
(seq (group-n 2
171+
"typedef")
172+
(+ ,ws)
173+
,cid
174+
(+ ,ws)
175+
,hsid-type)
176+
(group-n 2
177+
"nonGNU")
178+
;; TODO: default hook not implemented
179+
)
180+
(* ,anychar)
181+
(group-n 9 "#}"))))))
178182
;; Override highlighting for pairs in order to always distinguish them.
179-
(1 'c2hs-hook-pair-face t)
180-
(2 'c2hs-hook-name-face)
183+
(1 'haskell-c2hs-hook-pair-face t)
184+
(2 'haskell-c2hs-hook-name-face)
181185
;; Make matches lax, i.e. do not signal error if nothing
182186
;; matched.
183-
(3 'c2hs-hook-name-face nil t)
184-
(4 'c2hs-hook-name-face nil t)
185-
(5 'c2hs-hook-name-face nil t)
186-
(6 'c2hs-hook-name-face nil t)
187-
(7 'c2hs-hook-name-face nil t)
187+
(3 'haskell-c2hs-hook-name-face nil t)
188+
(4 'haskell-c2hs-hook-name-face nil t)
189+
(5 'haskell-c2hs-hook-name-face nil t)
190+
(6 'haskell-c2hs-hook-name-face nil t)
191+
(7 'haskell-c2hs-hook-name-face nil t)
188192
(8 'font-lock-negation-char-face nil t)
189193
;; Override highlighting for pairs in order to always distinguish them.
190-
(9 'c2hs-hook-pair-face t))
194+
(9 'haskell-c2hs-hook-pair-face t))
191195
,@(haskell-font-lock-keywords)))
192196

193197
;;;###autoload
194-
(define-derived-mode c2hs-mode haskell-mode "C2HS"
198+
(define-derived-mode haskell-c2hs-mode haskell-mode "C2HS"
195199
"Mode for editing *.chs files of the c2hs haskell tool."
196200
(setq-local font-lock-defaults
197-
(cons 'c2hs-font-lock-keywords
201+
(cons 'haskell-c2hs-font-lock-keywords
198202
(cdr font-lock-defaults))))
199203

200204

‎haskell-utils.el

Lines changed: 0 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -180,23 +180,5 @@ expression bounds."
180180
end-c
181181
value)))))
182182

183-
(defmacro haskell--rx-let (definitions &rest main-expr)
184-
"Return `rx' invokation of main-expr that has symbols defined in
185-
DEFINITIONS substituted by definition body. DEFINITIONS is list
186-
of let-bindig forms, (<symbol> <body>). No recursion is permitted -
187-
no defined symbol should show up in body of its definition or in
188-
body of any futher definition."
189-
(declare (indent 1))
190-
(let ((invalid-def (cl-find-if (lambda (def) (not (= 2 (length def)))) definitions)))
191-
(when invalid-def
192-
(error "haskell--rx-let: every definition must consist of two elements: (name def), but this one doesn't: %s"
193-
invalid-def)))
194-
`(rx ,@(cl-reduce (lambda (def expr)
195-
(cl-subst (cadr def) (car def) expr
196-
:test #'eq))
197-
definitions
198-
:initial-value main-expr
199-
:from-end t)))
200-
201183
(provide 'haskell-utils)
202184
;;; haskell-utils.el ends here

0 commit comments

Comments
 (0)