diff --git a/haskell-c2hs.el b/haskell-c2hs.el new file mode 100644 index 000000000..77be323eb --- /dev/null +++ b/haskell-c2hs.el @@ -0,0 +1,204 @@ +;; haskell-c2hs.el --- -*- lexical-binding: t; -*- + +;; Copyright (C) 2016 Sergey Vinokurov +;; +;; Author: Sergey Vinokurov +;; Created: Monday, 7 March 2016 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; This mode is mostly intended for highlighting {#...#} hooks. +;; +;; Quick setup: +;; (autoload 'c2hs-mode "c2hs-mode" nil t) +;; (add-to-list 'auto-mode-alist '("\\.chs\\'" . c2hs-mode)) +;; + +(require 'haskell-mode) +(require 'haskell-font-lock) +(require 'haskell-utils) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.chs\\'" . c2hs-mode)) + +(defface c2hs-hook-pair-face + '((t (:inherit 'font-lock-preprocessor-face))) + "Face for highlighting {#...#} pairs." + :group 'haskell) + +(defface c2hs-hook-name-face + '((t (:inherit 'font-lock-keyword-face))) + "Face for highlighting c2hs hook names." + :group 'haskell) + +;;;###autoload +(defvar c2hs-font-lock-keywords + `((,(haskell--rx-let ((ws (any ?\s ?\t ?\n ?\r)) + (anychar (or (not (any ?#)) + (seq "#" + (not (any ?\}))))) + (any-nonquote (or (not (any ?# ?\")) + (seq "#" + (not (any ?\} ?\"))))) + (cid (seq (any (?a . ?z) (?A . ?Z) ?_) + (* (any (?a . ?z) (?A . ?Z) (?0 . ?9) ?_)))) + (hsid-type (seq (? "'") + (any (?A . ?Z)) + (* (any (?a . ?z) (?A . ?Z) (?0 . ?9) ?_ ?')))) + (equals-str-val (seq (* ws) + "=" + (* ws) + "\"" + (* any-nonquote) + "\""))) + (group-n 1 "{#") + (* ws) + (or (seq (group-n 2 + "import" + (opt (+ ws) + "qualified")) + (+ ws)) + (seq (group-n 2 + "context") + (opt (+ ws) + (group-n 3 + "lib") + equals-str-val) + (opt (+ ws) + (group-n 4 + "prefix") + equals-str-val) + (opt (+ ws) + (group-n 5 + "add" + (+ ws) + "prefix") + equals-str-val)) + (seq (group-n 2 + "type") + (+ ws) + cid) + (seq (group-n 2 + "sizeof") + (+ ws) + cid) + (seq (group-n 2 + "enum" + (+ ws) + "define") + (+ ws) + cid) + ;; TODO: vanilla enum fontification is incomplete + (seq (group-n 2 + "enum") + (+ ws) + cid + (opt (+ ws) + (group-n 3 + "as"))) + ;; TODO: fun hook highlighting is incompelete + (seq (group-n 2 + (or "call" + "fun") + (opt (+ ws) + "pure") + (opt (+ ws) + "unsafe")) + (+ ws) + cid + (opt (+ ws) + (group-n 3 + "as") + (opt (+ ws) + (group-n 8 + "^")))) + (group-n 2 + "get") + (group-n 2 + "set") + (seq (group-n 2 + "pointer") + (or (seq (* ws) + (group-n 3 "*") + (* ws)) + (+ ws)) + cid + (opt (+ ws) + (group-n 4 "as") + (+ ws) + hsid-type) + (opt (+ ws) + (group-n 5 + (or "foreign" + "stable"))) + (opt + (or (seq (+ ws) + (group-n 6 + "newtype")) + (seq (* ws) + "->" + (* ws) + hsid-type))) + (opt (+ ws) + (group-n 7 + "nocode"))) + (group-n 2 + "class") + (group-n 2 + "alignof") + (group-n 2 + "offsetof") + (seq (group-n 2 + "const") + (+ ws) + cid) + (seq (group-n 2 + "typedef") + (+ ws) + cid + (+ ws) + hsid-type) + (group-n 2 + "nonGNU") + ;; TODO: default hook not implemented + ) + (* anychar) + (group-n 9 "#}")) + ;; Override highlighting for pairs in order to always distinguish them. + (1 'c2hs-hook-pair-face t) + (2 'c2hs-hook-name-face) + ;; Make matches lax, i.e. do not signal error if nothing + ;; matched. + (3 'c2hs-hook-name-face nil t) + (4 'c2hs-hook-name-face nil t) + (5 'c2hs-hook-name-face nil t) + (6 'c2hs-hook-name-face nil t) + (7 'c2hs-hook-name-face nil t) + (8 'font-lock-negation-char-face nil t) + ;; Override highlighting for pairs in order to always distinguish them. + (9 'c2hs-hook-pair-face t)) + ,@(haskell-font-lock-keywords))) + +;;;###autoload +(define-derived-mode c2hs-mode haskell-mode "C2HS" + "Mode for editing *.chs files of the c2hs haskell tool." + (setq-local font-lock-defaults + (cons 'c2hs-font-lock-keywords + (cdr font-lock-defaults)))) + + +(provide 'haskell-c2hs) + +;; haskell-c2hs.el ends here diff --git a/haskell-utils.el b/haskell-utils.el index 6f4f9a53d..8814e33c2 100644 --- a/haskell-utils.el +++ b/haskell-utils.el @@ -39,6 +39,8 @@ ;; require/depend-on any other haskell-mode modules in order to ;; stay at the bottom of the module dependency graph. +(eval-when-compile (require 'cl-lib)) + (require 'haskell-customize) (defvar haskell-utils-async-post-command-flag nil @@ -175,5 +177,23 @@ expression bounds." end-c value))))) +(defmacro haskell--rx-let (definitions &rest main-expr) + "Return `rx' invokation of main-expr that has symbols defined in +DEFINITIONS substituted by definition body. DEFINITIONS is list +of let-bindig forms, ( ). No recursion is permitted - +no defined symbol should show up in body of its definition or in +body of any futher definition." + (declare (indent 1)) + (let ((invalid-def (cl-find-if (lambda (def) (not (= 2 (length def)))) definitions))) + (when invalid-def + (error "haskell--rx-let: every definition must consist of two elements: (name def), but this one doesn't: %s" + invalid-def))) + `(rx ,@(cl-reduce (lambda (def expr) + (cl-subst (cadr def) (car def) expr + :test #'eq)) + definitions + :initial-value main-expr + :from-end t))) + (provide 'haskell-utils) ;;; haskell-utils.el ends here diff --git a/tests/haskell-c2hs-tests.el b/tests/haskell-c2hs-tests.el new file mode 100644 index 000000000..78e604e6d --- /dev/null +++ b/tests/haskell-c2hs-tests.el @@ -0,0 +1,309 @@ +;; haskell-c2hs-tests.el --- -*- lexical-binding: t; -*- + +(require 'ert) +(require 'haskell-c2hs) +(require 'haskell-test-utils) + +(ert-deftest haskell-c2hs-basic-import-hook () + "C2HS import hook" + (check-properties + '("{# import Foo #}") + '(("{#" t c2hs-hook-pair-face) + ("import" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-qualified-import-hook () + "C2HS qualified import hook" + (check-properties + '("{#import qualified Foo#}") + '(("{#" t c2hs-hook-pair-face) + ("import" "w" c2hs-hook-name-face) + ("qualified" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-full-context-hook () + "C2HS full context hook" + (check-properties + '("{# context lib = \"libgtk.so\" prefix = \"gtk\" add prefix = \"CGtk\" #}") + '(("{#" t c2hs-hook-pair-face) + ("context" "w" c2hs-hook-name-face) + ("lib" "w" c2hs-hook-name-face) + ("prefix" "w" c2hs-hook-name-face) + ("add" "w" c2hs-hook-name-face) + ("prefix" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-type-hook () + "C2HS type hook" + (check-properties + '("{# type gint #}") + '(("{#" t c2hs-hook-pair-face) + ("type" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-sizeof-hook () + "C2HS sizeof hook" + (check-properties + '("{# sizeof double #}") + '(("{#" t c2hs-hook-pair-face) + ("sizeof" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-enum-hook () + "C2HS enum hook" + (check-properties + '("{#enum v4l2_quantization as Quantization" + " { V4L2_QUANTIZATION_DEFAULT as Default" + " , V4L2_QUANTIZATION_FULL_RANGE as FullRange" + " , V4L2_QUANTIZATION_LIM_RANGE as LimitedRange" + " }" + " deriving (Show, Eq, Ord)" + " #}") + '(("{#" t c2hs-hook-pair-face) + ("enum" "w" c2hs-hook-name-face) + ("as" "w" c2hs-hook-name-face) + ("Quantization" "w" haskell-constructor-face) + ("V4L2_QUANTIZATION_DEFAULT" "w" haskell-constructor-face) + ("Default" "w" haskell-constructor-face) + ("V4L2_QUANTIZATION_FULL_RANGE" "w" haskell-constructor-face) + ("FullRange" "w" haskell-constructor-face) + ("V4L2_QUANTIZATION_LIM_RANGE" "w" haskell-constructor-face) + ("LimitedRange" "w" haskell-constructor-face) + ("deriving" "w" haskell-keyword-face) + ("Show" "w" haskell-constructor-face) + ("Eq" "w" haskell-constructor-face) + ("Ord" "w" haskell-constructor-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-enum-define-hook () + "C2HS enum define hook" + (check-properties + '("{#enum define MMapProtectionFlag" + " { PROT_READ as ProtRead" + " , PROT_WRITE as ProtWrite" + " , PROT_EXEC as ProtExec" + " , PROT_NONE as ProtNone" + " }" + " deriving (Show, Eq, Ord)" + " #}" + ) + '(("{#" t c2hs-hook-pair-face) + ("enum" "w" c2hs-hook-name-face) + ("define" "w" c2hs-hook-name-face) + ("MMapProtectionFlag" "w" haskell-constructor-face) + ("PROT_READ" "w" haskell-constructor-face) + ("ProtRead" "w" haskell-constructor-face) + ("PROT_WRITE" "w" haskell-constructor-face) + ("ProtWrite" "w" haskell-constructor-face) + ("PROT_EXEC" "w" haskell-constructor-face) + ("ProtExec" "w" haskell-constructor-face) + ("PROT_NONE" "w" haskell-constructor-face) + ("ProtNone" "w" haskell-constructor-face) + ("deriving" "w" haskell-keyword-face) + ("Show" "w" haskell-constructor-face) + ("Eq" "w" haskell-constructor-face) + ("Ord" "w" haskell-constructor-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-pure-call-hook () + "C2HS pure call hook" + (check-properties + '("sin :: Float -> Float" + "sin = {#call pure sin as \"_sin\"#}") + '(("sin" "w" haskell-definition-face) + ("::" t haskell-operator-face) + ("Float" "w" haskell-constructor-face) + ("->" t haskell-operator-face) + ("Float" "w" haskell-constructor-face) + ("sin" "w" haskell-definition-face) + ("=" t haskell-operator-face) + ("{#" t c2hs-hook-pair-face) + ("call" "w" c2hs-hook-name-face) + ("pure" "w" c2hs-hook-name-face) + ("as" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-unsafe-call-hook () + "C2HS unsafe fun hook" + (check-properties + '("{#fun unsafe sin as ^#}") + '(("{#" t c2hs-hook-pair-face) + ("fun" "w" c2hs-hook-name-face) + ("unsafe" "w" c2hs-hook-name-face) + ("as" "w" c2hs-hook-name-face) + ("^" t font-lock-negation-char-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-pure-fun-hook () + "C2HS pure call hook" + (check-properties + '("{#fun pure sin as \"_sin\"#}") + '(("{#" t c2hs-hook-pair-face) + ("fun" "w" c2hs-hook-name-face) + ("pure" "w" c2hs-hook-name-face) + ("as" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-unsafe-fun-hook () + "C2HS unsafe fun hook" + (check-properties + '("{#fun unsafe sin as ^#}") + '(("{#" t c2hs-hook-pair-face) + ("fun" "w" c2hs-hook-name-face) + ("unsafe" "w" c2hs-hook-name-face) + ("as" "w" c2hs-hook-name-face) + ("^" t font-lock-negation-char-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-get-hook () + "C2HS get hook" + (check-properties + '("visualGetType :: Visual -> IO VisualType" + "visualGetType (Visual vis) = liftM cToEnum $ {#get Visual->type#} vis") + '(("visualGetType" "w" haskell-definition-face) + ("::" t haskell-operator-face) + ("Visual" "w" haskell-constructor-face) + ("->" t haskell-operator-face) + ("IO" "w" haskell-constructor-face) + ("VisualType" "w" haskell-constructor-face) + ("visualGetType" "w" haskell-definition-face) + ("Visual" "w" haskell-constructor-face) + ("=" t haskell-operator-face) + ("$" t haskell-operator-face) + ("{#" t c2hs-hook-pair-face) + ("get" "w" c2hs-hook-name-face) + ("Visual" "w" haskell-constructor-face) + ("->" t haskell-operator-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-set-hook () + "C2HS set hook" + (check-properties + '("{#set sockaddr_in.sin_family#} addr_in (cFromEnum AF_NET)") + '(("{#" t c2hs-hook-pair-face) + ("set" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face) + ("AF_NET" "w" haskell-constructor-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-pointer-hook-1 () + "C2HS pointer hook" + (check-properties + '("{#pointer *GtkObject as Object foreign newtype#}") + '(("{#" t c2hs-hook-pair-face) + ("pointer" "w" c2hs-hook-name-face) + ("*" t c2hs-hook-name-face) + ("GtkObject" "w" haskell-constructor-face) + ("as" "w" c2hs-hook-name-face) + ("Object" "w" haskell-constructor-face) + ("foreign" "w" c2hs-hook-name-face) + ("newtype" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-pointer-hook-2 () + "C2HS pointer hook" + (check-properties + '("{# pointer point as PointPtr -> Point #}") + '(("{#" t c2hs-hook-pair-face) + ("pointer" "w" c2hs-hook-name-face) + ("PointPtr" "w" haskell-constructor-face) + ("->" t haskell-operator-face) + ("Point" "w" haskell-constructor-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-full-pointer-hook () + "C2HS full pointer hook" + (check-properties + '("{#pointer * foo_t as FooPtr stable -> MkFooPtr nocode#}") + '(("{#" t c2hs-hook-pair-face) + ("pointer" "w" c2hs-hook-name-face) + ("*" t c2hs-hook-name-face) + ("as" "w" c2hs-hook-name-face) + ("FooPtr" "w" haskell-constructor-face) + ("stable" "w" c2hs-hook-name-face) + ("MkFooPtr" "w" haskell-constructor-face) + ("nocode" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-class-hook () + "C2HS class hook" + (check-properties + '("{# class GtkObjectClass => GtkWidgetClass GtkWidget #}") + '(("{#" t c2hs-hook-pair-face) + ("class" "w" c2hs-hook-name-face) + ("GtkObjectClass" "w" haskell-constructor-face) + ("=>" t haskell-operator-face) + ("GtkWidgetClass" "w" haskell-constructor-face) + ("GtkWidget" "w" haskell-constructor-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-alignof-hook () + "C2HS alignof hook" + (check-properties + '("gIntAlign :: Int" + "gIntAlign = {#alignof gint#}") + '(("gIntAlign" "w" haskell-definition-face) + ("::" t haskell-operator-face) + ("Int" "w" haskell-constructor-face) + ("gIntAlign" "w" haskell-definition-face) + ("=" t haskell-operator-face) + ("{#" t c2hs-hook-pair-face) + ("alignof" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-offsetof-hook () + "C2HS offsetof hook" + (check-properties + '("{#offsetof struct_t->somefield#}") + '(("{#" t c2hs-hook-pair-face) + ("offsetof" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-const-hook () + "C2HS const hook" + (check-properties + '("{#const FOO_BAR#}") + '(("{#" t c2hs-hook-pair-face) + ("const" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-typedef-hook () + "C2HS typedef hook" + (check-properties + '("{# typedef size_t CSize #}") + '(("{#" t c2hs-hook-pair-face) + ("typedef" "w" c2hs-hook-name-face) + ("CSize" "w" haskell-constructor-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +(ert-deftest haskell-c2hs-nongnu-hook () + "C2HS nonGNU hook" + (check-properties + '("{#nonGNU#}") + '(("{#" t c2hs-hook-pair-face) + ("nonGNU" "w" c2hs-hook-name-face) + ("#}" t c2hs-hook-pair-face)) + 'c2hs-mode)) + +;; haskell-c2hs-tests.el ends here + diff --git a/tests/haskell-font-lock-tests.el b/tests/haskell-font-lock-tests.el index 2e583b5fc..86165d902 100644 --- a/tests/haskell-font-lock-tests.el +++ b/tests/haskell-font-lock-tests.el @@ -7,77 +7,6 @@ ;; without font lock initially and needs to be extra enabled (add-hook 'sql-mode-hook (lambda () (sql-set-product 'ansi))) -(defun check-syntax-and-face-match-range (beg end syntax face) - "Check if all charaters between positions BEG and END have -syntax set to SYNTAX and face set to FACE. - -If SYNTAX or FACE are set to t then any syntex respective face is -not checked." - (let (all-syntaxes - all-faces - (text (buffer-substring-no-properties beg end))) - (while (< beg end) - (add-to-list 'all-syntaxes (syntax-class (syntax-after beg))) - (add-to-list 'all-faces (get-text-property beg 'face)) - (setq beg (1+ beg))) - (unless (eq syntax t) - (should (equal (list text (list (syntax-class (string-to-syntax syntax)))) - (list text all-syntaxes)))) - (unless (eq face t) - (should (equal (list text (list face)) - (list text all-faces)))))) - -(defun check-face-match-range (face 0) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (while (< beg end) - (should (eq face (get-text-property beg 'face))) - (setq beg (1+ beg))))) - -(defmacro with-haskell-mode-buffer (&rest body) - "Run BODY in the context of a new buffer set to `haskell-mode'. - -Buffer is named *haskell-mode-buffer*. It is not deleted -after a test as this aids interactive debugging." - (declare (indent 1) (debug t)) - `(progn - ;; we want to create buffer from scratch so that there are no - ;; leftover state from the previous test - (when (get-buffer "*haskell-mode-buffer*") - (kill-buffer "*haskell-mode-buffer*")) - (save-current-buffer - (set-buffer (get-buffer-create "*haskell-mode-buffer*")) - (haskell-mode) - ,@body))) - -(defun check-properties (lines-or-contents props &optional literate) - "Check if syntax properties and font-lock properties as set properly. - -LINES is a list of strings that will be inserted to a new -buffer. Then PROPS is a list of tripples of (string syntax -face). String is searched for in the buffer and then is checked -if all of its characters have syntax and face. See -`check-syntax-and-face-match-range`." - (when (get-buffer "*haskell-mode-buffer*") - (kill-buffer "*haskell-mode-buffer*")) - (save-current-buffer - (set-buffer (get-buffer-create "*haskell-mode-buffer*")) - (if (consp lines-or-contents) - (dolist (line lines-or-contents) - (insert line) - (insert "\n")) - (insert lines-or-contents)) - - (if literate - (literate-haskell-mode) - (haskell-mode)) - (font-lock-fontify-buffer) - (goto-char (point-min)) - (dolist (prop props) - (cl-destructuring-bind (string syntax face) prop - (search-forward string) - (check-syntax-and-face-match-range (match-beginning 0) (match-end 0) syntax face))))) - (ert-deftest haskell-syntactic-test-1 () "Simple keywords fontified" (check-properties @@ -504,7 +433,7 @@ if all of its characters have syntax and face. See ("Comment2" t haskell-literate-comment-face) ("code3" t haskell-definition-face) ("Comment3" t haskell-literate-comment-face)) - 'literate)) + 'literate-haskell-mode)) (ert-deftest haskell-literate-bird-2 () ;; Haskell Report requires empty line before bird code block. So it @@ -526,7 +455,7 @@ if all of its characters have syntax and face. See ("Comment2" t haskell-literate-comment-face) ("code3" t haskell-definition-face) ("Comment3" t haskell-literate-comment-face)) - 'literate)) + 'literate-haskell-mode)) (ert-deftest haskell-literate-latex-1 () (check-properties @@ -548,7 +477,7 @@ if all of its characters have syntax and face. See ("Comment2" t haskell-literate-comment-face) ("code3" t haskell-definition-face) ("Comment3" t haskell-literate-comment-face)) - 'literate)) + 'literate-haskell-mode)) (ert-deftest haskell-literate-mixed-1 () ;; Although Haskell Report does not advice mixing modes, it is a @@ -571,7 +500,7 @@ if all of its characters have syntax and face. See ("Comment2" t haskell-literate-comment-face) ("code3" t haskell-definition-face) ("Comment3" t haskell-literate-comment-face)) - 'literate)) + 'literate-haskell-mode)) (ert-deftest haskell-type-instance () "Fontify \"instance\" after \"type\"" diff --git a/tests/haskell-test-utils.el b/tests/haskell-test-utils.el index 7bdd63962..58ff67f93 100644 --- a/tests/haskell-test-utils.el +++ b/tests/haskell-test-utils.el @@ -56,5 +56,70 @@ keybindings without this." (and (buffer-name ,temp-buffer) (kill-buffer ,temp-buffer)))))) +(defun check-syntax-and-face-match-range (beg end syntax face) + "Check if all charaters between positions BEG and END have +syntax set to SYNTAX and face set to FACE. + +If SYNTAX or FACE are set to t then any syntex respective face is +not checked." + (let (all-syntaxes + all-faces + (text (buffer-substring-no-properties beg end))) + (while (< beg end) + (add-to-list 'all-syntaxes (syntax-class (syntax-after beg))) + (add-to-list 'all-faces (get-text-property beg 'face)) + (setq beg (1+ beg))) + (unless (eq syntax t) + (should (equal (list text (list (syntax-class (string-to-syntax syntax)))) + (list text all-syntaxes)))) + (unless (eq face t) + (should (equal (list text (list face)) + (list text all-faces)))))) + +(defun check-face-match-range (face n) + (let ((beg (match-beginning n)) + (end (match-end n))) + (while (< beg end) + (should (eq face (get-text-property beg 'face))) + (setq beg (1+ beg))))) + +(defmacro with-haskell-test-buffer (mode &rest body) + "Run BODY in the context of a new buffer set to `haskell-mode'. + +Buffer is named *haskell-mode-buffer*. It is not deleted +after a test as this aids interactive debugging." + (declare (indent 1) (debug t)) + `(progn + ;; we want to create buffer from scratch so that there are no + ;; leftover state from the previous test + (when (get-buffer "*haskell-test-buffer*") + (kill-buffer "*haskell-test-buffer*")) + (save-current-buffer + (set-buffer (get-buffer-create "*haskell-test-buffer*")) + (funcall ,mode) + ,@body))) + +(defun check-properties (lines-or-contents props &optional mode) + "Check if syntax properties and font-lock properties as set properly. + +LINES is a list of strings that will be inserted to a new +buffer. Then PROPS is a list of tripples of (string syntax +face). String is searched for in the buffer and then is checked +if all of its characters have syntax and face. See +`check-syntax-and-face-match-range`." + (with-haskell-test-buffer (or mode #'haskell-mode) + (if (consp lines-or-contents) + (dolist (line lines-or-contents) + (insert line) + (insert "\n")) + (insert lines-or-contents)) + + (font-lock-fontify-buffer) + (goto-char (point-min)) + (dolist (prop props) + (cl-destructuring-bind (string syntax face) prop + (search-forward string) + (check-syntax-and-face-match-range (match-beginning 0) (match-end 0) syntax face))))) + (provide 'haskell-test-utils) ;;; haskell-test-utils.el ends here