add rudimentary tags queries

.github/workflows/ci.yml

@@ -16,6 +16,11 @@ jobs:
       - uses: actions/checkout@v4
       - uses: DeterminateSystems/nix-installer-action@main
 
+      - name: Init config
+        run: |
+          mkdir -p /home/runner/.config/tree-sitter
+          printf '{"parser-directories":["%q"]}' "${GITHUB_WORKSPACE%/*}" > "/home/runner/.config/tree-sitter/config.json"
+
       - name: Run tests
         run: nix -L run .#ci
 

nix/outputs.nix

@@ -311,6 +311,7 @@
   tree-sitter test
   test/parse/run.bash
   test/query/run.bash
+  test/tags-local/run.bash
   '';
 
   tests = script "tree-sitter-haskell-tests" ''

queries/tags.scm

@@ -0,0 +1,106 @@
+(
+  (
+    (haddock) @doc
+    .
+    [
+
+      (header (module) @name) @definition.module
+
+      (declarations
+        .
+        [
+          (function name: (variable) @name) @definition.function
+          (signature name: (variable) @name) @definition.function
+          (bind name: (variable) @name) @definition.variable
+          (data_type name: (name) @name) @definition.class
+          (newtype name: (name) @name) @definition.class
+          (class name: (name) @name) @definition.interface
+          (instance name: (name) @name) @reference.implementation
+        ]
+      )
+
+      (class_declarations
+        .
+        [
+          (function name: (variable) @name)
+          (signature name: (variable) @name)
+          (bind name: (variable) @name)
+        ] @definition.method
+      )
+
+      (instance_declarations
+        .
+        [
+          (function name: (variable) @name)
+          (signature name: (variable) @name)
+          (bind name: (variable) @name)
+        ] @definition.method
+      )
+
+    ]
+  )
+  (#strip! @doc "^\s*--+\\s*(\\|\\s*)?")
+  (#select-adjacent! @doc @definition.function)
+ )
+
+(
+  [
+
+    (declarations
+      (haddock) @doc
+      .
+      [
+        (function name: (variable) @name) @definition.function
+        (signature name: (variable) @name) @definition.function
+        (bind name: (variable) @name) @definition.variable
+        (data_type name: (name) @name) @definition.class
+        (newtype name: (name) @name) @definition.class
+        (class name: (name) @name) @definition.interface
+        (instance name: (name) @name) @reference.implementation
+      ]
+    )
+
+    (class_declarations
+      (haddock)? @doc
+      .
+      [
+        (signature name: (variable) @name)
+        (function name: (variable) @name)
+        (bind name: (variable) @name)
+      ] @definition.method
+    )
+
+    (instance_declarations
+      (haddock)? @doc
+      .
+      [
+        (signature name: (variable) @name)
+        (function name: (variable) @name)
+        (bind name: (variable) @name)
+      ] @definition.method
+    )
+
+   ]
+  (#strip! @doc "^\s*--+\\s*(\\|\\s*)?")
+  (#select-adjacent! @doc @definition.function)
+)
+
+(declarations
+  [
+    (function name: (variable) @name) @definition.function
+    (signature name: (variable) @name) @definition.function
+    (bind name: (variable) @name) @definition.variable
+  ]
+)
+
+(header (module) @name) @definition.module
+
+(data_type name: (name) @name) @definition.class
+
+(newtype name: (name) @name) @definition.class
+
+(pattern/variable) @definition.variable
+
+(expression/variable) @reference.variable
+
+(expression/apply) @reference.call

test/main

@@ -5,3 +5,4 @@ set -e
 tree-sitter test
 test/parse/run.bash
 test/query/run.bash
+test/tags-local/run.bash

test/tags-local/class.hs

@@ -0,0 +1,19 @@
+module A.B where
+
+-- | Documentation
+class A a where
+  -- | Documentaton
+  meth1 :: Int -> a
+  meth1 a = a
+
+  -- | Documentaton
+  meth2 :: Int -> a
+  meth2 a = a
+
+-- | Documentation
+instance A Int where
+  -- | Documentaton
+  meth1 a = a
+
+  -- | Documentaton
+  meth2 a = a

test/tags-local/class.target

@@ -0,0 +1,7 @@
+A.B       	 | module  	def (0, 7) - (0, 10) `module A.B where`
+A         	 | interface	def (3, 6) - (3, 7) `class A a where`	"Documentation"
+meth1     	 | method  	def (5, 2) - (5, 7) `meth1 :: Int -> a`	"Documentaton"
+meth2     	 | method  	def (9, 2) - (9, 7) `meth2 :: Int -> a`	"Documentaton"
+A         	 | implementation	ref (13, 9) - (13, 10) `instance A Int where`	"Documentation"
+meth1     	 | method  	def (15, 2) - (15, 7) `meth1 a = a`	"Documentaton"
+meth2     	 | method  	def (18, 2) - (18, 7) `meth2 a = a`	"Documentaton"

test/tags-local/data.hs

@@ -0,0 +1,7 @@
+-- | Documentation
+module A.B where
+
+-- | Documentation
+data A = A Int
+
+newtype A = A Int

test/tags-local/data.target

@@ -0,0 +1,3 @@
+A.B       	 | module  	def (1, 7) - (1, 10) `module A.B where`	"Documentation"
+A         	 | class   	def (4, 5) - (4, 6) `data A = A Int`	"Documentation"
+A         	 | class   	def (6, 8) - (6, 9) `newtype A = A Int`

test/tags-local/function.hs

@@ -0,0 +1,21 @@
+-- | Documentation fun1
+fun1 :: Maybe Int -> String -> IO Bool
+fun1 (Just i) s =
+  if i == 1
+  then True
+  else s == ""
+
+-- | Documentation fun2
+fun2 :: a -> a
+fun2 a = a
+
+-- | Documentation equation
+equation a = 1
+
+-- | Documentation bind1
+bind1 :: Int
+bind1 = 1
+
+-- Comment
+bind2 :: Int
+bind2 = 1

test/tags-local/function.target

@@ -0,0 +1,9 @@
+fun1      	 | function	def (1, 0) - (1, 4) `fun1 :: Maybe Int -> String -> IO Bool`	"Documentation fun1"
+fun1      	 | function	def (2, 0) - (2, 4) `fun1 (Just i) s =`
+fun2      	 | function	def (8, 0) - (8, 4) `fun2 :: a -> a`	"Documentation fun2"
+fun2      	 | function	def (9, 0) - (9, 4) `fun2 a = a`
+equation  	 | function	def (12, 0) - (12, 8) `equation a = 1`	"Documentation equation"
+bind1     	 | function	def (15, 0) - (15, 5) `bind1 :: Int`	"Documentation bind1"
+bind1     	 | variable	def (16, 0) - (16, 5) `bind1 = 1`
+bind2     	 | function	def (19, 0) - (19, 5) `bind2 :: Int`
+bind2     	 | variable	def (20, 0) - (20, 5) `bind2 = 1`

test/tags-local/run.bash

@@ -0,0 +1,22 @@
+#!/usr/bin/env bash
+
+base=$(dirname $0)
+
+source $base/../common.bash
+
+tags_test_file() {
+  if [[ $mode == 'native' ]]
+  then
+    tree-sitter tags $2
+  elif [[ $mode == 'wasm' ]]
+  then
+    message "Tags tests can't be run in wasm."
+    exit 1
+  else
+    message "Invalid mode: $mode"
+    exit 1
+  fi
+}
+
+test_files 'tags' tags_test_file
+exit

tree-sitter.json

@@ -12,6 +12,9 @@
       "highlights": [
         "queries/highlights.scm"
       ],
+      "tags": [
+        "queries/tags.scm"
+      ],
       "injection-regex": "^(hs|haskell)$"
     }
   ],