fix(editor): highlight recognized Haskell source and diffs

Load the maintained Haskell grammar through the existing lazy TextMate
registration. Map its scopes to existing Monaco theme categories, retain
the upstream license in packaged resources, and cover real tokenization
and hidden Electron file and diff views.

Co-authored-by: davidwis <davidwis000@gmail.com>

resources/licenses/language-haskell/LICENSE.txt

@@ -0,0 +1,30 @@
+Copyright (c) 2017 Justus Adam
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Justus Adam nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

resources/licenses/language-haskell/UPSTREAM.txt

@@ -0,0 +1,4 @@
+Source: https://github.com/haskell/language-haskell
+Version: 3.8.0 (commit 417bdaf7d997b8561d8d52066120faca395a1ec7)
+Grammar: syntaxes/haskell.YAML-tmLanguage, converted to JSON without changing its content.
+License: BSD-3-Clause; the full upstream license is in LICENSE.txt.

src/renderer/src/lib/language-detect.test.ts

@@ -2,6 +2,15 @@ import { describe, expect, it } from 'vitest'
 import { detectLanguage } from './language-detect'
 
 describe('detectLanguage', () => {
+  it.each([
+    'src/Main.hs',
+    'src/Main.hsig',
+    'src/Main.hs-boot',
+    'C:\\src\\MAIN.HS',
+    '/remote folder/Main.hsig'
+  ])('maps Haskell source %s to the haskell language id', (filePath) => {
+    expect(detectLanguage(filePath)).toBe('haskell')
+  })
   it('maps .vue files to the custom vue language id', () => {
     expect(detectLanguage('src/components/App.vue')).toBe('vue')
   })

src/renderer/src/lib/language-detect.ts

@@ -94,6 +94,8 @@ const EXT_TO_LANGUAGE: Record<string, string> = {
   '.erl': 'erlang',
   '.hrl': 'erlang',
   '.hs': 'haskell',
+  '.hsig': 'haskell',
+  '.hs-boot': 'haskell',
   '.clj': 'clojure',
   // Why: Monaco registers Solidity under the id 'sol'; 'solidity' is only an alias.
   '.sol': 'sol',

src/renderer/src/lib/monaco-languages/register-haskell.test.ts

@@ -0,0 +1,93 @@
+// @vitest-environment happy-dom
+import * as monaco from 'monaco-editor/esm/vs/editor/editor.api.js'
+import { afterAll, beforeAll, describe, expect, it, vi } from 'vitest'
+import { loadHaskellTextMateGrammar, registerHaskellLanguage } from './register-haskell'
+import type { TextMateTokensProviderOptions } from './textmate-token-provider'
+import type * as TextMateProvider from './textmate-token-provider'
+import { loadNodeOniguruma } from './textmate-oniguruma-fixture'
+
+const providerRequests = vi.hoisted(() => vi.fn())
+const disposers: (() => void)[] = []
+
+vi.mock('./textmate-token-provider', async (importOriginal) => {
+  const actual = await importOriginal<typeof TextMateProvider>()
+  return {
+    ...actual,
+    createTextMateTokensProvider: (options: TextMateTokensProviderOptions) => {
+      providerRequests()
+      return actual.createTextMateTokensProvider({ ...options, loadOniguruma: loadNodeOniguruma })
+    }
+  }
+})
+
+beforeAll(() => {
+  const registration = vi.spyOn(monaco.languages, 'register')
+  const configuration = vi.spyOn(monaco.languages, 'setLanguageConfiguration')
+  const factory = vi.spyOn(monaco.languages, 'registerTokensProviderFactory')
+  registerHaskellLanguage(monaco)
+  expect(providerRequests).not.toHaveBeenCalled()
+  registerHaskellLanguage(monaco)
+  expect(registration).toHaveBeenCalledTimes(1)
+  for (const call of [...configuration.mock.results, ...factory.mock.results]) {
+    if (call.type === 'return') {
+      disposers.push(() => call.value.dispose())
+    }
+  }
+})
+
+afterAll(() => {
+  for (const dispose of disposers.splice(0).toReversed()) {
+    dispose()
+  }
+  vi.restoreAllMocks()
+})
+
+describe('Haskell through the installed Monaco tokenizer', () => {
+  it('lazily colors recognized source, types, numbers, strings, and comments', async () => {
+    const source = [
+      'module Main where',
+      '-- comment',
+      'answer :: Int',
+      'answer = 42',
+      'main = putStrLn "hello"'
+    ].join('\n')
+    await monaco.editor.colorize(source, 'haskell', {})
+    expect(providerRequests).toHaveBeenCalledTimes(1)
+    const tokens = monaco.editor.tokenize(source, 'haskell')
+    const scopes = (line: number) => tokens[line].map((token) => token.type)
+
+    expect(scopes(0)).toContain('keyword.other.module.haskell')
+    expect(new Set(scopes(1))).toEqual(new Set(['comment.haskell']))
+    expect(scopes(2)).toEqual(expect.arrayContaining(['type.identifier.haskell', 'type.haskell']))
+    expect(scopes(3)).toContain('number.haskell')
+    expect(scopes(4)).toContain('string.quoted.double.haskell')
+    expect(monaco.languages.getLanguages().find(({ id }) => id === 'haskell')?.extensions).toEqual([
+      '.hs',
+      '.hsig',
+      '.hs-boot'
+    ])
+  })
+
+  it('keeps nested comments active and returns to code after both closers', async () => {
+    const source = [
+      '{- outer {- inner',
+      '-} still outer',
+      '-}',
+      'answer = 42',
+      'text = "-- literal"'
+    ].join('\n')
+    await monaco.editor.colorize(source, 'haskell', {})
+    const tokens = monaco.editor.tokenize(source, 'haskell')
+
+    expect(new Set(tokens[0].map((token) => token.type))).toEqual(new Set(['comment.haskell']))
+    expect(new Set(tokens[1].map((token) => token.type))).toEqual(new Set(['comment.haskell']))
+    expect(tokens[3].map((token) => token.type)).toContain('number.haskell')
+    expect(tokens[3].map((token) => token.type)).not.toContain('comment.haskell')
+    expect(tokens[4].map((token) => token.type)).toContain('string.quoted.double.haskell')
+    expect(tokens[4].map((token) => token.type)).not.toContain('comment.haskell')
+  })
+
+  it('does not load a grammar for an unrelated scope', async () => {
+    await expect(loadHaskellTextMateGrammar('source.python')).resolves.toBeNull()
+  })
+})

src/renderer/src/lib/monaco-languages/register-haskell.ts

@@ -0,0 +1,74 @@
+import type * as Monaco from 'monaco-editor'
+import type { IRawGrammar } from 'vscode-textmate'
+import { registerTextMateLanguage } from './textmate-language-registration'
+
+const HASKELL_SCOPE = 'source.haskell'
+
+export const haskellLanguageConfiguration: Monaco.languages.LanguageConfiguration = {
+  comments: { lineComment: '--', blockComment: ['{-', '-}'] },
+  brackets: [
+    ['{', '}'],
+    ['[', ']'],
+    ['(', ')']
+  ],
+  autoClosingPairs: [
+    { open: '{', close: '}' },
+    { open: '[', close: ']' },
+    { open: '(', close: ')' },
+    { open: '"', close: '"', notIn: ['string', 'comment'] }
+  ],
+  surroundingPairs: [
+    { open: '{', close: '}' },
+    { open: '[', close: ']' },
+    { open: '(', close: ')' },
+    { open: '"', close: '"' },
+    { open: "'", close: "'" }
+  ]
+}
+
+function mapHaskellTokenScopes(scopes: readonly string[]): string {
+  if (scopes.some((scope) => scope.startsWith('comment.'))) {
+    return 'comment.haskell'
+  }
+  const scope = scopes.at(-1) ?? HASKELL_SCOPE
+  if (scope.startsWith('constant.numeric.')) {
+    return 'number.haskell'
+  }
+  if (scope.startsWith('constant.character.escape.')) {
+    return 'string.escape.haskell'
+  }
+  if (scope.startsWith('entity.name.function.')) {
+    return 'type.identifier.haskell'
+  }
+  if (scope.startsWith('storage.type.')) {
+    return 'type.haskell'
+  }
+  if (scope.startsWith('variable.other.generic-type.')) {
+    return 'variable.parameter.haskell'
+  }
+  return scope
+}
+
+export async function loadHaskellTextMateGrammar(scopeName: string): Promise<IRawGrammar | null> {
+  if (scopeName !== HASKELL_SCOPE) {
+    return null
+  }
+  // BSD-3-Clause grammar; provenance and license ship in resources/licenses/language-haskell.
+  const grammarModule = await import('./textmate-grammars/haskell.tmLanguage.json')
+  // oxlint-disable-next-line typescript/consistent-type-assertions -- SAFETY: TextMate adds the required $self/$base repository entries; real tokenizer tests validate this generated upstream grammar.
+  return grammarModule.default as unknown as IRawGrammar
+}
+
+export function registerHaskellLanguage(monaco: Pick<typeof Monaco, 'languages'>): void {
+  registerTextMateLanguage(monaco, {
+    language: {
+      id: 'haskell',
+      extensions: ['.hs', '.hsig', '.hs-boot'],
+      aliases: ['Haskell', 'haskell']
+    },
+    configuration: haskellLanguageConfiguration,
+    scopeName: HASKELL_SCOPE,
+    loadGrammar: loadHaskellTextMateGrammar,
+    mapTokenScopes: mapHaskellTokenScopes
+  })
+}

src/renderer/src/lib/monaco-languages/textmate-language-registration.ts

@@ -4,7 +4,7 @@ import type {
   TextMateGrammarLoader
 } from './textmate-token-provider'
 
-type MonacoModule = typeof Monaco
+type MonacoModule = Pick<typeof Monaco, 'languages'>
 type TextMateTokensProvider = Monaco.languages.TokensProvider
 type TextMateTokenProviderModule = {
   createTextMateTokensProvider: typeof createTextMateTokensProviderType
@@ -15,6 +15,7 @@ export type TextMateLanguageRegistration = {
   configuration?: Monaco.languages.LanguageConfiguration
   scopeName: string
   loadGrammar: TextMateGrammarLoader
+  mapTokenScopes?: (scopes: readonly string[]) => string
   loadProviderModule?: () => Promise<TextMateTokenProviderModule>
 }
 
@@ -48,7 +49,8 @@ export function registerTextMateLanguage(
       )().then(({ createTextMateTokensProvider }) =>
         createTextMateTokensProvider({
           scopeName: registration.scopeName,
-          loadGrammar: registration.loadGrammar
+          loadGrammar: registration.loadGrammar,
+          ...(registration.mapTokenScopes ? { mapTokenScopes: registration.mapTokenScopes } : {})
         })
       )
       return tokensProviderPromise

src/renderer/src/lib/monaco-languages/textmate-oniguruma-fixture.ts

@@ -0,0 +1,16 @@
+import { createRequire } from 'node:module'
+import { readFile } from 'node:fs/promises'
+import { createOnigScanner, createOnigString, loadWASM } from 'vscode-oniguruma'
+import type { IOnigLib } from 'vscode-textmate'
+
+const require = createRequire(import.meta.url)
+let nodeOnigurumaPromise: Promise<IOnigLib> | undefined
+
+export function loadNodeOniguruma(): Promise<IOnigLib> {
+  nodeOnigurumaPromise ??= (async () => {
+    const bytes = await readFile(require.resolve('vscode-oniguruma/release/onig.wasm'))
+    await loadWASM(new Uint8Array(bytes))
+    return { createOnigScanner, createOnigString }
+  })()
+  return nodeOnigurumaPromise
+}

src/renderer/src/lib/monaco-languages/textmate-token-provider.test.ts

@@ -1,30 +1,9 @@
-import { createRequire } from 'node:module'
-import { readFile } from 'node:fs/promises'
 import { describe, expect, it } from 'vitest'
-import { createOnigScanner, createOnigString, loadWASM } from 'vscode-oniguruma'
-import type { IOnigLib, IRawGrammar } from 'vscode-textmate'
+import type { IRawGrammar } from 'vscode-textmate'
 import nimGrammar from './textmate-grammars/nim.tmLanguage.json'
 import { loadTypstTextMateGrammar } from './register-typst'
 import { createTextMateTokensProvider } from './textmate-token-provider'
-
-const require = createRequire(import.meta.url)
-
-let nodeOnigurumaPromise: Promise<IOnigLib> | undefined
-
-async function loadNodeOniguruma(): Promise<IOnigLib> {
-  nodeOnigurumaPromise ??= (async () => {
-    const wasmPath = require.resolve('vscode-oniguruma/release/onig.wasm')
-    const wasmBytes = await readFile(wasmPath)
-    const wasmBuffer = wasmBytes.buffer.slice(
-      wasmBytes.byteOffset,
-      wasmBytes.byteOffset + wasmBytes.byteLength
-    )
-    await loadWASM(wasmBuffer)
-    return { createOnigScanner, createOnigString }
-  })()
-
-  return nodeOnigurumaPromise
-}
+import { loadNodeOniguruma } from './textmate-oniguruma-fixture'
 
 describe('createTextMateTokensProvider', () => {
   it('tokenizes Nim with the vendored TextMate grammar', async () => {

src/renderer/src/lib/monaco-languages/textmate-token-provider.ts

@@ -10,6 +10,7 @@ export type TextMateGrammarLoader = (scopeName: string) => Promise<IRawGrammar |
 export type TextMateTokensProviderOptions = {
   scopeName: string
   loadGrammar: TextMateGrammarLoader
+  mapTokenScopes?: (scopes: readonly string[]) => string
   loadOniguruma?: () => Promise<IOnigLib>
 }
 
@@ -47,7 +48,8 @@ class TextMateTokenizerState implements Monaco.languages.IState {
 
 function createTokensProvider(
   grammar: IGrammar,
-  fallbackScopeName: string
+  fallbackScopeName: string,
+  mapTokenScopes?: (scopes: readonly string[]) => string
 ): TextMateTokensProvider {
   return {
     getInitialState() {
@@ -64,7 +66,7 @@ function createTokensProvider(
           startIndex: token.startIndex,
           // Why: Monaco themes match a single token scope; TextMate returns a
           // scope stack, and the final entry is the most specific reusable one.
-          scopes: token.scopes.at(-1) ?? fallbackScopeName
+          scopes: mapTokenScopes?.(token.scopes) ?? token.scopes.at(-1) ?? fallbackScopeName
         }))
       }
     }
@@ -94,5 +96,5 @@ export async function createTextMateTokensProvider(
     throw new Error(`No TextMate grammar registered for scope ${options.scopeName}`)
   }
 
-  return createTokensProvider(grammar, options.scopeName)
+  return createTokensProvider(grammar, options.scopeName, options.mapTokenScopes)
 }

src/renderer/src/lib/monaco-setup.ts

@@ -10,6 +10,7 @@ import htmlWorker from 'monaco-editor/esm/vs/language/html/html.worker?worker'
 import tsWorker from 'monaco-editor/esm/vs/language/typescript/ts.worker?worker'
 import { registerAstroLanguage } from './monaco-languages/register-astro'
 import { registerJsonlLanguage } from './monaco-languages/register-jsonl'
+import { registerHaskellLanguage } from './monaco-languages/register-haskell'
 import { registerNimLanguage } from './monaco-languages/register-nim'
 import { registerShellMarkdownAliases } from './monaco-languages/register-shell-markdown-aliases'
 import { registerSvelteLanguage } from './monaco-languages/register-svelte'
@@ -83,6 +84,7 @@ runMonacoSetupSteps([
   ['Svelte language registration', () => registerSvelteLanguage(monaco)],
   ['Astro language registration', () => registerAstroLanguage(monaco)],
   ['Nim language registration', () => registerNimLanguage(monaco)],
+  ['Haskell language registration', () => registerHaskellLanguage(monaco)],
   ['Typst language registration', () => registerTypstLanguage(monaco)],
   ['JSONL language registration', () => registerJsonlLanguage(monaco)],
   ['shell Markdown alias registration', () => registerShellMarkdownAliases(monaco)],

tests/e2e/editor-haskell-highlighting.spec.ts

@@ -0,0 +1,99 @@
+import { writeFileSync } from 'node:fs'
+import path from 'node:path'
+import type { Locator } from '@stablyai/playwright-test'
+import { detectLanguage } from '../../src/renderer/src/lib/language-detect'
+import { test, expect } from './helpers/orca-app'
+import {
+  cleanupGoldenWorktree,
+  createGoldenWorktree,
+  openGoldenSourceControl
+} from './helpers/golden-source-control'
+import { waitForSessionReady } from './helpers/store'
+
+const source = [
+  'module Main where',
+  '-- A comment',
+  'answer :: Int',
+  'answer = 42',
+  'main = putStrLn "hello"',
+  ''
+].join('\n')
+
+async function colors(editor: Locator): Promise<Record<string, string | null>> {
+  return editor.locator('.view-lines:not(.line-delete)').evaluate((lines) => {
+    const colorOf = (text: string) => {
+      const span = [...lines.querySelectorAll('span[class*="mtk"]')].find((entry) =>
+        entry.textContent?.includes(text)
+      )
+      return span ? getComputedStyle(span).color : null
+    }
+    return {
+      keyword: colorOf('module'),
+      comment: colorOf('comment'),
+      type: colorOf('Int'),
+      number: colorOf('42'),
+      string: colorOf('hello')
+    }
+  })
+}
+
+async function expectHighlighted(editor: Locator): Promise<void> {
+  await expect(editor.locator('.view-lines:not(.line-delete)')).toContainText('module Main where')
+  await expect
+    .poll(
+      async () => {
+        const painted = await colors(editor)
+        return (
+          Object.values(painted).every((color) => color !== null) &&
+          new Set(Object.values(painted)).size >= 4
+        )
+      },
+      { timeout: 25_000 }
+    )
+    .toBe(true)
+}
+
+test('highlights recognized Haskell source and an untracked file diff', async ({
+  orcaPage,
+  testRepoPath,
+  registerPostElectronShutdownCleanup
+}, testInfo) => {
+  const fixture = createGoldenWorktree(testRepoPath, 'haskell-highlighting')
+  registerPostElectronShutdownCleanup(async () => cleanupGoldenWorktree(testRepoPath, fixture))
+  const filePath = path.join(fixture.worktreePath, 'Main.hs')
+  writeFileSync(filePath, source)
+
+  await waitForSessionReady(orcaPage)
+  await openGoldenSourceControl(orcaPage, testRepoPath, fixture)
+  await orcaPage.evaluate(
+    ({ filePath, language }) => {
+      const store = window.__store
+      const worktreeId = store?.getState().activeWorktreeId
+      if (!store || !worktreeId) {
+        throw new Error('Haskell fixture worktree unavailable')
+      }
+      store
+        .getState()
+        .openFile({ filePath, relativePath: 'Main.hs', worktreeId, language, mode: 'edit' })
+    },
+    { filePath, language: detectLanguage(filePath) }
+  )
+  const sourceEditor = orcaPage.locator('.monaco-editor').first()
+  await expectHighlighted(sourceEditor)
+  await expect
+    .poll(() => orcaPage.evaluate(() => window.__monacoEditorE2E?.snapshot().valueLength))
+    .toBe(source.length)
+  await orcaPage.screenshot({ path: testInfo.outputPath('haskell-source.png') })
+
+  await orcaPage
+    .locator('[data-testid="source-control-entry"]')
+    .filter({ hasText: 'Main.hs' })
+    .click()
+  await expectHighlighted(orcaPage.locator('.modified-in-monaco-diff-editor'))
+  await orcaPage.screenshot({ path: testInfo.outputPath('haskell-diff.png') })
+
+  await orcaPage.evaluate(() => window.__store?.getState().updateSettings({ theme: 'dark' }))
+  const darkDiff = orcaPage.locator('.modified-in-monaco-diff-editor.vs-dark')
+  await expectHighlighted(darkDiff)
+  await orcaPage.screenshot({ path: testInfo.outputPath('haskell-diff-dark.png') })
+})