From 5e287905425e45feb548b6103a805b01da18131c Mon Sep 17 00:00:00 2001
From: Marc Jakobi <marc.jakobi@tiko.energy>
Date: Tue, 7 May 2024 19:13:12 +0200
Subject: [PATCH] chore!(queries): adjust queries for tree-sitter-haskell
 rewrite

---
 lua/neotest-haskell/runner.lua                |   4 +-
 nix/ci-overlay.nix                            |  57 ++++-
 queries/haskell/hspec-positions.scm           |  94 ++++-----
 queries/haskell/sydtest-positions.scm         |  61 ++----
 queries/haskell/tasty-positions.scm           | 197 ++++++++----------
 .../multi-package/tasty-pkg/test/Spec.hs      |   4 +
 .../tree-sitter-haskell-scm-1.rockspec        |  31 +++
 7 files changed, 246 insertions(+), 202 deletions(-)
 create mode 100644 spec/fixtures/tree-sitter-haskell-scm-1.rockspec

diff --git a/lua/neotest-haskell/runner.lua b/lua/neotest-haskell/runner.lua
index 1a5b665..e544510 100644
--- a/lua/neotest-haskell/runner.lua
+++ b/lua/neotest-haskell/runner.lua
@@ -48,14 +48,14 @@ local function mk_module_query(modules)
   for i, module_name in ipairs(modules) do
     local filter = ([[
     ;;query
-    (module) @mod%d
+    (module_id) @mod%d
     (#eq? @mod%d "%s")
     ]]):format(i, i, module_name)
     table.insert(filters, filter)
   end
   return [[
   ;;query
-  (qualified_module
+  (module
   ]] .. table.concat(filters, '\n') .. [[
   ;;query
   )
diff --git a/nix/ci-overlay.nix b/nix/ci-overlay.nix
index a56d0ae..f131005 100644
--- a/nix/ci-overlay.nix
+++ b/nix/ci-overlay.nix
@@ -55,6 +55,55 @@
         disabled = luaOlder "5.1";
         propagatedBuildInputs = [lua nvim-nio plenary-nvim];
       }) {};
+
+    luarocks-build-treesitter-parser = luaself.callPackage ({
+      buildLuarocksPackage,
+      luaOlder,
+      luafilesystem,
+      fetchurl,
+      fetchzip,
+      lua,
+      ...
+    }:
+      buildLuarocksPackage {
+        pname = "luarocks-build-treesitter-parser";
+        version = "2.0.0-1";
+        knownRockspec =
+          (fetchurl {
+            url = "mirror://luarocks/luarocks-build-treesitter-parser-2.0.0-1.rockspec";
+            sha256 = "0ylax1r0yl5k742p8n0fq5irs2r632npigqp1qckfx7kwi89gxhb";
+          })
+          .outPath;
+        src = fetchzip {
+          url = "https://github.com/nvim-neorocks/luarocks-build-treesitter-parser/archive/v2.0.0.zip";
+          sha256 = "0gqiwk7dk1xn5n2m0iq5c7xkrgyaxwyd1spb573l289gprvlrbn5";
+        };
+
+        disabled = luaOlder "5.1";
+        propagatedBuildInputs = [lua luafilesystem];
+      }) {};
+
+    tree-sitter-haskell = luaself.callPackage (
+      {
+        buildLuarocksPackage,
+        fetchurl,
+        fetchzip,
+        luarocks-build-treesitter-parser,
+        ...
+      }:
+        buildLuarocksPackage {
+          pname = "tree-sitter-haskell";
+          version = "scm-1";
+          knownRockspec = self + "/spec/fixtures/tree-sitter-haskell-scm-1.rockspec";
+          src = fetchzip {
+            url = "https://github.com/tree-sitter/tree-sitter-haskell/archive/e29c59236283198d93740a796c50d1394bccbef5.zip";
+            sha256 = "03mk4jvlg2l33xfd8p2xk1q0xcansij2sfa98bdnhsh8ac1jm30h";
+          };
+          propagatedBuildInputs = [
+            luarocks-build-treesitter-parser
+          ];
+        }
+    ) {};
   };
 
   lua5_1 = prev.lua5_1.override {
@@ -63,6 +112,12 @@
 
   lua51Packages = prev.lua51Packages // final.lua5_1.pkgs;
 
+  tree-sitter-haskell-plugin = final.neovimUtils.buildNeovimPlugin {
+    pname = "tree-sitter-haskell";
+    version = "scm";
+    src = final.lua51Packages.tree-sitter-haskell.src;
+  };
+
   mkNeorocksTest = {
     name,
     nvim ? final.neovim-unwrapped,
@@ -73,7 +128,7 @@
           start = with final.vimPlugins; [
             final.neotest-haskell-dev # Queries need to be on the rtp
             plenary-nvim # XXX: This needs to be on the nvim rtp
-            (nvim-treesitter.withPlugins (p: [p.haskell])) # TODO: replace with tree-sitter-haskell
+            tree-sitter-haskell-plugin
           ];
         };
       };
diff --git a/queries/haskell/hspec-positions.scm b/queries/haskell/hspec-positions.scm
index c4d6ca2..ac000dc 100644
--- a/queries/haskell/hspec-positions.scm
+++ b/queries/haskell/hspec-positions.scm
@@ -1,55 +1,43 @@
-;; describe (unqualified)
-(_ (_ (exp_apply
-  (exp_name (variable) @func_name)
-  (exp_literal) @namespace.name
-)
-(#any-of? @func_name
-  "describe"
-  "xdescribe"
-  "context"
-  "xcontext"
-)
-)) @namespace.definition
+;; describe
+(_ (_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @namespace.name)
+  (#any-of? @_func_name
+    "describe"
+    "xdescribe"
+    "context"
+    "xcontext"
+  ))) @namespace.definition
 
-;; describe (qualified)
-(_ (_ (exp_apply
-  (exp_name (qualified_variable (variable) @func_name))
-  (exp_literal) @namespace.name
-)
-(#any-of? @func_name
-  "describe"
-  "xdescribe"
-  "context"
-  "xcontext"
-)
-)) @namespace.definition
+;; test
+((expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#any-of? @_func_name
+    "it"
+    "xit"
+    "prop"
+    "xprop"
+    "specify"
+    "xspecify")) @test.definition
 
-;; test (unqualified)
-((exp_apply
-  (exp_name (variable) @func_name)
-  (exp_literal) @test.name
-)
-(#any-of? @func_name
-  "it"
-  "xit"
-  "prop"
-  "xprop"
-  "specify"
-  "xspecify"
-)
-) @test.definition
-
-;; test (qualified)
-((exp_apply
-  (exp_name (qualified_variable (variable) @func_name))
-  (exp_literal) @test.name
-)
-(#any-of? @func_name
-  "it"
-  "xit"
-  "prop"
-  "xprop"
-  "specify"
-  "xspecify"
-)
-) @test.definition
+;; test
+(_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#any-of? @_func_name
+    "it"
+    "xit"
+    "prop"
+    "xprop"
+    "specify"
+    "xspecify")) @test.definition
diff --git a/queries/haskell/sydtest-positions.scm b/queries/haskell/sydtest-positions.scm
index 131752c..294ecf4 100644
--- a/queries/haskell/sydtest-positions.scm
+++ b/queries/haskell/sydtest-positions.scm
@@ -1,43 +1,22 @@
-;; NOTE: The sydtest runner inclides all queries for hspec, too.
+;; NOTE: The sydtest runner includes all queries for hspec, too.
 
 ;; test (unqualified)
-((exp_apply
-  (exp_name (variable) @func_name)
-  (exp_literal) @test.name
-)
-(#any-of? @func_name
-  "itWithOuter"
-  "xitWithOuter"
-  "itWithBoth"
-  "xitWithBoth"
-  "itWithAll"
-  "xitWithAll"
-  "specifyWithOuter"
-  "xspecifyWithOuter"
-  "specifyWithBoth"
-  "xspecifyWithBoth"
-  "specifyWithAll"
-  "xspecifyWithAll"
-)
-) @test.definition
-
-;; test (qualified)
-((exp_apply
-  (exp_name (qualified_variable (variable) @func_name))
-  (exp_literal) @test.name
-)
-(#any-of? @func_name
-  "itWithOuter"
-  "xitWithOuter"
-  "itWithBoth"
-  "xitWithBoth"
-  "itWithAll"
-  "xitWithAll"
-  "specifyWithOuter"
-  "xspecifyWithOuter"
-  "specifyWithBoth"
-  "xspecifyWithBoth"
-  "specifyWithAll"
-  "xspecifyWithAll"
-)
-) @test.definition
+((expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#any-of? @_func_name
+    "itWithOuter"
+    "xitWithOuter"
+    "itWithBoth"
+    "xitWithBoth"
+    "itWithAll"
+    "xitWithAll"
+    "specifyWithOuter"
+    "xspecifyWithOuter"
+    "specifyWithBoth"
+    "xspecifyWithBoth"
+    "specifyWithAll"
+    "xspecifyWithAll")) @test.definition
diff --git a/queries/haskell/tasty-positions.scm b/queries/haskell/tasty-positions.scm
index 4e2b826..767f71b 100644
--- a/queries/haskell/tasty-positions.scm
+++ b/queries/haskell/tasty-positions.scm
@@ -1,115 +1,102 @@
-;; NOTE: The tasty runner inclides all queries for hspec, too.
+;; NOTE: The tasty runner includes all queries for hspec, too.
 
-(_
-  (exp_name) @func_name
-  (#lua-match? @func_name "^.*testGroup")
-  (exp_literal (string) @namespace.name)
-  (exp_list (_))
-) @namespace.definition
+(_ 
+  function: (expression/apply
+    function: [
+      (variable) @_func_name
+      (qualified id: (variable) @_func_name)
+    ]
+    (#lua-match? @_func_name "^.*testGroup")
+    argument: (literal) @namespace.name)
+ argument: (list)) @namespace.definition
 
-;; describe (unqualified)
-(_ (_ (exp_apply
-  (exp_name (variable) @func_name)
-  (exp_literal) @namespace.name
-)
-(#match? @func_name
-  "testSpec"
-)
-)) @namespace.definition
+;; testSpec
+(_ (_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @namespace.name)
+  (#match? @_func_name "testSpec"))) @namespace.definition
 
-;; describe (qualified)
-(_ (_ (exp_apply
-  (exp_name (qualified_variable (variable) @func_name))
-  (exp_literal) @namespace.name
-)
-(#match? @func_name
-  "testSpec"
-)
-)) @namespace.definition
+;; smallcheck/quickcheck/hedgehog
+((_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)) @test.definition
+  (#lua-match? @_func_name "^.*testProperty.*"))
 
-;; smallcheck/quickcheck/hedgehog (qualified or unqualified)
-(
-(exp_apply
-  (exp_name) @func_name
-  (exp_literal) @test.name
+;; expectFail
+((variable) @_func_name
+(expression/apply
+  argument: [
+    (variable) @test.name
+    (qualified id: (variable) @test.name)
+  ]
 ) @test.definition
-(#lua-match? @func_name "^.*testProperty.*")
-)
+(#lua-match? @_func_name "^.*expectFail"))
 
-;; expectFail (qualified or unqualified)
-(
-(exp_name) @func_name
-(exp_apply
-  (exp_name)
-  (exp_literal) @test.name
-) @test.definition
-(#lua-match? @func_name "^.*expectFail")
-)
-
-;; HUnit (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*testCase")
-    (exp_literal) @test.name
-  ) @test.definition
-)
+;; HUnit
+((_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#lua-match? @_func_name "^.*testCase")
+  ) @test.definition)
 
 ;; Program (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*testProgram")
-    (exp_literal) @test.name
-  ) @test.definition
-)
+((_ (_ (_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#lua-match? @_func_name "^.*testProgram")
+  ))) @test.definition)
+
+
+;; Wai
+((_ (expression/apply
+  function: (expression/apply
+    function: [
+      (variable) @_func_name
+      (qualified id: (variable) @_func_name)
+    ]
+    (#lua-match? @_func_name "^.*testWai"))
+  argument: (expression/literal) @test.name)) @test.definition)
+
+;; tasty-golden
+((_ (_ (_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#any-of? @_func_name
+    "goldenVsFile"
+    "goldenVsStringDiff"
+    "postCleanup")))) @test.definition)
 
-;; Wai (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*testWai")
-    (exp_literal) @test.name
-  ) @test.definition
-)
+;; tasty-golden
+((_ (_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#any-of? @_func_name
+    "goldenVsString"))) @test.definition)
 
-;; tasty-golden goldenVsFile (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*goldenVsFile")
-    (exp_literal) @test.name
-  ) @test.definition
-)
-;; tasty-golden goldenVsFileDiff (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*goldenVsFileDiff")
-    (exp_literal) @test.name
-  ) @test.definition
-)
-;; tasty-golden goldenVsString (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*goldenVsString")
-    (exp_literal) @test.name
-  ) @test.definition
-)
-;; tasty-golden goldenVsStringDiff (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*goldenVsStringDiff")
-    (exp_literal) @test.name
-  ) @test.definition
-)
-;; tasty-golden postCleanup (qualified or unqualified)
-(_
-  (exp_apply
-    (exp_name) @func_name
-    (#lua-match? @func_name "^.*postCleanup")
-    (exp_literal) @test.name
-  ) @test.definition
-)
+;; tasty-golden
+((_ (_ (_ (_ (expression/apply
+  function: [
+    (variable) @_func_name
+    (qualified id: (variable) @_func_name)
+  ]
+  argument: (expression/literal) @test.name)
+  (#any-of? @_func_name
+    "goldenVsFileDiff"))))) @test.definition)
diff --git a/spec/fixtures/tasty/cabal/multi-package/tasty-pkg/test/Spec.hs b/spec/fixtures/tasty/cabal/multi-package/tasty-pkg/test/Spec.hs
index 3054c56..37143f0 100644
--- a/spec/fixtures/tasty/cabal/multi-package/tasty-pkg/test/Spec.hs
+++ b/spec/fixtures/tasty/cabal/multi-package/tasty-pkg/test/Spec.hs
@@ -46,6 +46,7 @@ scProps = testGroup "(checked by SmallCheck)"
   , SC.testProperty "Fermat's little theorem" $
       \x -> ((x :: Integer)^7 - x) `mod` 7 == 0
   -- the following property does not hold
+  -- TODO: Add test case for parens instead of $
   , SC.testProperty "Fermat's last theorem" $
       \x y z n ->
         (n :: Integer) >= 3 SC.==> x^n + y^n /= (z^n :: Integer)
@@ -83,6 +84,7 @@ hedgehogProps = testGroup "Hedgehog tests"
   [ H.testProperty
       "reverse involutive"
       prop_reverse_involutive
+  -- TODO: Add test case for parens instead of $
   , expectFail $ H.testProperty
       "badReverse involutive fails"
       prop_badReverse_involutive
@@ -113,6 +115,7 @@ programTests = testGroup "Compilation with GHC"
   ]
 
 waiTests = testGroup "Tasty-Wai Tests"
+  -- TODO: Add cases without $
   [ testWai testApp "Hello to World" $ do
       res <- get "hello"
       assertBody "world!" res
@@ -135,6 +138,7 @@ waiTests = testGroup "Tasty-Wai Tests"
       assertBody "no route" res
   ]
 
+-- TODO: Add test case for postCleanup
 goldenTests = testGroup "Golden tests"
   [ goldenVsFile "goldenVsFile" "/some/golden/file.txt" "/some/output/file.txt" (pure ())
   , goldenVsString "goldenVsString" "/some/golden/file.txt" (pure "")
diff --git a/spec/fixtures/tree-sitter-haskell-scm-1.rockspec b/spec/fixtures/tree-sitter-haskell-scm-1.rockspec
new file mode 100644
index 0000000..1c3e247
--- /dev/null
+++ b/spec/fixtures/tree-sitter-haskell-scm-1.rockspec
@@ -0,0 +1,31 @@
+local git_ref = 'e29c59236283198d93740a796c50d1394bccbef5'
+local modrev = 'scm'
+local specrev = '1'
+
+local repo_url = 'https://github.com/tree-sitter/tree-sitter-haskell'
+
+rockspec_format = '3.0'
+package = 'tree-sitter-haskell'
+version = modrev ..'-'.. specrev
+
+description = {
+  summary = 'tree-sitter parser and Neovim queries for haskell',
+  labels = { 'neovim', 'tree-sitter' } ,
+  homepage = 'https://github.com/tree-sitter/tree-sitter-haskell',
+  license = 'MIT'
+}
+
+build_dependencies = {
+  'luarocks-build-treesitter-parser >= 1.3.0',
+}
+
+source = {
+  url = repo_url .. '/archive/' .. git_ref .. '.zip',
+  dir = 'tree-sitter-haskell-' .. 'e29c59236283198d93740a796c50d1394bccbef5',
+}
+
+build = {
+  type = "treesitter-parser",
+  lang = "haskell",
+  sources = { "src/parser.c", "src/scanner.c" },
+}