textmate-bjolang/src/core.bjo

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.

;; textmate-bjolang/src/core.bjo — the module (textmate-bjolang core).
;;
;; Syntax highlighting with VS Code's grammars and themes. TextMateSharp runs
;; them; what comes out is Bjolang values — lines of scoped tokens, lines of
;; styled spans — and (text xml) nodes for a page:
;;
;;     (def hl (highlighter #:theme 'dark-plus))
;;     (match (find-language hl "c#")
;;       ((Some cs) (highlight->node cs "var x = 1;"))
;;       (None ...))
;;     ;; => (pre (@ (class "tm") (style "color:#D4D4D4;background-color:#1E1E1E"))
;;     ;;         (code (@ (class "language-csharp"))
;;     ;;               (span (@ (style "color:#569CD6")) "var") " " ...))
;;
;; A node is coloured one of two ways. 'inline writes the theme's colours into
;; style attributes, which works wherever HTML does. 'classes writes class
;; names taken from the grammar's scopes, which need no theme at all, and
;; highlighter-css turns a theme into a stylesheet for them.
;;
;; Bjolang's own grammar is in grammars/bjolang, beside src/, and every
;; highlighter reads it.
;;
;; Open:
;; - (text xml write) writes an empty element as <x />, which HTML reads as an
;;   open tag. Two things here can be empty: the code element of empty code,
;;   and, under #:lines?, the last line of code that ends in a blank line.
;; - A class is the innermost scope the vocabulary knows. A theme rule that
;;   looks at the scopes around a token ("meta.embedded string"), or colours a
;;   meta. scope, has no class to go on, so highlighter-css's stylesheet is
;;   close to the theme, not it: in VS Code's six best-known themes, about
;;   one character in twenty of C#, JavaScript and Bjolang differs.
;; - TextMateSharp takes a theme's own rules before the ones it includes,
;;   however specific: Light+ colours `this` as a variable, where VS Code
;;   gives it the included theme's blue. Both styles here follow TextMateSharp.
;; - The Bjolang grammar is found beside the DLL. The manifest declares
;;   grammars/ as a resource, so bjo publish copies it to the same place
;;   relative to the module; a program copied by hand without it has no
;;   bjolang.
;; - A highlighter tokenizes one line at a time, under a lock: TextMateSharp
;;   compiles a grammar's rules as it meets them and says nothing about
;;   threads. Parallel work wants a highlighter per thread.
;; - A line that takes longer than the time limit is cut there, and the rest
;;   of it is one token in the scope reached.
;; - Only VS Code's own themes. A theme file of one's own could be read with
;;   TextMateSharp's ThemeReader and Registry.SetTheme.

(export
  TmTheme TmStyleMode TmHighlighter TmLanguage TmToken TmStyle TmSpan
  highlighter highlighter-foreground highlighter-background highlighter-css
  find-language language-id language-names
  tokenize highlight token-classes
  highlight->nodes highlight->node code->node)

(import (std prelude))
(import (only (std hashset) list->hashset hashset-contains?))
(import (text xml))

;; ---------------------------------------------------------------------------
;; TextMateSharp
;; ---------------------------------------------------------------------------

(import/class
  (Object           (: System.Object))
  (ThemeName        (: TextMateSharp.Grammars.ThemeName))
  (RegistryOptions  (: TextMateSharp.Grammars.RegistryOptions (-> ThemeName RegistryOptions)))
  (IRegistryOptions (: TextMateSharp.Registry.IRegistryOptions))
  (Registry         (: TextMateSharp.Registry.Registry (-> IRegistryOptions Registry)))
  (ClrLanguage      (: TextMateSharp.Grammars.Language))
  (Grammar          (: TextMateSharp.Grammars.IGrammar))
  (StateStack       (: TextMateSharp.Grammars.IStateStack))
  (LineText         (: TextMateSharp.Grammars.LineText (-> string LineText)))
  (ScopedResult     (: TextMateSharp.Grammars.ITokenizeLineResult))
  (EncodedResult    (: TextMateSharp.Grammars.ITokenizeLineResult2))
  (Token            (: TextMateSharp.Grammars.IToken))
  (Theme            (: TextMateSharp.Themes.Theme))
  (ThemeRule        (: TextMateSharp.Themes.ThemeTrieElementRule))
  (FontStyle        (: TextMateSharp.Themes.FontStyle))
  (TimeSpan         (: System.TimeSpan))
  (ClrLock          (: System.Threading.Lock (-> ClrLock)))
  ((GuiColours %k %v) (: System.Collections.ObjectModel.ReadOnlyDictionary))
  ((KeyValuePair %k %v) (: System.Collections.Generic.KeyValuePair))
  (ArgumentException (: System.ArgumentException (-> string ArgumentException))))

(import/extern
  ;; --- grammars and languages ---
  (clr-load-package   (: TextMateSharp.Grammars.RegistryOptions.LoadFromLocalFile
                         (-> RegistryOptions string string bool void)))
  (clr-languages      (: TextMateSharp.Grammars.RegistryOptions.GetAvailableLanguages
                         (-> RegistryOptions (System.Collections.Generic.List ClrLanguage))))
  (clr-language-id    (: TextMateSharp.Grammars.Language.Id (-> ClrLanguage string) #:get))
  (clr-language-aliases (: TextMateSharp.Grammars.Language.Aliases
                           (-> ClrLanguage (System.Collections.Generic.List string)) #:get))
  (clr-language-extensions (: TextMateSharp.Grammars.Language.Extensions
                              (-> ClrLanguage (System.Collections.Generic.List string)) #:get))
  (clr-scope-of       (: TextMateSharp.Grammars.RegistryOptions.GetScopeByLanguageId
                         (-> RegistryOptions string string)))
  (clr-load-grammar   (: TextMateSharp.Registry.Registry.LoadGrammar (-> Registry string Grammar)))
  (clr-registry-theme (: TextMateSharp.Registry.Registry.GetTheme (-> Registry Theme)))

  ;; --- tokenizing ---
  (clr-initial-state  (: TextMateSharp.Grammars.StateStack.NULL #:get))
  (clr-tokenize       (: TextMateSharp.Grammars.IGrammar.TokenizeLine
                         (-> Grammar LineText StateStack TimeSpan ScopedResult)))
  (clr-tokenize-encoded (: TextMateSharp.Grammars.IGrammar.TokenizeLine2
                           (-> Grammar LineText StateStack TimeSpan EncodedResult)))
  (clr-scoped-tokens  (: TextMateSharp.Grammars.ITokenizeLineResult.Tokens (-> ScopedResult (Array Token)) #:get))
  (clr-scoped-state   (: TextMateSharp.Grammars.ITokenizeLineResult.RuleStack (-> ScopedResult StateStack) #:get))
  (clr-encoded-tokens (: TextMateSharp.Grammars.ITokenizeLineResult2.Tokens (-> EncodedResult (Array int)) #:get))
  (clr-encoded-state  (: TextMateSharp.Grammars.ITokenizeLineResult2.RuleStack (-> EncodedResult StateStack) #:get))
  (clr-token-start    (: TextMateSharp.Grammars.IToken.StartIndex (-> Token int) #:get))
  (clr-token-scopes   (: TextMateSharp.Grammars.IToken.Scopes
                         (-> Token (System.Collections.Generic.List string)) #:get))
  (clr-meta-foreground (: TextMateSharp.Internal.Grammars.EncodedTokenAttributes.GetForeground (-> int int)))
  (clr-meta-background (: TextMateSharp.Internal.Grammars.EncodedTokenAttributes.GetBackground (-> int int)))
  (clr-meta-font-style (: TextMateSharp.Internal.Grammars.EncodedTokenAttributes.GetFontStyle (-> int FontStyle)))

  ;; --- the theme ---
  (clr-theme-color    (: TextMateSharp.Themes.Theme.GetColor (-> Theme int string)))
  (clr-theme-colours  (: TextMateSharp.Themes.Theme.GetColorMap
                         (-> Theme (System.Collections.Generic.ICollection string))))
  (clr-theme-gui      (: TextMateSharp.Themes.Theme.GetGuiColorDictionary (-> Theme (GuiColours string string))))
  (clr-theme-match    (: TextMateSharp.Themes.Theme.Match
                         (-> Theme (System.Collections.Generic.IList string)
                             (System.Collections.Generic.List ThemeRule))))
  (clr-rule-foreground (: TextMateSharp.Themes.ThemeTrieElementRule.foreground (-> ThemeRule int) #:get))
  (clr-rule-background (: TextMateSharp.Themes.ThemeTrieElementRule.background (-> ThemeRule int) #:get))
  (clr-rule-font-style (: TextMateSharp.Themes.ThemeTrieElementRule.fontStyle (-> ThemeRule FontStyle) #:get))
  (clr-rule-parents   (: TextMateSharp.Themes.ThemeTrieElementRule.parentScopes
                         (-> ThemeRule (System.Collections.Generic.List string)) #:get))
  (clr-rule-depth     (: TextMateSharp.Themes.ThemeTrieElementRule.scopeDepth (-> ThemeRule int) #:get))
  (clr-has-flag       (: System.Enum.HasFlag (-> System.Enum System.Enum bool)))

  ;; --- the rest ---
  (clr-substring      (: System.String.Substring (-> string int int string)))
  (clr-milliseconds   (: System.TimeSpan.FromMilliseconds (-> double TimeSpan)))
  (clr-lock-enter     (: System.Threading.Lock.Enter (-> ClrLock void)))
  (clr-lock-exit      (: System.Threading.Lock.Exit (-> ClrLock void)))
  (clr-full-path      (: System.IO.Path.GetFullPath (-> string string)))
  (clr-combine        (: System.IO.Path.Combine (-> string string string)))
  (clr-directory-of   (: System.IO.Path.GetDirectoryName (-> string string)))
  (clr-file-exists?   (: System.IO.File.Exists (-> string bool)))
  (clr-directory-exists? (: System.IO.Directory.Exists (-> string bool)))
  (null-or-empty?     (: System.String.IsNullOrEmpty (-> string bool))))

;; An ArgumentException, which is what a mistake in the arguments raises.
(: argument-error (-> string %a))
(defun (argument-error message)
  (raise (cast Exception (ArgumentException. (str "(textmate-bjolang core): " message)))))

;; ---------------------------------------------------------------------------
;; Themes and styles
;; ---------------------------------------------------------------------------

;; VS Code's themes, the ones TextMateSharp carries: #:theme 'dark-plus.
(type (: TmTheme (Union (: ThemeDarkPlus #:tag dark-plus)
                        (: ThemeLightPlus #:tag light-plus)
                        (: ThemeDark #:tag dark)
                        (: ThemeLight #:tag light)
                        (: ThemeMonokai #:tag monokai)
                        (: ThemeDimmedMonokai #:tag dimmed-monokai)
                        (: ThemeOneDark #:tag one-dark)
                        (: ThemeAtomOneDark #:tag atom-one-dark)
                        (: ThemeAtomOneLight #:tag atom-one-light)
                        (: ThemeDracula #:tag dracula)
                        (: ThemeSolarizedDark #:tag solarized-dark)
                        (: ThemeSolarizedLight #:tag solarized-light)
                        (: ThemeQuietLight #:tag quiet-light)
                        (: ThemeKimbieDark #:tag kimbie-dark)
                        (: ThemeTomorrowNightBlue #:tag tomorrow-night-blue)
                        (: ThemeAbyss #:tag abyss)
                        (: ThemeRed #:tag red)
                        (: ThemeHighContrastDark #:tag high-contrast-dark)
                        (: ThemeHighContrastLight #:tag high-contrast-light)
                        (: ThemeVisualStudioDark #:tag visual-studio-dark)
                        (: ThemeVisualStudioLight #:tag visual-studio-light))))

;; How a node is coloured: #:style 'inline or #:style 'classes.
(type (: TmStyleMode (Union (: StyleInline #:tag inline)
                            (: StyleClasses #:tag classes))))

;; How a piece of text looks. None is the theme's own colour, which the pre
;; around the code already has.
(type/derive (Eq)
  (: TmStyle (Record (: color (Option string))
                     (: background (Option string))
                     (: bold bool)
                     (: italic bool)
                     (: underline bool)
                     (: strikethrough bool))))

;; A token's text and its scopes, the outermost first: source.cs, then
;; comment.line.double-slash.cs, then punctuation.definition.comment.cs.
(type (: TmToken (Record (: text string) (: scopes (Vec string)))))

;; A piece of text and how it looks.
(type (: TmSpan (Record (: text string) (: style TmStyle))))

(: plain-style TmStyle)
(def plain-style
  (TmStyle (color None) (background None) (bold #f) (italic #f) (underline #f) (strikethrough #f)))

(: theme-name (-> TmTheme ThemeName))
(defun (theme-name t)
  (match t
    (ThemeDarkPlus ThemeName.DarkPlus)
    (ThemeLightPlus ThemeName.LightPlus)
    (ThemeDark ThemeName.Dark)
    (ThemeLight ThemeName.Light)
    (ThemeMonokai ThemeName.Monokai)
    (ThemeDimmedMonokai ThemeName.DimmedMonokai)
    (ThemeOneDark ThemeName.OneDark)
    (ThemeAtomOneDark ThemeName.AtomOneDark)
    (ThemeAtomOneLight ThemeName.AtomOneLight)
    (ThemeDracula ThemeName.Dracula)
    (ThemeSolarizedDark ThemeName.SolarizedDark)
    (ThemeSolarizedLight ThemeName.SolarizedLight)
    (ThemeQuietLight ThemeName.QuietLight)
    (ThemeKimbieDark ThemeName.KimbieDark)
    (ThemeTomorrowNightBlue ThemeName.TomorrowNightBlue)
    ;; TextMateSharp spells it so.
    (ThemeAbyss ThemeName.Abbys)
    (ThemeRed ThemeName.Red)
    (ThemeHighContrastDark ThemeName.HighContrastDark)
    (ThemeHighContrastLight ThemeName.HighContrastLight)
    (ThemeVisualStudioDark ThemeName.VisualStudioDark)
    (ThemeVisualStudioLight ThemeName.VisualStudioLight)))

;; ---------------------------------------------------------------------------
;; Highlighters and languages
;; ---------------------------------------------------------------------------

;; A language as it may be asked for: its id and aliases, and the extensions
;; of its files, all in lower case.
(type (: LanguageEntry (Record (: id string) (: names (Vec string)) (: extensions (Vec string)))))

;; The grammars, one theme, and what is worked out from the theme once: its
;; colours by id (id 0 is none) and the editor's own two. The lock is held
;; while TextMateSharp works; see the head of the file.
(type (: TmHighlighter #:opaque
         (Record (: options RegistryOptions)
                 (: registry Registry)
                 (: theme Theme)
                 (: colours (Vec string))
                 (: foreground string)
                 (: background string)
                 (: languages (Vec LanguageEntry))
                 (: lock ClrLock)
                 (: limit TimeSpan))))

;; A grammar, which belongs to the highlighter that loaded it: TextMateSharp
;; colours tokens by that highlighter's theme as it reads them.
(type (: TmLanguage #:opaque
         (Record (: id string) (: grammar Grammar) (: highlighter TmHighlighter))))

(: with-lock (-> TmHighlighter (-> %a) %a))
(defun (with-lock hl thunk)
  (def lock (record-ref hl lock))
  (clr-lock-enter lock)
  (try (thunk) #:finally (clr-lock-exit lock)))

;; This module's DLL is src/core.dll in the package, and the Bjolang grammar
;; is beside src/. The DLL is found from a value of a type declared here,
;; whose class it holds. Nothing when the DLL has no file.
(: bundled-package (-> (Option string)))
(defun (bundled-package)
  (def dll (.-Location (.-Assembly (.GetType (cast Object plain-style)))))
  (if (null-or-empty? dll)
      None
      (Some (clr-full-path (clr-combine (clr-directory-of dll) "../grammars/bjolang/package.json")))))

;; Adds the grammars of a VS Code extension: its package.json, or the
;; directory it is in. Keyed by the file's path, because TextMateSharp skips a
;; key it has already, and with overwrite on it throws.
(: add-package! (-> RegistryOptions string void))
(defun (add-package! options path)
  (def file (clr-full-path (if (clr-directory-exists? path) (clr-combine path "package.json") path)))
  (unless (clr-file-exists? file)
    (argument-error (str "there is no grammar package at " file
                         ": give a VS Code extension's package.json, or the directory it is in.")))
  (clr-load-package options file file #f))

;; A .NET list of strings, which TextMateSharp leaves null for none, in lower
;; case.
(: lower-strings (-> (System.Collections.Generic.List string) (Vec string)))
(defun (lower-strings xs)
  (match (cast Object xs)
    ((:is System.Collections.IEnumerable e)
     (loop (:for s (cast (Seq string) e))
           (:acc (vecing (string-downcase s)))))
    (_ (vec-empty))))

(: language-table (-> RegistryOptions (Vec LanguageEntry)))
(defun (language-table options)
  (loop (:for l (cast (Seq ClrLanguage) (clr-languages options)))
        (:acc (vecing (LanguageEntry (id (clr-language-id l))
                                     (names (vec-insert (lower-strings (clr-language-aliases l)) 0
                                                        (string-downcase (clr-language-id l))))
                                     (extensions (lower-strings (clr-language-extensions l))))))))

;; The theme's colours by id. TextMateSharp looks one up by walking them all,
;; and a line of code asks for several.
(: colour-table (-> Theme (Vec string)))
(defun (colour-table theme)
  (def count (.-Count (clr-theme-colours theme)))
  (loop (:for id (range 0 (+ count 1)))
        (:acc (vecing (if (= id 0) "" (let ((c (clr-theme-color theme id))) (if (null-or-empty? c) "" c)))))))

(: gui-colour (-> Theme string (Option string)))
(defun (gui-colour theme key)
  (loop (:for kv (cast (Seq (KeyValuePair string string)) (clr-theme-gui theme)))
        (:acc found (folding None (if (= (.-Key kv) key) (Some (.-Value kv)) found)))))

(: colour-at (-> (Vec string) int string))
(defun (colour-at colours id)
  (if (< id (vec-length colours)) (vec-ref colours id) ""))

;; A highlighter: VS Code's grammars, Bjolang's, the ones in #:grammars — each
;; a VS Code extension's package.json or its directory — and one theme. Built
;; once and used for everything, since reading a grammar is the slow part.
;; #:line-time-limit is how long one line may take, in milliseconds.
(: highlighter (-> (#:theme TmTheme) (#:grammars (List string)) (#:line-time-limit int) TmHighlighter))
(defun (highlighter #:theme 'dark-plus #:grammars Nil #:line-time-limit 500)
  (def options (RegistryOptions. (theme-name theme)))
  (match (bundled-package)
    ((Some file) (when (clr-file-exists? file) (clr-load-package options file file #f)))
    (None unit))
  (list-for-each (fun (path) (add-package! options path)) grammars)
  (def registry (Registry. options))
  (def t (clr-registry-theme registry))
  (def colours (colour-table t))
  (TmHighlighter (options options)
                 (registry registry)
                 (theme t)
                 (colours colours)
                 (foreground (option-value (gui-colour t "editor.foreground") (colour-at colours 1)))
                 (background (option-value (gui-colour t "editor.background") (colour-at colours 2)))
                 (languages (language-table options))
                 (lock (ClrLock.))
                 (limit (clr-milliseconds (cast System.Double line-time-limit)))))

;; The colour of text the theme says nothing about.
(: highlighter-foreground (-> TmHighlighter string))
(defun (highlighter-foreground hl) (record-ref hl foreground))

(: highlighter-background (-> TmHighlighter string))
(defun (highlighter-background hl) (record-ref hl background))

;; Every language's id.
(: language-names (-> TmHighlighter (Vec string)))
(defun (language-names hl) (vec-map (fun (e) (record-ref e id)) (record-ref hl languages)))

(: language-id (-> TmLanguage string))
(defun (language-id lang) (record-ref lang id))

(: first-entry (-> (-> LanguageEntry bool) (Vec LanguageEntry) (Option LanguageEntry)))
(defun (first-entry wanted? entries)
  (loop (:for e entries)
        (:acc found (folding None (if (and (none? found) (wanted? e)) (Some e) found)))))

(: load-language (-> TmHighlighter string (Option TmLanguage)))
(defun (load-language hl id)
  (def scope (clr-scope-of (record-ref hl options) id))
  (if (null-or-empty? scope)
      None
      (match (cast Object (with-lock hl (fun () (clr-load-grammar (record-ref hl registry) scope))))
        ((:is TextMateSharp.Grammars.IGrammar g) (Some (TmLanguage (id id) (grammar g) (highlighter hl))))
        (_ None))))

;; A language by its id, an alias or an extension, in any case: "csharp",
;; "C#", "cs" and ".cs" are one language. A grammar is read the first time
;; its language is asked for, and a broken one raises TextMateSharp's error.
(: find-language (-> TmHighlighter string (Option TmLanguage)))
(defun (find-language hl name)
  (def wanted (string-downcase (string-trim name)))
  (def dotted (if (string-starts-with? wanted ".") wanted (str "." wanted)))
  (def entries (record-ref hl languages))
  (def entry (match (first-entry (fun (e) (vec-contains (record-ref e names) wanted)) entries)
               ((Some e) (Some e))
               (None (first-entry (fun (e) (vec-contains (record-ref e extensions) dotted)) entries))))
  (match entry
    ((Some e) (load-language hl (record-ref e id)))
    (None None)))

;; ---------------------------------------------------------------------------
;; Tokens and spans
;; ---------------------------------------------------------------------------

;; The lines of some code. \r\n, \r and \n all end one, and a newline at the
;; very end ends the last line rather than beginning an empty one.
(: lines-of (-> string (Vec string)))
(defun (lines-of code)
  (def unified (string-replace (string-replace code "\r\n" "\n") "\r" "\n"))
  (cond
    ((string-empty? unified) (vec-empty))
    ((string-ends-with? unified "\n")
     (string-split (clr-substring unified 0 (- (string-length unified) 1)) "\n"))
    (else (string-split unified "\n"))))

;; Where each token's text lies in its line, as (index from to): from its
;; start to the next one's, the last to the end. TextMateSharp reads the line
;; with a newline added, so a start can lie past the text; and the first
;; token starts at 0, whatever it says. A token left with no text is dropped.
(: token-bounds (-> int int (-> int int) (Vec (Tuple int int int))))
(defun (token-bounds count len start-of)
  (loop (:for i (range 0 count))
        (:acc out (folding (vec-empty)
                           (let ((from (if (= i 0) 0 (min (start-of i) len)))
                                 (to (if (< (+ i 1) count) (min (start-of (+ i 1)) len) len)))
                             (if (< from to) (vec-add out (Tuple i from to)) out))))))

(: scopes-of (-> Token (Vec string)))
(defun (scopes-of t)
  (loop (:for s (cast (Seq string) (clr-token-scopes t)))
        (:acc (vecing s))))

(: scoped-line (-> string (Array Token) (Vec TmToken)))
(defun (scoped-line line tokens)
  (vec-map (fun (b)
             (match b
               ((Tuple i from to)
                (TmToken (text (clr-substring line from (- to from)))
                         (scopes (scopes-of (array-ref tokens i)))))))
           (token-bounds (array-length tokens) (string-length line)
                         (fun (i) (clr-token-start (array-ref tokens i))))))

;; Each line of some code, as tokens and their scopes. Needs no theme.
(: tokenize (-> TmLanguage string (Vec (Vec TmToken))))
(defun (tokenize lang code)
  (def hl (record-ref lang highlighter))
  (def g (record-ref lang grammar))
  (def limit (record-ref hl limit))
  (def lines (lines-of code))
  (with-lock hl
    (fun ()
      (match (loop (:for line lines)
                   (:acc acc (folding (Tuple (cast StateStack clr-initial-state) (vec-empty))
                                      (match acc
                                        ((Tuple state out)
                                         (let ((r (clr-tokenize g (LineText. line) state limit)))
                                           (Tuple (clr-scoped-state r)
                                                  (vec-add out (scoped-line line (clr-scoped-tokens r))))))))))
        ((Tuple _ out) out)))))

(: has-font-style? (-> FontStyle FontStyle bool))
(defun (has-font-style? fs flag)
  ;; NotSet is -1, every flag at once.
  (and (not (clr-has-flag (cast System.Enum fs) (cast System.Enum FontStyle.NotSet)))
       (clr-has-flag (cast System.Enum fs) (cast System.Enum flag))))

;; A colour id as a colour, or None for the theme's own: the id the theme
;; gives its default, or the colour the editor has, which the pre has too.
;; The default is its own id — 1 for text, 2 for background — and is what the
;; theme's token colours say, which is black and white when, as in Dark+,
;; they say nothing and the editor's colours are meant.
(: colour-or-none (-> TmHighlighter int int string (Option string)))
(defun (colour-or-none hl id default-id editor)
  (def c (colour-at (record-ref hl colours) id))
  (if (or (<= id 0) (= id default-id) (string-empty? c) (= (string-downcase c) (string-downcase editor)))
      None
      (Some c)))

(: style-of (-> TmHighlighter int TmStyle))
(defun (style-of hl metadata)
  (def fs (clr-meta-font-style metadata))
  (TmStyle (color (colour-or-none hl (clr-meta-foreground metadata) 1 (record-ref hl foreground)))
           (background (colour-or-none hl (clr-meta-background metadata) 2 (record-ref hl background)))
           (bold (has-font-style? fs FontStyle.Bold))
           (italic (has-font-style? fs FontStyle.Italic))
           (underline (has-font-style? fs FontStyle.Underline))
           (strikethrough (has-font-style? fs FontStyle.Strikethrough))))

;; Whitespace looks the same in any colour, so it is plain unless something
;; would show on it: a background, or a line under or through it.
(: plain-whitespace (-> TmSpan TmSpan))
(defun (plain-whitespace s)
  (def style (record-ref s style))
  (if (and (string-empty? (string-trim (record-ref s text)))
           (none? (record-ref style background))
           (not (record-ref style underline))
           (not (record-ref style strikethrough)))
      (TmSpan (text (record-ref s text)) (style plain-style))
      s))

;; Neighbours that look the same are one span.
(: merge-spans (-> (Vec TmSpan) (Vec TmSpan)))
(defun (merge-spans spans)
  (loop (:for s spans)
        (:acc out (folding (vec-empty)
                           (let ((last (- (vec-length out) 1)))
                             (if (and (>= last 0) (= (record-ref (vec-ref out last) style) (record-ref s style)))
                                 (vec-set out last (TmSpan (text (str (record-ref (vec-ref out last) text) (record-ref s text)))
                                                           (style (record-ref s style))))
                                 (vec-add out s)))))))

(: styled-line (-> TmHighlighter string (Array int) (Vec TmSpan)))
(defun (styled-line hl line encoded)
  ;; Pairs: a token's start, then its metadata.
  (merge-spans
    (vec-map (fun (b)
               (match b
                 ((Tuple i from to)
                  (plain-whitespace
                    (TmSpan (text (clr-substring line from (- to from)))
                            (style (style-of hl (array-ref encoded (+ (* 2 i) 1)))))))))
             (token-bounds (/ (array-length encoded) 2) (string-length line)
                           (fun (i) (array-ref encoded (* 2 i)))))))

;; Each line of some code, as spans coloured by the highlighter's theme.
(: highlight (-> TmLanguage string (Vec (Vec TmSpan))))
(defun (highlight lang code)
  (def hl (record-ref lang highlighter))
  (def g (record-ref lang grammar))
  (def limit (record-ref hl limit))
  (def lines (lines-of code))
  (with-lock hl
    (fun ()
      (match (loop (:for line lines)
                   (:acc acc (folding (Tuple (cast StateStack clr-initial-state) (vec-empty))
                                      (match acc
                                        ((Tuple state out)
                                         (let ((r (clr-tokenize-encoded g (LineText. line) state limit)))
                                           (Tuple (clr-encoded-state r)
                                                  (vec-add out (styled-line hl line (clr-encoded-tokens r))))))))))
        ((Tuple _ out) out)))))

;; ---------------------------------------------------------------------------
;; Classes
;; ---------------------------------------------------------------------------

;; The scopes a class is made from, TextMate's conventional names, the
;; general before the particular: that is the order of the stylesheet, so
;; that tm-keyword-control, written after tm-keyword, wins over it.
(: class-scopes (List string))
(def class-scopes
  (list "comment" "constant" "entity" "invalid" "keyword" "markup" "punctuation" "storage" "string"
        "support" "variable"
        "constant.numeric" "constant.character" "constant.language" "constant.other"
        "entity.name" "entity.other"
        "invalid.illegal" "invalid.deprecated"
        "keyword.control" "keyword.operator" "keyword.other"
        "markup.bold" "markup.italic" "markup.underline" "markup.heading" "markup.list" "markup.quote"
        "markup.raw" "markup.inserted" "markup.deleted" "markup.changed"
        "storage.type" "storage.modifier"
        "string.regexp"
        "support.function" "support.class" "support.type" "support.constant" "support.variable"
        "variable.parameter" "variable.language" "variable.other"
        "comment.block.documentation" "constant.character.escape"
        "entity.name.function" "entity.name.type" "entity.name.tag" "entity.name.section"
        "entity.name.variable" "entity.other.inherited-class" "entity.other.attribute-name"
        "punctuation.section.embedded"))

(: class-vocabulary (HashSet string))
(def class-vocabulary (list->hashset class-scopes))

;; The class scope a grammar scope comes under: the longest one it begins
;; with, a whole segment at a time. None for a scope that says nothing about
;; how text looks — meta., source. — and for punctuation.definition, the
;; quotes of a string and the ; of a comment, which look like what they
;; delimit.
(: vocabulary-entry (-> string (Option string)))
(defun (vocabulary-entry scope)
  (if (string-starts-with? scope "punctuation.definition.")
      None
      (let ((segments (string-split scope ".")))
        (loop (:for k (range 1 (+ (min 3 (vec-length segments)) 1)))
              (:acc found (folding None
                                   (let ((prefix (string-join (vec-slice segments 0 k) ".")))
                                     (if (hashset-contains? class-vocabulary prefix) (Some prefix) found))))))))

(: class-name (-> string string))
(defun (class-name scope) (str "tm-" (string-replace scope "." "-")))

;; Where the code of one language begins inside another's text: the hole of
;; an interpolated string, a script in HTML. What is outside does not colour
;; what is inside.
(: embedded-scope? (-> string bool))
(defun (embedded-scope? scope)
  (or (string-starts-with? scope "meta.embedded")
      (string-starts-with? scope "source.")
      (string-starts-with? scope "text.")))

;; A token's classes: the general one and the particular, "tm-keyword
;; tm-keyword-control", from the innermost scope that has one, looking no
;; further out than where embedded code begins. That is how a theme picks a
;; token's colour too. None for plain text.
(: token-classes (-> TmToken (Vec string)))
(defun (token-classes t)
  (def scopes (record-ref t scopes))
  (def entry (loop (:for i (range 0 (vec-length scopes)))
                   (:acc found (folding None
                                        (let ((scope (vec-ref scopes i)))
                                          (if (embedded-scope? scope)
                                              None
                                              (match (vocabulary-entry scope)
                                                ((Some e) (Some e))
                                                (None found))))))))
  (match entry
    ((Some e)
     (let ((top (vec-ref (string-split e ".") 0)))
       (if (= top e) [(class-name e)] [(class-name top) (class-name e)])))
    (None (vec-empty))))

;; A rule with a selector, which applies whatever surrounds the scope. A
;; rule of no depth is the theme saying nothing, and is passed over.
(: unconditional? (-> ThemeRule bool))
(defun (unconditional? r)
  (and (> (clr-rule-depth r) 0)
       (match (cast Object (clr-rule-parents r))
         ((:is System.Collections.ICollection c) (= (.-Count c) 0))
         (_ #t))))

;; How a theme styles a class scope, as CSS. The rule is the one
;; TextMateSharp colours a token of that scope by: the first that applies,
;; whole. That is the theme's own before the one it includes, however
;; specific the included one is. A font style that is set is written in
;; full, so that "none" undoes a general class's italic.
(: theme-css (-> TmHighlighter string string))
(defun (theme-css hl scope)
  (def rule (loop (:for r (cast (Seq ThemeRule)
                                (clr-theme-match (record-ref hl theme)
                                                 (cast (System.Collections.Generic.IList string) #[scope]))))
                  (:acc found (folding None (if (and (none? found) (unconditional? r)) (Some r) found)))))
  (def fg (match rule ((Some r) (clr-rule-foreground r)) (None 0)))
  (def bg (match rule ((Some r) (if (> (clr-rule-background r) 2) (clr-rule-background r) 0)) (None 0)))
  (def fs (match rule
            ((Some r) (if (clr-has-flag (cast System.Enum (clr-rule-font-style r)) (cast System.Enum FontStyle.NotSet))
                          None
                          (Some (clr-rule-font-style r))))
            (None None)))
  (def colours (record-ref hl colours))
  (def parts
    (vec-merge
      (vec-merge (cond ((= fg 0) (vec-empty))
                       ;; The theme's default is the editor's colour, as it is inline.
                       ((= fg 1) [(str "color:" (record-ref hl foreground))])
                       (else [(str "color:" (colour-at colours fg))]))
                 (if (= bg 0) (vec-empty) [(str "background-color:" (colour-at colours bg))]))
      (match fs
        ((Some s)
         (def decorations (vec-merge (if (has-font-style? s FontStyle.Underline) ["underline"] (vec-empty))
                                     (if (has-font-style? s FontStyle.Strikethrough) ["line-through"] (vec-empty))))
         [(str "font-weight:" (if (has-font-style? s FontStyle.Bold) "bold" "normal"))
          (str "font-style:" (if (has-font-style? s FontStyle.Italic) "italic" "normal"))
          (str "text-decoration:" (if (vec-empty? decorations) "none" (string-join decorations " ")))])
        (None (vec-empty)))))
  (string-join parts ";"))

;; A stylesheet for #:style 'classes in this highlighter's theme, every rule
;; under #:selector: the pre's colours, then a rule for each class the theme
;; has something to say about.
(: highlighter-css (-> TmHighlighter (#:selector string) string))
(defun (highlighter-css hl #:selector ".tm")
  (def rules (loop (:for scope class-scopes)
                   (:acc out (folding (vec-empty)
                                      (let ((css (theme-css hl scope)))
                                        (if (string-empty? css)
                                            out
                                            (vec-add out (str selector " ." (class-name scope) "{" css "}"))))))))
  (string-join (vec-insert rules 0 (str selector "{color:" (record-ref hl foreground)
                                         ";background-color:" (record-ref hl background) "}"))
               "\n"))

;; ---------------------------------------------------------------------------
;; Nodes
;; ---------------------------------------------------------------------------

(: pre-tag XmlName)
(def pre-tag (xml-name "pre"))

(: code-tag XmlName)
(def code-tag (xml-name "code"))

(: span-tag XmlName)
(def span-tag (xml-name "span"))

(: class-attr XmlName)
(def class-attr (xml-name "class"))

(: style-attr XmlName)
(def style-attr (xml-name "style"))

(: style->css (-> TmStyle string))
(defun (style->css s)
  (def decorations (vec-merge (if (record-ref s underline) ["underline"] (vec-empty))
                              (if (record-ref s strikethrough) ["line-through"] (vec-empty))))
  (string-join
    (vec-merge
      (vec-merge (match (record-ref s color) ((Some c) [(str "color:" c)]) (None (vec-empty)))
                 (match (record-ref s background) ((Some c) [(str "background-color:" c)]) (None (vec-empty))))
      (vec-merge (vec-merge (if (record-ref s bold) ["font-weight:bold"] (vec-empty))
                            (if (record-ref s italic) ["font-style:italic"] (vec-empty)))
                 (if (vec-empty? decorations) (vec-empty) [(str "text-decoration:" (string-join decorations " "))])))
    ";"))

;; Text in a span with that attribute, or the text alone when it is "".
(: span-node (-> XmlName string string Node))
(defun (span-node attr value text)
  (if (string-empty? value)
      (xml-text text)
      (xml-element span-tag (list (Tuple attr value)) (list (xml-text text)))))

(: inline-line (-> (Vec TmSpan) (Vec Node)))
(defun (inline-line spans)
  (vec-map (fun (s) (span-node style-attr (style->css (record-ref s style)) (record-ref s text))) spans))

;; Neighbours with the same classes are one span.
(: class-line (-> (Vec TmToken) (Vec Node)))
(defun (class-line tokens)
  (def runs (loop (:for t tokens)
                  (:acc out (folding (vec-empty)
                                     (let ((classes (string-join (token-classes t) " "))
                                           (last (- (vec-length out) 1)))
                                       (match (if (>= last 0) (Some (vec-ref out last)) None)
                                         ((Some (Tuple c text))
                                          (if (= c classes)
                                              (vec-set out last (Tuple c (str text (record-ref t text))))
                                              (vec-add out (Tuple classes (record-ref t text)))))
                                         (None (vec-add out (Tuple classes (record-ref t text))))))))))
  (vec-map (fun (run) (match run ((Tuple classes text) (span-node class-attr classes text)))) runs))

;; The lines as the code element's children, with a newline between each.
;; Under #:lines? each line is a (span (@ (class "line")) ...), with its
;; newline inside it, so that no line but perhaps the last is empty.
(: assemble (-> (Vec (Vec Node)) bool (List Node)))
(defun (assemble lines lines?)
  (def count (vec-length lines))
  (vec->list
    (loop (:for i (range 0 count))
          (:acc out (folding (vec-empty)
                             (let* ((nodes (vec-ref lines i))
                                    (content (if (< (+ i 1) count) (vec-add nodes (xml-text "\n")) nodes)))
                               (if lines?
                                   (vec-add out (xml-element span-tag (list (Tuple class-attr "line")) (vec->list content)))
                                   (vec-merge out content))))))))

;; The pre and code elements around some children: the pre carries the
;; theme's colours when they are inline, and the code the language, as
;; language-csharp.
(: pre-node (-> TmHighlighter TmStyleMode (Option string) (List Node) Node))
(defun (pre-node hl style language children)
  (def pre-attrs
    (match style
      (StyleInline (list (Tuple class-attr "tm")
                         (Tuple style-attr (str "color:" (record-ref hl foreground)
                                                ";background-color:" (record-ref hl background)))))
      (StyleClasses (list (Tuple class-attr "tm")))))
  (def code-attrs (match language
                    ((Some id) (list (Tuple class-attr (str "language-" id))))
                    (None Nil)))
  (xml-element pre-tag pre-attrs (list (xml-element code-tag code-attrs children))))

;; Some code, highlighted, as the children of a code element.
(: highlight->nodes (-> TmLanguage string (#:style TmStyleMode) (#:lines? bool) (List Node)))
(defun (highlight->nodes lang code #:style 'inline #:lines? #f)
  (assemble (match style
              (StyleInline (vec-map inline-line (highlight lang code)))
              (StyleClasses (vec-map class-line (tokenize lang code))))
            lines?))

;; Some code, highlighted, in a pre and a code element.
(: highlight->node (-> TmLanguage string (#:style TmStyleMode) (#:lines? bool) Node))
(defun (highlight->node lang code #:style 'inline #:lines? #f)
  (pre-node (record-ref lang highlighter) style (Some (record-ref lang id))
            (highlight->nodes lang code #:style style #:lines? lines?)))

;; Some code in a language named as a Markdown fence names it — "c#", or
;; "scheme title=x", of which the first word counts — highlighted when the
;; language is known and as plain text when it is not.
(: code->node (-> TmHighlighter string string (#:style TmStyleMode) (#:lines? bool) Node))
(defun (code->node hl name code #:style 'inline #:lines? #f)
  (def word (vec-ref (string-split (string-trim name) " ") 0))
  (match (find-language hl word)
    ((Some lang) (highlight->node lang code #:style style #:lines? lines?))
    (None (pre-node hl style (if (string-empty? word) None (Some word))
                    (assemble (vec-map (fun (line) [(xml-text line)]) (lines-of code)) lines?)))))