;;; haskell-lexeme.el --- haskell lexical tokens   -*- coding: utf-8; lexical-binding: t -*-

;; Copyright (C) 2015 Gracjan Polak

;; This file 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, or (at your option)
;; any later version.

;; This file 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 <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(require 'rx)

(unless (category-docstring ?P)
  (define-category ?P "Haskell symbol constituent characters")
  (map-char-table
   #'(lambda (key val)
       (if (or
            (and (consp key) (> (car key) 128))
            (and (numberp key) (> key 128)))
           (if (member val '(Pc Pd Po Sm Sc Sk So))
               (modify-category-entry key ?P))))
   unicode-category-table)

  (dolist (key (string-to-list "!#$%&*+./<=>?@^|~\\-:"))
    (modify-category-entry key ?P)))

(defconst haskell-lexeme-modid
  "[[:upper:]][[:alnum:]'_]*"
  "Regexp matching a valid Haskell module identifier.

Note that GHC accepts Unicode category UppercaseLetter as a first
character. Following letters are from Unicode categories
UppercaseLetter, LowercaseLetter, OtherLetter, TitlecaseLetter,
ModifierLetter, DecimalNumber, OtherNumber, backslash or
underscore.")

(defconst haskell-lexeme-id
  "[[:alpha:]_][[:alnum:]'_]*"
  "Regexp matching a valid Haskell identifier.

GHC accepts a string starting with any alphabetic character or
underscore followed by any alphanumeric character or underscore
or apostrophe.")

(defconst haskell-lexeme-sym
  "\\cP+"
  "Regexp matching a valid Haskell variable or constructor symbol.

GHC accepts a string of chars from the set
[:!#$%&*+./<=>?@^|~\\-] or Unicode category Symbol for chars with
codes larger than 128 only.")

(defconst haskell-lexeme-idsym-first-char
  "\\(?:[[:alpha:]_]\\|\\cP\\)"
  "Regexp matching first character of a qualified or unqualified
identifier or symbol.

Useful for `re-search-forward'.")

(defconst haskell-lexeme-modid-opt-prefix
  (concat "\\(?:" haskell-lexeme-modid "\\.\\)*")
  "Regexp matching a valid Haskell module prefix, potentially empty.

Module path prefix is separated by dots and finishes with a
dot. For path component syntax see `haskell-lexeme-modid'.")

(defconst haskell-lexeme-qid-or-qsym
  (rx-to-string `(: (regexp ,haskell-lexeme-modid-opt-prefix)
                    (group (| (regexp ,haskell-lexeme-id) (regexp ,haskell-lexeme-sym)
                              ))))
  "Regexp matching a valid qualified identifier or symbol.

Note that (match-string 1) returns the unqualified part.")

(defun haskell-lexeme-looking-at-qidsym ()
  "Non-nil when point is just in front of an optionally qualified
identifier or symbol.

Using this function is more efficient than matching against the
regexp `haskell-lexeme-qid-or-qsym'.

Returns:
  \\='qid - if matched a qualified id: \\='Data.Map\\=' or \\='Map\\='
  \\='qsym - if matched a qualified id: \\='Monad.>>=\\=' or \\='>>=\\='
  \\='qprefix - if matched only modid prefix: \\='Data.\\='

After successful \\='qid or \\='qsym match (match-string 1) will return
the unqualified part (if any)."
  (let ((begin (point))
        (match-data-old (match-data t)))
    (save-excursion
      (while (looking-at (concat haskell-lexeme-modid "\\."))
        (goto-char (match-end 0)))
      (cond
       ((looking-at haskell-lexeme-id)
        (let ((beg (match-beginning 0))
              (end (match-end 0)))

          ;; check is MagicHash is present at the end of the token
          (goto-char end)
          (when (looking-at "#+")
            (setq end (match-end 0)))

          (set-match-data
           (list begin end
                 beg end)))
        'qid)
       ((looking-at haskell-lexeme-sym)
        (set-match-data
          (list begin (match-end 0)
                (match-beginning 0) (match-end 0)))
        'qsym)
       ((equal begin (point))
        (set-match-data match-data-old)
        nil)
       (t
        (set-match-data
         (list begin (point)
               nil nil))
        'qprefix)))))

(defun haskell-lexeme-looking-at-backtick ()
  "Non-nil when point is just in front of an identifier quoted with backticks.

When match is successful, match-data will contain:
  (match-text 1) - opening backtick
  (match-text 2) - whole qualified identifier
  (match-text 3) - unqualified part of identifier
  (match-text 4) - closing backtick"
  (let ((match-data-old (match-data t))
        first-backtick-start
        last-backtick-start
        qid-start
        id-start
        id-end
        result)
    (save-excursion
      (when (looking-at "`")
        (setq first-backtick-start (match-beginning 0))
        (goto-char (match-end 0))
        (forward-comment (buffer-size))
        (when (haskell-lexeme-looking-at-qidsym)
          (setq qid-start (match-beginning 0))
          (setq id-start (match-beginning 1))
          (setq id-end (match-end 1))
          (goto-char (match-end 0))
          (forward-comment (buffer-size))
          (when (looking-at "`")
            (setq last-backtick-start (match-beginning 0))
            (set-match-data
             (list
              first-backtick-start (1+ last-backtick-start)
              first-backtick-start (1+ first-backtick-start)
              qid-start id-end
              id-start id-end
              last-backtick-start (1+ last-backtick-start)))
            (setq result t)))))
    (unless result
      (set-match-data match-data-old))
    result))

(defconst haskell-lexeme-qid
  (rx-to-string `(: (regexp "'*")
                    (regexp ,haskell-lexeme-modid-opt-prefix)
                    (group (regexp ,haskell-lexeme-id))))
  "Regexp matching a valid qualified identifier.

Note that (match-string 1) returns the unqualified part.")

(defconst haskell-lexeme-qsym
  (rx-to-string `(: (regexp "'*")
                    (regexp ,haskell-lexeme-modid-opt-prefix)
                    (group (regexp ,haskell-lexeme-id))))
  "Regexp matching a valid qualified symbol.

Note that (match-string 1) returns the unqualified part.")

(defconst haskell-lexeme-number
  (rx (| (: (regexp "[0-9]+\\.[0-9]+") (opt (regexp "[eE][-+]?[0-9]+")))
         (regexp "[0-9]+[eE][-+]?[0-9]+")
         (regexp "0[xX][0-9a-fA-F]+")
         (regexp "0[oO][0-7]+")
         (regexp "[0-9]+")))
  "Regexp matching a floating point, decimal, octal or hexadecimal number.

Note that negative sign char is not part of a number.")

(defconst haskell-lexeme-char-literal-inside
  (rx (| (not (any "\n'\\"))
         (: "\\"
            (| "a" "b" "f" "n" "r" "t" "v" "\\" "\"" "'"
               "NUL" "SOH" "STX" "ETX" "EOT" "ENQ" "ACK"
               "BEL" "BS" "HT" "LF" "VT" "FF" "CR" "SO" "SI" "DLE"
               "DC1" "DC2" "DC3" "DC4" "NAK" "SYN" "ETB" "CAN"
               "EM" "SUB" "ESC" "FS" "GS" "RS" "US" "SP" "DEL"
               (regexp "[0-9]+")
               (: "x" (regexp "[0-9a-fA-F]+"))
               (: "o" (regexp "[0-7]+"))
               (: "^" (regexp "[]A-Z@^_\\[]"))))))
  "Regexp matching an inside of a character literal.

Note that `haskell-lexeme-char-literal-inside' matches strictly
only escape sequences defined in Haskell Report.")

(defconst haskell-lexeme--char-literal-rx
  (rx-to-string `(: (group "'")
                    (| (: (group (regexp "[[:alpha:]_:([]")) (group "'")) ; exactly one char
                       (: (group (| (regexp "\\\\[^\n][^'\n]*") ; allow quote just after first backslash
                                    (regexp "[^[:alpha:]_:(['\n][^'\n]*")))
                          (| (group "'") "\n" (regexp "\\'"))))))
  "Regexp matching a character literal lookalike.

Note that `haskell-lexeme--char-literal-rx' matches more than
Haskell Report specifies because we want to support also code
under edit.

Character literals end with a quote or a newline or end of
buffer.

Regexp has subgroup expressions:
 (match-text 1) matches the opening quote.
 (match-text 2) matches the inside of the character literal.
 (match-text 3) matches the closing quote or an empty string
                at the end of line or the end buffer.")

(defun haskell-lexeme-looking-at-char-literal ()
  "Non-nil when point is at a char literal lookalike.

Note that this function matches more than Haskell Report
specifies because we want to support also code under edit.

Char literals end with a quote or an unescaped newline or end
of buffer.

After successful match:
 (match-text 1) matches the opening quote.
 (match-text 2) matches the inside of the char literla.
 (match-text 3) matches the closing quote, or a closing
                newline or is nil when at the end of the buffer."
  (when (looking-at haskell-lexeme--char-literal-rx)
    (set-match-data
     (list (match-beginning 0) (match-end 0)
           (match-beginning 1) (match-end 1)
           (or (match-beginning 2) (match-beginning 4)) (or (match-end 2) (match-end 4))
           (or (match-beginning 3) (match-beginning 5)) (or (match-end 3) (match-end 5))))
    t))

(defconst haskell-lexeme-string-literal-inside-item
  (rx (| (not (any "\n\"\\"))
         (: "\\"
            (| "a" "b" "f" "n" "r" "t" "v" "\\" "\"" "'" "&"
               "NUL" "SOH" "STX" "ETX" "EOT" "ENQ" "ACK"
               "BEL" "BS" "HT" "LF" "VT" "FF" "CR" "SO" "SI" "DLE"
               "DC1" "DC2" "DC3" "DC4" "NAK" "SYN" "ETB" "CAN"
               "EM" "SUB" "ESC" "FS" "GS" "RS" "US" "SP" "DEL"
               (regexp "[0-9]+")
               (: "x" (regexp "[0-9a-fA-F]+"))
               (: "o" (regexp "[0-7]+"))
               (: "^" (regexp "[]A-Z@^_\\[]"))
               (regexp "[ \t\n\r\v\f]*\\\\")))))
  "Regexp matching an item that is a single character or a single
escape sequence inside of a string literal.

Note that `haskell-lexeme-string-literal-inside-item' matches
strictly only escape sequences defined in Haskell Report.")

(defconst haskell-lexeme-string-literal
  (rx (: (group "\"")
         (group (* (| (regexp "\\\\[ \t\n\r\v\f]*\\\\")
                      (regexp "\\\\[ \t\n\r\v\f]+")
                      (regexp "\\\\[^ \t\n\r\v\f]")
                      (* (regexp "[^\"\n\\]")))))
         (group (| "\"" (regexp "$") (regexp "\\\\?\\'")
                   ))))
  "Regexp matching a string literal lookalike.

Note that `haskell-lexeme-string-literal' matches more than
Haskell Report specifies because we want to support also code
under edit.

String literals end with double quote or unescaped newline or end
of buffer.

Regexp has subgroup expressions:
 (match-text 1) matches the opening double quote.
 (match-text 2) matches the inside of the string.
 (match-text 3) matches the closing double quote or an empty string
                at the end of line or the end buffer.")

(defun haskell-lexeme-looking-at-string-literal ()
  "Non-nil when point is at a string literal lookalike.

Note that this function matches more than Haskell Report
specifies because we want to support also code under edit.

String literals end with double quote or unescaped newline or end
of buffer.

After successful match:
 (match-text 1) matches the opening doublequote.
 (match-text 2) matches the inside of the string.
 (match-text 3) matches the closing quote, or a closing
                newline or is nil when at the end of the buffer."
  (when (looking-at "\"")
    (save-excursion
      (let ((begin (point)))
        (goto-char (match-end 0))
        (let (finish)
          (while (and (not finish)
                      (re-search-forward "[\"\n\\]" nil 'goto-eob))
            (cond
             ((equal (match-string 0) "\\")
              (if (looking-at "[ \t\n\r\v\f]+\\\\?")
                  (goto-char (match-end 0))
                (goto-char (1+ (point)))))

             ((equal (match-string 0) "\"")
              (set-match-data
               (list begin (match-end 0)
                     begin (1+ begin)
                     (1+ begin) (match-beginning 0)
                     (match-beginning 0) (match-end 0)))
              (setq finish t))

             ((equal (match-string 0) "\n")
              (set-match-data
               (list begin (match-beginning 0)
                     begin (1+ begin)
                     (1+ begin) (match-beginning 0)
                     nil nil))
              (setq finish t))))
          (unless finish
            ;; string closed by end of buffer
            (set-match-data
             (list begin (point)
                   begin (1+ begin)
                   (1+ begin) (point)
                   nil nil))))))
    ;; there was a match
    t))

(defun haskell-lexeme-looking-at-quasi-quote-literal ()
  "Non-nil when point is just in front of Template Haskell
quaisquote literal.

Quasi quotes start with \\='[xxx|\\=' or \\='[$xxx|\\=' sequence and end with
  \\='|]\\='. The \\='xxx\\=' is a quoter name. There is no escaping mechanism
provided for the ending sequence.

Regexp has subgroup expressions:
 (match-text 1) matches the quoter name (without $ sign if present).
 (match-text 2) matches the opening vertical bar.
 (match-text 3) matches the inside of the quoted string.
 (match-text 4) matches the closing vertical bar
                or nil if at the end of the buffer.

Note that this function excludes \\='e\\=', \\='t\\=', \\='d'\\=, \\='p\\='
as quoter names according to Template Haskell specification."
  (let ((match-data-old (match-data t)))
    (if (and
         (looking-at (rx-to-string `(: "[" (optional "$")
                                       (regexp ,haskell-lexeme-modid-opt-prefix)
                                       (group (regexp ,haskell-lexeme-id))
                                       (group "|"))))
         (equal (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
                'varid)
         (not (member (match-string 1) '("e" "t" "d" "p"))))
      (save-excursion
        ;; note that quasi quote syntax does not have any escaping
        ;; mechanism and if not closed it will span to the end of buffer
        (goto-char (match-end 0))
        (let ((match-data (match-data t))
              (match-data-2 (and (re-search-forward "|]" nil t)
                                 (match-data t))))
          (if match-data-2
              (set-match-data
               (list
                (nth 0 match-data) (nth 1 match-data-2)          ;; whole match
                (nth 2 match-data) (nth 3 match-data)            ;; quoter name
                (nth 4 match-data) (nth 5 match-data)            ;; opening bar
                (nth 5 match-data) (nth 0 match-data-2)          ;; inner string
                (nth 0 match-data-2) (1+ (nth 0 match-data-2)))) ;; closing bar

            (set-match-data
             (list
              (nth 0 match-data) (point-max)                   ;; whole match
              (nth 2 match-data) (nth 3 match-data)            ;; quoter name
              (nth 4 match-data) (nth 5 match-data)            ;; opening bar
              (nth 5 match-data) (point-max)                   ;; inner string
              nil nil))                                        ;; closing bar
            ))
        t)
      ;; restore old match data if not matched
      (set-match-data match-data-old)
      nil)))

(defun haskell-lexeme-classify-by-first-char (char)
  "Classify token by CHAR.

CHAR is a chararacter that is assumed to be the first character
of a token."
  (let ((category (get-char-code-property (or char ?\ ) 'general-category)))

    (cond
     ((or (member char '(?! ?# ?$ ?% ?& ?* ?+ ?. ?/ ?< ?= ?> ?? ?@ ?^ ?| ?~ ?\\ ?-))
          (and (> char 127)
               (member category '(Pc Pd Po Sm Sc Sk So))))
      'varsym)
     ((equal char ?:)
      'consym)
     ((equal char ?\')
      'char)
     ((equal char ?\")
      'string)
     ((member category '(Lu Lt))
      'conid)
     ((or (equal char ?_)
          (member category '(Ll Lo)))
      'varid)
     ((and (>= char ?0) (<= char ?9))
      'number)
     ((member char '(?\] ?\[ ?\( ?\) ?\{ ?\} ?\` ?\, ?\;))
      'special))))

(defun haskell-lexeme-looking-at-token (&rest flags)
  "Like `looking-at' but understands Haskell lexemes.

Moves point forward over whitespace.  Returns a symbol describing
type of Haskell token recognized.  Use `match-string',
`match-beginning' and `match-end' with argument 0 to query match
result.

Possible results are:
- \\='special: for chars [](){}`,;
- \\='comment: for single line comments
- \\='nested-comment: for multiline comments
- \\='qsymid: for qualified identifiers or symbols
- \\='string: for strings literals
- \\='char: for char literals
- \\='number: for decimal, float, hexadecimal and octal number literals
- \\='template-haskell-quote: for a string of apostrophes for template
   haskell
- \\='template-haskell-quasi-quote: for a string of apostrophes for template
   haskell

Note that for qualified symbols (match-string 1) returns the
unqualified identifier or symbol.  Further qualification for
symbol or identifier can be done with:

   (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))

See `haskell-lexeme-classify-by-first-char' for details."
  (while
      ;; Due to how unterminated strings terminate at newline, some
      ;; newlines have syntax set to generic string delimeter. We want
      ;; those to be treated as whitespace anyway
      (or
       (> (skip-syntax-forward "-") 0)
       (and (not (member 'newline flags))
            (> (skip-chars-forward "\n") 0))))
  (let
      ((case-fold-search nil)
       (point (point)))
    (or
     (and
      (equal (string-to-syntax "<")
             (get-char-property (point) 'syntax-table))
      (progn
        (set-match-data (list point (line-end-position)))
        'literate-comment))
     (and (looking-at "\n")
          'newline)
     (and (looking-at "{-")
          (save-excursion
            (forward-comment 1)
            (set-match-data (list point (point)))
            'nested-comment))
     (and (haskell-lexeme-looking-at-char-literal)
          'char)
     (and (haskell-lexeme-looking-at-string-literal)
          'string)
     (and (looking-at "[][(){}`,;]")
          (if (haskell-lexeme-looking-at-quasi-quote-literal)
              'template-haskell-quasi-quote
            'special))
     (and (haskell-lexeme-looking-at-qidsym)
          (if (save-match-data
                (string-match "\\`---*\\'" (match-string-no-properties 0)))
              (progn
                (set-match-data (list point (line-end-position)))
                'comment)
            'qsymid))
     (and (looking-at haskell-lexeme-number)
          'number)
     (and (looking-at "'+")
          'template-haskell-quote)
     (and (looking-at ".")
          'illegal))))

(provide 'haskell-lexeme)

;;; haskell-lexeme.el ends here