fix(haskell): highlight fixes (#5470)

* fix(haskell): highlight fixes + merge qualified/unqualified queries

* fix(haskell): lambda params + add exp_record to function.call args

* style: apply PR suggestions

queries/haskell/highlights.scm

@@ -1,14 +1,23 @@
 ;; ----------------------------------------------------------------------------
-;; Parameters
+;; Parameters and variables
 
 ;; NOTE: These are at the top, so that they have low priority,
 ;; and don't override destructured parameters 
 
-(function
+(variable) @variable
-  patterns: (patterns (pat_name) @parameter))
+(pat_wildcard) @variable
 
-(exp_lambda
+(function
-  (pat_name) @parameter)
+  patterns: (patterns (_) @parameter))
+
+(exp_lambda (_)+ @parameter "->")
+
+(function 
+  infix: (infix
+    lhs: (_) @parameter))
+(function 
+  infix: (infix
+    rhs: (_) @parameter))
 
 ;; ----------------------------------------------------------------------------
 ;; Literals and comments
@@ -121,6 +130,7 @@
 (qualified_type (module) @namespace)
 (qualified_variable (module) @namespace)
 (import (module) @namespace)
+(import (module) @constructor . (module))
 
 [
   (where)
@@ -151,26 +161,79 @@
 ;; ----------------------------------------------------------------------------
 ;; Functions and variables
 
-(variable) @variable
-(pat_wildcard) @variable
 (signature name: (variable) @function)
 ((signature name: (variable) @variable)
  (function 
   name: (variable) @_name
   rhs: [
    (exp_literal)
-   (exp_apply (exp_name (constructor)))
+   (exp_apply 
+     (exp_name 
+       [(constructor)
+        (variable)
+       ]))
    (quasiquote)
+   ((exp_name) . (operator))
   ])
  (#eq? @variable @_name))
+
+((signature name: (variable) @variable)
+ (function 
+  name: (variable) @_name
+  rhs: (exp_infix 
+    [
+     (exp_literal)
+     (exp_apply 
+       (exp_name 
+         [(constructor)
+          (variable)
+         ]))
+     (quasiquote)
+     ((exp_name) . (operator))
+    ]))
+ (#eq? @variable @_name))
+
+((signature name: (variable) @function)
+ (function 
+  name: (variable) @_name
+  patterns: (patterns))
+ (#eq? @function @_name))
+
+(signature 
+  name: (variable) @function
+  type: (fun))
+((signature 
+   name: (variable) @_name
+   type: (fun))
+ (function
+   name: (variable) @function)
+ (#eq? @function @_name))
+
 (function name: (variable) @function)
 (function 
   name: (variable) @variable
   rhs: [
    (exp_literal)
-   (exp_apply (exp_name (constructor)))
+   (exp_apply 
+     (exp_name 
+       [(constructor)
+        (variable)
+       ]))
    (quasiquote)
+   ((exp_name) . (operator))
   ])
+(function 
+  name: (variable) @variable
+  rhs: (exp_infix [
+   (exp_literal)
+   (exp_apply 
+     (exp_name 
+       [(constructor)
+        (variable)
+       ]))
+   (quasiquote)
+   ((exp_name) . (operator))
+  ]))
 
 (function
   name: (variable) @function
@@ -186,59 +249,86 @@
 ((signature (variable) @_type (forall (context (fun)))) . (function (variable) @function) (#eq? @function @_type))
 
 ; consider infix functions as operators
-(exp_infix (variable) @operator)  
+(exp_infix [
-(exp_infix (qualified_variable (variable) @operator))
+  (variable) @operator
+  (qualified_variable (variable) @operator)
+])
 ; partially applied infix functions (sections) also get highlighted as operators
-(exp_section_right (variable) @operator) 
+(exp_section_right [
-(exp_section_right (qualified_variable (variable) @operator)) 
+  ((variable) @operator)
-(exp_section_left (variable) @operator)
+  (qualified_variable (variable) @operator)
-(exp_section_left (qualified_variable (variable) @operator))
+  ]) 
+(exp_section_left [
+  ((variable) @operator)
+  (qualified_variable (variable) @operator)
+  ])
 
 ; function calls with an infix operator
 ; e.g. func <$> a <*> b
-(exp_infix (exp_name) @function.call . (operator))
+(exp_infix 
-; qualified function calls with an infix operator
+  (exp_name 
-(exp_infix (exp_name 
+    [
-  (qualified_variable (
+      ((variable) @function.call)
-      (module) @namespace
+      (qualified_variable (
-      (variable) @function.call))) . (operator))
+        (module) @namespace
+        (variable) @function.call))
+    ])
+  . (operator))
 ; infix operators applied to variables
 ((exp_name (variable) @variable) . (operator))
 ((operator) . (exp_name (variable) @variable))
 ; function calls with infix operators
 ((exp_name (variable) @function.call) . (operator) @_op
- (#any-of? @_op "$" "<$>" ">>="))
+ (#any-of? @_op "$" "<$>" ">>=" "=<<"))
-; function composition, arrows
+; right hand side of infix operator
-((exp_name (variable) @function) . (operator) @_op
+((exp_infix 
- (#any-of? @_op "." ">>>"))
+   [(operator)(variable)] ; infix or `func`
-((operator) @_op (exp_name (variable) @function)
+  . (exp_name [
- (#any-of? @_op "." ">>>"))
+      ((variable) @function.call)
-        
+      (qualified_variable (variable) @function.call)
-        
+    ])) . (operator) @_op
-(exp_apply . (exp_name (variable) @function.call))
+ (#any-of? @_op "$" "<$>" "=<<"))
-(exp_apply . (exp_name (qualified_variable (variable) @function.call)))
+; function composition, arrows, monadic composition (rhs)
-
+((exp_name [
-; let/where bindings
+  ((variable) @function)
-(_ (decls (function name: (variable) @variable)))
+  (qualified_variable (variable) @function)
-(_ (decls 
+ ]) . (operator) @_op
-  (function 
+ (#any-of? @_op "." ">>>" "***" ">=>" "<=<"))
-    name: (variable) @function
+; right hand side of infix operator
-    patterns: (patterns (pat_name) @parameter))))
+((exp_infix 
-
+   [(operator)(variable)] ; infix or `func`
-; higher-order function parameters
+  . (exp_name [
-(function
+      ((variable) @function)
-  patterns: (patterns (pat_name (variable) @function))
+      (qualified_variable (variable) @function)
-  rhs: (exp_apply (exp_name (variable) @_name) . (exp_name)+)
+    ])) . (operator) @_op
-  (#eq? @function @_name))
+ (#any-of? @_op "." ">>>" "***" ">=>" "<=<"))
-(function
+; function composition, arrows, monadic composition (rhs)
-  patterns: (patterns (pat_name (variable) @function))
+((operator) @_op . (exp_name [
-  rhs: (_ (operator) @_op (exp_name (variable))
+  ((variable) @function)
- (#any-of? @_op "." ">>>")))
+  (qualified_variable (variable) @function)
-(function
+ ])
-  patterns: (patterns (pat_name (variable) @function))
+ (#any-of? @_op "." ">>>" "***" ">=>" "<=<" ))
-  rhs: (_ (exp_name (variable)) . (operator) @_op)
- (#any-of? @_op "$" "<$>" ">>=" "." ">>>"))
         
+(exp_apply (exp_name 
+  [
+    ((variable) @function.call)
+    (qualified_variable (variable) @function.call)
+  ]))
+(exp_apply [
+    (exp_name [
+      (variable)
+      (qualified_variable (variable))
+      (constructor)
+      (qualified_constructor (constructor))
+    ])
+    (exp_type_application)
+    (exp_parens)
+    (exp_record)
+  ]
+  . (exp_name [
+    ((variable) @variable)
+    (qualified_variable (variable) @variable)
+  ]))
 
 ;; ----------------------------------------------------------------------------
 ;; Types
@@ -263,6 +353,12 @@
 (quasiquote 
   (quoter) @_name (#eq? @_name "qq")
   (quasiquote_body) @string)
+;; namespaced quasi-quoter
+(quasiquote
+  (_
+    (module) @namespace
+    . (variable) @function.call
+  ))
 
 ; Highlighting of quasiquote_body for other languages is handled by injections.scm
 
@@ -294,7 +390,8 @@
    "bracket_"
    "bracketOnErrorSource"
    "finally"
-   "onException"))
+   "onException"
+   "expectationFailure"))
 
 ;; ----------------------------------------------------------------------------
 ;; Debugging
@@ -321,6 +418,9 @@
 ;; ----------------------------------------------------------------------------
 ;; Fields
 (field (variable) @field)
+(pat_field (variable) @field)
+(exp_projection field: (variable) @field)
+(import_item (type) . (import_con_names (variable) @field))
 
 
 ;; ----------------------------------------------------------------------------

tests/query/highlights/haskell/test.hs

@@ -20,6 +20,11 @@ import qualified Data.Map as Map
                            -- ^ @namespace
 import qualified Chronos
                 -- ^ @namespace
+import qualified Chronos as C
+                -- ^ @constructor
+                         -- ^ @namespace
+import FooMod (BarTy (barField))
+                      -- ^ @field
 
 data ADT
 -- ^ @keyword
@@ -32,6 +37,10 @@ data ADT
   -- ^ @keyword
          -- ^ @type
                -- ^ @type
+mkA x = A x
+       -- ^ @variable
+mkAQualified x = SomeModule.A x
+                           -- ^ @variable
 
 class Ord a => PartialOrd a
     -- ^ @type
@@ -56,6 +65,10 @@ newtype Rec
  -- ^ @punctuation.bracket
     deriving Eq
            -- ^ @type
+recordWildCard Rec { field } = field
+                    -- ^ @field
+recordDotSyntax rec = rec.field
+                        -- ^ @field
 
 main :: IO ()
 -- ^ @function
@@ -76,6 +89,10 @@ someFunc0 x = someFunc1 x
     someFunc1 _ = 5
     -- ^ @function
                -- ^ @number
+scopedTypeParam (x :: Int) = someFunc x
+              -- ^ @parameter
+scopedTypeParam (Just x :: Int) = someFunc x
+                   -- ^ @parameter
 
 someInfix :: Integral a => a -> Double
             -- ^ @type
@@ -88,12 +105,36 @@ someInfix x = fromIntegral x `myAdd` floatVal
                              -- ^ @operator
                                     -- ^ @variable
   where
+    myAdd :: Num a => a -> a
+    -- ^ @function
     myAdd x y = x + y
              -- ^ @variable
                  -- ^ @variable
+    floatVal :: Double
+    -- ^ @variable
     floatVal = 5.5
     -- ^ @variable
             -- ^ @float
+    intVal :: Int
+    -- ^ @variable
+    intVal = getInt 5
+    -- ^ @variable
+    boolVal :: Bool
+    -- ^ @variable
+    boolVal = bool False True $ 1 + 2 == 3
+    -- ^ @variable
+    isInt :: Either Double Int -> Bool
+    -- ^ @function
+    isInt eith@Left{} = False
+        -- ^ @parameter
+    isInt eith@(Left x) = False
+    -- ^ @function
+                  -- ^ @parameter
+    isInt (Left x) = False
+             -- ^ @parameter
+    isInt (Right _) = True
+    -- ^ @function
+
 
 someIOaction :: IO ()
 -- ^ @function
@@ -104,6 +145,8 @@ someIOaction = do
             -- ^ @namespace
                    -- ^ @function.call
                           -- ^ @operator
+  _ <- someFunc0 =<< someIOAction
+        -- ^ @function.call
   let bar = SomeModule.doSomething $ "a" "b"
     -- ^ @variable
             -- ^ @namespace
@@ -114,6 +157,15 @@ someIOaction = do
         -- ^ @parameter
               -- ^ @variable
                   -- ^ @variable
+      gunc x y = func x $ y + 7
+                   -- ^ @variable
+                       -- ^ @variable
+  when foo $ putStrLn $ T.showt =<< bar
+ -- ^ @function.call
+     -- ^ @variable
+            -- ^ @function.call
+                        -- ^ @function.call
+
   pure $ func 1 2
   -- ^ @function.call
         -- ^ @function.call
@@ -132,6 +184,12 @@ getLambda x = \y -> x `SomeModule.someInfix` y
             -- ^ @parameter
                       -- ^ @namespace
                                   -- ^ @operator
+lambdaTyped = \(y :: Int) -> x
+             -- ^ @parameter
+lambdaPattern = \(Just x) -> x
+                    -- ^ @parameter
+lambdaPatternTyped = \(Just x :: Int) -> x
+                         -- ^ @parameter
 
 isVowel = (`elem` "AEIOU")
           -- ^ @operator
@@ -149,13 +207,71 @@ quasiQuotedString = [qq|Some string|]
 -- ^ @variable
                    -- ^ @function.call
                       -- ^ @string
-
+quasiQuotedString2 = [SomeModule.qq|Some string|]
-higherOrderFn f x = f x
+                        -- ^ @namespace
-           -- ^ @function
+                              -- ^ @function.call
-             -- ^ @variable
 
 composition f g = f . g
-         -- ^ @function
-           -- ^ @function
                -- ^ @function
                    -- ^ @function
+qualifiedComposition = SomeModule.f . SomeModule.g
+                               -- ^ @function
+                                              -- ^ @function
+takeMVarOrThrow = evaluate <=< takeMVar
+                  -- ^ @function
+                              -- ^ @function
+modifyMVarOrThrow v f = modifyMVar v $ f >=> evaluate
+                                -- ^ @variable
+                                    -- ^ @function
+                                           -- ^ @function
+assertNonEmpty xs = xs `shouldSatisfy` not . null
+                 -- ^ @variable
+                                     -- ^ @function
+                                            -- ^ @function
+
+param1 |*| param2 = Qu $ param1 * param2
+-- ^ @parameter
+         -- ^ @parameter
+(param1 :: Int) |*| (param2 :: Int) = Qu $ param1 * param2
+-- ^ @parameter
+                   -- ^ @parameter
+(Qu a) |/| (SomeModule.Qu b) = a / b
+ -- ^ @parameter
+                       -- ^ @parameter
+(Qu a :: Int) |/| (SomeModule.Qu b :: Int) = a / b
+ -- ^ @parameter
+                              -- ^ @parameter
+(Qu a, b, c :: Int) |/| x = undefined
+ -- ^ @parameter
+    -- ^ @parameter
+       -- ^ @parameter
+[Qu a, b, c :: Int] >< x = undefined
+ -- ^ @parameter
+    -- ^ @parameter
+       -- ^ @parameter
+listParam [a, b :: Int, Just c] = undefined
+        -- ^ @parameter
+           -- ^ @parameter
+                          -- ^ @parameter
+tupleParam (a :: Int, b, Just c) = undefined
+         -- ^ @parameter
+                   -- ^ @parameter
+                           -- ^ @parameter
+listLambda = \[a, a :: Int, Just c] -> undefined
+            -- ^ @parameter
+               -- ^ @parameter
+                              -- ^ @parameter
+tupleLambda = \(a, b :: Int, Just c) -> undefined
+             -- ^ @parameter
+                -- ^ @parameter
+nestedDestructure (Left (Just a)) = undefined
+                           -- ^ @parameter
+typeApplication x y = someFun @ty x y
+                               -- ^ @variable
+                                 -- ^ @variable
+encrypt key pass = encrypt (defaultOAEPParams SHA1) key pass
+                                                 -- ^ @variable
+                                                      -- ^ @variable
+recordUpdate x y rec = someFun rec {field = 5} x y
+                                            -- ^ @variable
+                                              -- ^ @variable