Add support for the Fennel programming language

This is a pretty straightforward language in the lisp family with a
small number of special forms. Since Fennel runs on the Lua runtime,
the list of builtins is the same as that of Lua, so it might be
possible to re-use the definition from the Lua lexer, but since I
don't know Python I couldn't figure out how that would work; maybe
someone else could add that.

3 files changed, 227 insertions, 1 deletions

diff --git a/pygments/lexers/_mapping.py b/pygments/lexers/_mapping.py
index b48ee1d1..6ed0852d 100644
--- a/pygments/lexers/_mapping.py
+++ b/pygments/lexers/_mapping.py
@@ -153,6 +153,7 @@ LEXERS = {
     'FancyLexer': ('pygments.lexers.ruby', 'Fancy', ('fancy', 'fy'), ('*.fy', '*.fancypack'), ('text/x-fancysrc',)),
     'FantomLexer': ('pygments.lexers.fantom', 'Fantom', ('fan',), ('*.fan',), ('application/x-fantom',)),
     'FelixLexer': ('pygments.lexers.felix', 'Felix', ('felix', 'flx'), ('*.flx', '*.flxh'), ('text/x-felix',)),
+    'FennelLexer': ('pygments.lexers.lisp', 'Fennel', (), ('*.fnl',), ()),
     'FishShellLexer': ('pygments.lexers.shell', 'Fish', ('fish', 'fishshell'), ('*.fish', '*.load'), ('application/x-fish',)),
     'FlatlineLexer': ('pygments.lexers.dsls', 'Flatline', ('flatline',), (), ('text/x-flatline',)),
     'ForthLexer': ('pygments.lexers.forth', 'Forth', ('forth',), ('*.frt', '*.fs'), ('application/x-forth',)),
diff --git a/pygments/lexers/lisp.py b/pygments/lexers/lisp.py
index e258c347..345dabfb 100644
--- a/pygments/lexers/lisp.py
+++ b/pygments/lexers/lisp.py
@@ -19,7 +19,7 @@ from pygments.lexers.python import PythonLexer
 
 __all__ = ['SchemeLexer', 'CommonLispLexer', 'HyLexer', 'RacketLexer',
            'NewLispLexer', 'EmacsLispLexer', 'ShenLexer', 'CPSALexer',
-           'XtlangLexer']
+           'XtlangLexer', 'FennelLexer']
 
 
 class SchemeLexer(RegexLexer):
@@ -2619,3 +2619,72 @@ class XtlangLexer(RegexLexer):
             include('scheme')
         ],
     }
+
+class FennelLexer(RegexLexer):
+    """A lexer for the Fennel programming language <https://fennel-lang.org>
+
+    Fennel compiles to Lua, so all the Lua builtins are recognized as well
+    as the special forms that are particular to the Fennel compiler.
+    """
+    name = 'Fennel'
+    aliases = ['fennel', 'fnl']
+    filenames = ['*.fnl']
+
+    # these two lists are taken from fennel-mode.el:
+    # https://gitlab.com/technomancy/fennel-mode
+    # this list is current as of Fennel version 0.1.0.
+    special_forms = (
+        u'require-macros', u'eval-compiler',
+        u'do', u'values', u'if', u'when', u'each', u'for', u'fn', u'lambda',
+        u'λ', u'set', u'global', u'var', u'local', u'let', u'tset', u'doto',
+        u'set-forcibly!', u'defn', u'partial', u'while', u'or', u'and', u'true',
+        u'false', u'nil', u'.', u'+', u'..', u'^', u'-', u'*', u'%', u'/', u'>',
+        u'<', u'>=', u'<=', u'=', u'~=', u'#', u'...', u':', u'->', u'->>',
+    )
+
+    # Might be nicer to use the list from _lua_builtins.py but it's unclear how?
+    builtins = (
+        u'_G', u'_VERSION', u'arg', u'assert', u'bit32', u'collectgarbage',
+        u'coroutine', u'debug', u'dofile', u'error', u'getfenv',
+        u'getmetatable', u'io', u'ipairs', u'load', u'loadfile', u'loadstring',
+        u'math', u'next', u'os', u'package', u'pairs', u'pcall', u'print',
+        u'rawequal', u'rawget', u'rawlen', u'rawset', u'require', u'select',
+        u'setfenv', u'setmetatable', u'string', u'table', u'tonumber',
+        u'tostring', u'type', u'unpack', u'xpcall'
+    )
+
+    # based on the scheme definition, but disallowing leading digits and commas
+    valid_name = r'[a-zA-Z_!$%&*+/:<=>?@^~|-][\w!$%&*+/:<=>?@^~|\.-]*'
+
+    tokens = {
+        'root': [
+            # the only comment form is a semicolon; goes to the end of the line
+            (r';.*$', Comment.Single),
+
+            (r'[,\s]+', Text),
+            (r'-?\d+\.\d+', Number.Float),
+            (r'-?\d+', Number.Integer),
+
+            (r'"(\\\\|\\"|[^"])*"', String),
+            (r"'(\\\\|\\'|[^'])*'", String),
+
+            # these are technically strings, but it's worth visually
+            # distinguishing them because their intent is different
+            # from regular strings.
+            (r':' + valid_name, String.Symbol),
+
+            # special forms are keywords
+            (words(special_forms, suffix=' '), Keyword),
+            # lua standard library are builtins
+            (words(builtins, suffix=' '), Name.Builtin),
+            # special-case the vararg symbol
+            (r'\.\.\.', Name.Variable),
+            # regular identifiers
+            (valid_name, Name.Variable),
+
+            # all your normal paired delimiters for your programming enjoyment
+            (r'(\(|\))', Punctuation),
+            (r'(\[|\])', Punctuation),
+            (r'(\{|\})', Punctuation),
+        ]
+    }
diff --git a/tests/examplefiles/fennelview.fnl b/tests/examplefiles/fennelview.fnl
new file mode 100644
index 00000000..fd0fc648
--- /dev/null
+++ b/tests/examplefiles/fennelview.fnl
@@ -0,0 +1,156 @@
+;; A pretty-printer that outputs tables in Fennel syntax.
+;; Loosely based on inspect.lua: http://github.com/kikito/inspect.lua
+
+(local quote (fn [str] (.. '"' (: str :gsub '"' '\\"') '"')))
+
+(local short-control-char-escapes
+       {"\a" "\\a" "\b" "\\b" "\f" "\\f" "\n" "\\n"
+        "\r" "\\r" "\t" "\\t" "\v" "\\v"})
+
+(local long-control-char-esapes
+       (let [long {}]
+         (for [i 0 31]
+           (let [ch (string.char i)]
+             (when (not (. short-control-char-escapes ch))
+               (tset short-control-char-escapes ch (.. "\\" i))
+               (tset long ch (: "\\%03d" :format i)))))
+         long))
+
+(fn escape [str]
+  (let [str (: str :gsub "\\" "\\\\")
+        str (: str :gsub "(%c)%f[0-9]" long-control-char-esapes)]
+    (: str :gsub "%c" short-control-char-escapes)))
+
+(fn sequence-key? [k len]
+  (and (= (type k) "number")
+       (<= 1 k)
+       (<= k len)
+       (= (math.floor k) k)))
+
+(local type-order {:number 1 :boolean 2 :string 3 :table 4
+                   :function 5 :userdata 6 :thread 7})
+
+(fn sort-keys [a b]
+  (let [ta (type a) tb (type b)]
+    (if (and (= ta tb) (~= ta "boolean")
+             (or (= ta "string") (= ta "number")))
+        (< a b)
+        (let [dta (. type-order a)
+              dtb (. type-order b)]
+          (if (and dta dtb)
+              (< dta dtb)
+              dta true
+              dtb false
+              :else (< ta tb))))))
+
+(fn get-sequence-length [t]
+  (var len 1)
+  (each [i (ipairs t)] (set len i))
+  len)
+
+(fn get-nonsequential-keys [t]
+  (let [keys {}
+        sequence-length (get-sequence-length t)]
+    (each [k (pairs t)]
+      (when (not (sequence-key? k sequence-length))
+        (table.insert keys k)))
+    (table.sort keys sort-keys)
+    (values keys sequence-length)))
+
+(fn count-table-appearances [t appearances]
+  (if (= (type t) "table")
+      (when (not (. appearances t))
+        (tset appearances t 1)
+        (each [k v (pairs t)]
+          (count-table-appearances k appearances)
+          (count-table-appearances v appearances)))
+      (when (and t (= t t)) ; no nans please
+        (tset appearances t (+ (or (. appearances t) 0) 1))))
+  appearances)
+
+
+
+(var put-value nil) ; mutual recursion going on; defined below
+
+(fn puts [self ...]
+  (each [_ v (ipairs [...])]
+    (table.insert self.buffer v)))
+
+(fn tabify [self] (puts self "\n" (: self.indent :rep self.level)))
+
+(fn already-visited? [self v] (~= (. self.ids v) nil))
+
+(fn get-id [self v]
+  (var id (. self.ids v))
+  (when (not id)
+    (let [tv (type v)]
+      (set id (+ (or (. self.max-ids tv) 0) 1))
+      (tset self.max-ids tv id)
+      (tset self.ids v id)))
+  (tostring id))
+
+(fn put-sequential-table [self t length]
+  (puts self "[")
+  (set self.level (+ self.level 1))
+  (for [i 1 length]
+    (puts self " ")
+    (put-value self (. t i)))
+  (set self.level (- self.level 1))
+  (puts self " ]"))
+
+(fn put-key [self k]
+  (if (and (= (type k) "string")
+           (: k :find "^[-%w?\\^_`!#$%&*+./@~:|<=>]+$"))
+      (puts self ":" k)
+      (put-value self k)))
+
+(fn put-kv-table [self t]
+  (puts self "{")
+  (set self.level (+ self.level 1))
+  (each [k v (pairs t)]
+    (tabify self)
+    (put-key self k)
+    (puts self " ")
+    (put-value self v))
+  (set self.level (- self.level 1))
+  (tabify self)
+  (puts self "}"))
+
+(fn put-table [self t]
+  (if (already-visited? self t)
+      (puts self "#<table " (get-id self t) ">")
+      (>= self.level self.depth)
+      (puts self "{...}")
+      :else
+      (let [(non-seq-keys length) (get-nonsequential-keys t)
+            id (get-id self t)]
+        (if (> (. self.appearances t) 1)
+            (puts self "#<" id ">")
+            (and (= (# non-seq-keys) 0) (= (# t) 0))
+            (puts self "{}")
+            (= (# non-seq-keys) 0)
+            (put-sequential-table self t length)
+            :else
+            (put-kv-table self t)))))
+
+(set put-value (fn [self v]
+                 (let [tv (type v)]
+                   (if (= tv "string")
+                       (puts self (quote (escape v)))
+                       (or (= tv "number") (= tv "boolean") (= tv "nil"))
+                       (puts self (tostring v))
+                       (= tv "table")
+                       (put-table self v)
+                       :else
+                       (puts self "#<" (tostring v) ">")))))
+
+
+
+(fn fennelview [root options]
+  (let [options (or options {})
+        inspector {:appearances (count-table-appearances root {})
+                   :depth (or options.depth 128)
+                   :level 0 :buffer {} :ids {} :max-ids {}
+                   :indent (or options.indent "  ")}]
+    (put-value inspector root)
+    (table.concat inspector.buffer)))