branch: elpa/haskell-tng-mode
commit 79aeb82f3d5bdaa3e6e84a4f5ace0f294f9bd1bf
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@gmail.com>
most of the grammar
---
haskell-tng-smie.el | 97 ++++++++++++++-----------------------------
test/haskell-tng-sexp-test.el | 49 +++++++++++-----------
test/src/layout.hs.sexps | 30 ++++++-------
3 files changed, 71 insertions(+), 105 deletions(-)
diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index 56c329a..bc729ac 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -22,11 +22,13 @@
(require 'haskell-tng-font-lock)
(require 'haskell-tng-lexer)
-;; FIXME a haskell grammar that doesn't have warnings during the tests
-
;; https://www.gnu.org/software/emacs/manual/html_mono/elisp.html#SMIE-Grammar
;; https://www.haskell.org/onlinereport/haskell2010/haskellch3.html
;;
+;; Transcribed here. Many of these grammar rules cannot be expressed in SMIE
+;; because Haskell uses whitespace separators a lot, whereas the BNF must use
+;; non-terminals.
+;;
;; exp infixexp :: [context =>] type (expression type signature)
;; | infixexp
;;
@@ -60,80 +62,43 @@
(smie-bnf->prec2
'((id)
(exp
- ;; TODO context
- ;;(infixexp "::" context "=>" type)
+ (infixexp "::" context "=>" type)
(infixexp "::" type)
- (infixexp)
- )
+ (infixexp))
- ;; TODO update the lexer to provide a virtual token for infix but keep
- ;; popular operators with important fixity.
+ (context
+ ("(" context ")")
+ (context "," context))
+
+ ;; TODO the lexer should provide virtual infix operators
(infixexp
(lexp "$" infixexp)
- (lexp "+" infixexp)
- (lexp "-" infixexp)
- ;; (lexp "*" infixexp)
- ;; (lexp "/" infixexp)
- ;; (lexp "<$>" infixexp)
- ;; (lexp "<*>" infixexp)
- ;; (lexp ">>=" infixexp)
- ;; (lexp "`should`" infixexp)
- ;; (lexp "&" infixexp)
-
- ;;("-" infixexp) ;; can't be opener and neither
- (lexp)
- )
-
- ;; TODO should we support terminators as separators?
- ;;(insts (insts ";" insts) (inst))
+ (lexp))
(lexp
("if" exp "then" exp "else" exp)
- ;; TODO apats
- ;;("let" decls "in" exp)
- ;;("case" exp "of" alts)
- ;;("do" stmts)
- ;; TODO where?
- ;; TODO fexp
- )
-
- ;; (decls
- ;; ;;("{" decls "}")
- ;; (decls ";" decls)
- ;; (decl))
- ;; (decl
- ;; (id "=" exp))
- ;; (alts
- ;; ;;("{" alts "}")
- ;; (alts ";" alts)
- ;; (alt))
- ;; (alt
- ;; (id "->" exp))
- ;; (stmts
- ;; ;;("{" stmts "}")
- ;; (stmts ";" stmts)
- ;; (stmt))
- ;; (stmt
- ;; (id "<-" exp))
-
+ ("where" decls)
+ ("let" decls "in" exp)
+ ("do" stmts)
+ ("case" exp "of" alts))
+
+ (decls
+ ("{" decls "}")
+ (decls ";" decls)
+ (id "=" exp))
+ (alts
+ ("{" alts "}")
+ (alts ";" alts)
+ (id "->" exp))
+ (stmts
+ ("{" stmts "}")
+ (stmts ";" stmts)
+ (id "<-" exp))
)
;; operator precedences
- ;;'((assoc ";"))
- ;;'((assoc ","))
- '((assoc "else" "::") ;; TODO keywords here
- (assoc "$")
- ;; TODO arrange by fixity
- (assoc "+" "-"))
- ;; '((assoc "*"))
- ;; '((assoc "/"))
- ;; '((assoc "<$>"))
- ;; '((assoc "<*>"))
- ;; '((assoc ">>="))
- ;; '((assoc "&"))
-
-;; Read the "<" and ">" as parentheses: when confronted with "... else E $ ..."
-;;SMIE is not sure if you meant "... else E) $ ..." or "... else (E $ ...".
+ '((left ";" "," "::" "else" "in" "of" "->" "do" "<-" "where" "=")
+ (left "$"))
)))
diff --git a/test/haskell-tng-sexp-test.el b/test/haskell-tng-sexp-test.el
index dc3a15f..7332243 100644
--- a/test/haskell-tng-sexp-test.el
+++ b/test/haskell-tng-sexp-test.el
@@ -21,9 +21,10 @@
;; tokens.
(ert-deftest haskell-tng-sexp-file-tests ()
+ ;; the baselines have some pretty funky stuff in them...
(should (have-expected-sexps (testdata "src/layout.hs")))
- ;; TODO enable when layout.hs gives better results...
+ ;; to the extent that they aren't even useful
;;(should (have-expected-sexps (testdata "src/medley.hs")))
)
@@ -37,24 +38,24 @@
;; and `backward-sexp', provided by SMIE.
(defun haskell-tng-sexp-test:sexps-at-point (p)
"Return a list of cons cells (start . end)"
- (let* (sexps
- (forward-backward
- (ignore-errors
- (save-excursion
- (goto-char p)
- (forward-sexp)
- (let ((forward (point)))
- (backward-sexp)
- (unless (= (point) forward)
- (cons (point) forward))))))
- (backward-forward
- (ignore-errors
- (save-excursion
- (goto-char p)
- (backward-sexp)
- (let ((backward (point)))
- (forward-sexp)
- (unless (= backward (point))
+ (let (sexps
+ (forward-backward
+ (ignore-errors
+ (save-excursion
+ (goto-char p)
+ (forward-sexp)
+ (let ((forward (point)))
+ (backward-sexp)
+ (unless (= (point) forward)
+ (cons (point) forward))))))
+ (backward-forward
+ (ignore-errors
+ (save-excursion
+ (goto-char p)
+ (backward-sexp)
+ (let ((backward (point)))
+ (forward-sexp)
+ (unless (= backward (point))
(cons backward (point))))))))
(when forward-backward
(push forward-backward sexps))
@@ -67,9 +68,8 @@
(goto-char (point-min))
(let (sexps)
(while (not (eobp))
- (unless (nth 8 (syntax-ppss)) ;; don't query in comments/strings
- (let ((here (haskell-tng-sexp-test:sexps-at-point (point))))
- (setq sexps (append here sexps))))
+ (let ((here (haskell-tng-sexp-test:sexps-at-point (point))))
+ (setq sexps (append here sexps)))
(forward-char))
(delete-dups sexps)))
@@ -78,10 +78,11 @@
(let (chars exit)
(goto-char (point-min))
(while (not exit)
- (--each sexps
+ ;; there is ambiguity around multiple parens at the same point
+ (--each (reverse sexps)
(cond
- ((= (point) (car it)) (push "(" chars))
((= (point) (cdr it)) (push ")" chars))
+ ((= (point) (car it)) (push "(" chars))
(t nil)))
(if (eobp)
(setq exit 't)
diff --git a/test/src/layout.hs.sexps b/test/src/layout.hs.sexps
index a412dc4..b260243 100644
--- a/test/src/layout.hs.sexps
+++ b/test/src/layout.hs.sexps
@@ -1,20 +1,20 @@
-(-- Figure 2.1 from the Haskell2010 report
-(((((module)) (AStack()( (Stack(),) (push(),) (pop(),) (top(),) (size) ))
(where)
-(data) (Stack) (a) (=) (Empty)
+((--) (Figure) (2.1) (from) (the) (Haskell2010) (report)
+(module)) (AStack)(( (Stack), (push), (pop), (top), (size) )) (where
+(((data) (Stack) (a) = (Empty)
(|) (MkStack) (a) (((Stack) (a)))
-(push) (::) (a) (->) (Stack) (a) (->) (Stack) (a)
-(push) (x) (s) (=) (MkStack) (x) (s)
+(push) (::) (((a) (->) ((Stack) (a) (->) (Stack) (a)))
+((push) (x) (s) = (MkStack) (x) (s))
-(size)) (::) (Stack) (a) (->) (Int)
-(size) (s) (=) (length) (((stkToLst) (s))) (where)
- (stkToLst) (Empty) (=) ([])
- (stkToLst) (((MkStack) (x) (s))) (=) (x:xs) (where) (xs) (=)
(stkToLst) (s)
+(size) (::) ((((Stack) (a) (->) (Int))
+((size) (s) = (length) (((stkToLst) (s))) (where
+ ((stkToLst) (Empty) = ([])
+ ((stkToLst) (((MkStack) (x) (s))) = (x:xs) (where ((xs) =
(stkToLst) (s)
-(pop)) (::) (Stack) (a) (->) (((a(),) (Stack) (a)))
-(pop) (((MkStack) (x) (s)))
- (=) (((x)(,) (case) (s) (of) r (->) (i) (r) (where) i (x) (=) x)) -- (pop
Empty) is an error
+)))))))(pop) (::) (((Stack) (a) (->) (((a), (Stack) (a))))
+((pop) (((MkStack) (x) (s)))
+ = (((x), ((case (s) (of) ((r (->) (i) (r) (where (i (x) = x))))))))) ((--)
(((pop) (Empty))) (is) (an) (error)
-(top)) (::) (Stack) (a) (->) (a)
-(top) (((MkStack) (x) (s))) (=) (x) -- (top Empty) is an
error
-)
\ No newline at end of file
+(top)) (::) ((Stack) (a) (->) (a))
+((top) (((MkStack) (x) (s))) = (x)))))) (--) (((top)
(Empty))) (is) (an) (error)
+))
\ No newline at end of file
