Fix VTAs wildcard inferred warning (#4492)

JordanMartinez · web-flow · commit 4afea2fbefee · 2023-07-25T07:01:28.000-07:00
The problem initially arises when we convert the [`ExprVisibleApp` (CST value) into `VisibleTypeApp` (AST value)](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/CST/Convert.hs#L338-L340). Using [`convertType`](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/CST/Convert.hs#L122-L123), whenever we come across a wildcard, we always convert the resulting value into an `UnnamedWildcard`. Later, [right before we typecheck a module's declarations](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/TypeChecker.hs#L614), we update all `UnnamedWildcard` to `IgnoreWildcard` if they appear in a specific context via [`ignoreWildcardsUnderCompleteTypeSignatures`](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Linter/Wildcards.hs#L10-L47). Because Visible Type Applications are a separate concept, they aren't converted here. Presumably, while typechecking, the compiler emits a warning for each `UnnamedWildcard` found, which produces the issue. Thus, there are two ways to resolve this: 1. (this PR) we update `convertType` to take another arg indicating whether it was called while converting an `ExprVisibleApp` into a `VisibleTypeApp`. If it was, then convert any wildcards into `IgnoreWildcard` in the first place. This solves the root of the problem but any other usages of `convertType` don't have this special rule in place. 1. (not this PR) we update the `ignoreWildcards*` function to also account for `VisibleTypeApp`. This is a smaller change but comes at the cost of another traversal through the AST. AFAICT, `convertType` is only used in two other places, both of which I think aren't affected by this change: - [Ide/CaseSplit.hs](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Ide/CaseSplit.hs#L128) - [Interactive/Parser.hs](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Interactive/Parser.hs#L108) Lastly, we call into `convertType` via the conversion of `ExprVisibleApp` to `VisibleTypeApp`, However, `convertType` can also call `convertConstraint`, which calls `convertType`. Thus, `convertConstraint` needs to propagate the `withinVta` arg as well.
diff --git a/CHANGELOG.d/fix_vtas-wildcard-inferred.md b/CHANGELOG.d/fix_vtas-wildcard-inferred.md
@@ -0,0 +1,12 @@
+* Stop emitting warnings for wildcards in Visible Type Applications
+
+  Previously, the below usage of a wildcard (i.e. `_`) would
+  incorrectly cause the compiler to emit a warning.
+  
+  ```purs
+  f :: forall @a. a -> a
+  f = identity
+
+  x :: { x :: Int }
+  x = f @{ x :: _ } { x: 42 }
+  ```
diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs
@@ -98,7 +98,13 @@ ident :: Ident -> N.Ident
 ident = N.Ident . getIdent
 
 convertType :: String -> Type a -> T.SourceType
-convertType fileName = go
+convertType = convertType' False
+
+convertVtaType :: String -> Type a -> T.SourceType
+convertVtaType = convertType' True
+
+convertType' :: Bool -> String -> Type a -> T.SourceType
+convertType' withinVta fileName = go
   where
   goRow (Row labels tl) b = do
     let
@@ -120,7 +126,7 @@ convertType fileName = go
     TypeConstructor _ a ->
       T.TypeConstructor (sourceQualName fileName a) $ qualified a
     TypeWildcard _ a ->
-      T.TypeWildcard (sourceAnnCommented fileName a a) T.UnnamedWildcard
+      T.TypeWildcard (sourceAnnCommented fileName a a) $ if withinVta then T.IgnoredWildcard else T.UnnamedWildcard
     TypeHole _ a ->
       T.TypeWildcard (sourceName fileName a) . T.HoleWildcard . getIdent $ nameValue a
     TypeString _ a b ->
@@ -182,7 +188,7 @@ convertType fileName = go
       Env.tyFunction $> sourceAnnCommented fileName a a
     TypeConstrained _ a _ b -> do
       let
-        a' = convertConstraint fileName a
+        a' = convertConstraint withinVta fileName a
         b' = go b
         ann = Pos.widenSourceAnn (T.constraintAnn a') (T.getAnnForType b')
       T.ConstrainedType ann a' b'
@@ -195,13 +201,13 @@ convertType fileName = go
         ann = uncurry (sourceAnnCommented fileName) rng
       T.setAnnForType ann $ Env.kindRow a'
 
-convertConstraint :: String -> Constraint a -> T.SourceConstraint
-convertConstraint fileName = go
+convertConstraint :: Bool -> String -> Constraint a -> T.SourceConstraint
+convertConstraint withinVta fileName = go
   where
   go = \case
     cst@(Constraint _ name args) -> do
       let ann = uncurry (sourceAnnCommented fileName) $ constraintRange cst
-      T.Constraint ann (qualified name) [] (convertType fileName <$> args) Nothing
+      T.Constraint ann (qualified name) [] (convertType' withinVta fileName <$> args) Nothing
     ConstraintParens _ (Wrapped _ c _) -> go c
 
 convertGuarded :: String -> Guarded a -> [AST.GuardedExpr]
@@ -337,7 +343,7 @@ convertExpr fileName = go
       positioned ann $ AST.App (go a) (go b)
     expr@(ExprVisibleTypeApp _ a _ b) -> do
       let ann = uncurry (sourceAnn fileName) $ exprRange expr
-      positioned ann $ AST.VisibleTypeApp (go a) (convertType fileName b)
+      positioned ann $ AST.VisibleTypeApp (go a) (convertVtaType fileName b)
     expr@(ExprLambda _ (Lambda _ as _ b)) -> do
       let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
       positioned ann
@@ -472,7 +478,7 @@ convertDeclaration fileName decl = case decl of
     pure $ AST.TypeClassDeclaration ann
       (nameValue name)
       (goTypeVar <$> vars)
-      (convertConstraint fileName <$> maybe [] (toList . fst) sup)
+      (convertConstraint False fileName <$> maybe [] (toList . fst) sup)
       (goFundep <$> maybe [] (toList . snd) fdeps)
       (goSig <$> maybe [] (NE.toList . snd) bd)
   DeclInstanceChain _ insts -> do
@@ -483,7 +489,7 @@ convertDeclaration fileName decl = case decl of
             clsAnn = findInstanceAnn cls args
         AST.TypeInstanceDeclaration ann' clsAnn chainId ix
           (mkPartialInstanceName nameSep cls args)
-          (convertConstraint fileName <$> maybe [] (toList . fst) ctrs)
+          (convertConstraint False fileName <$> maybe [] (toList . fst) ctrs)
           (qualified cls)
           (convertType fileName <$> args)
           (AST.ExplicitInstance $ goInstanceBinding <$> maybe [] (NE.toList . snd) bd)
@@ -497,7 +503,7 @@ convertDeclaration fileName decl = case decl of
         | otherwise = AST.DerivedInstance
       clsAnn = findInstanceAnn cls args
     pure $ AST.TypeInstanceDeclaration ann clsAnn chainId 0 name'
-      (convertConstraint fileName <$> maybe [] (toList . fst) ctrs)
+      (convertConstraint False fileName <$> maybe [] (toList . fst) ctrs)
       (qualified cls)
       (convertType fileName <$> args)
       instTy
diff --git a/tests/purs/warning/VTAsWildcardInferred.out b/tests/purs/warning/VTAsWildcardInferred.out
diff --git a/tests/purs/warning/VTAsWildcardInferred.purs b/tests/purs/warning/VTAsWildcardInferred.purs
@@ -0,0 +1,28 @@
+-- See https://github.com/purescript/purescript/issues/4487
+module Main where
+
+import Prelude
+import Effect (Effect)
+import Effect.Console (log)
+
+f :: forall @a. a -> a
+f = identity
+
+test1 :: { x :: Int }
+test1 = f @{ x :: _ } { x: 42 }
+
+class Foo :: Type -> Type -> Type -> Constraint
+class Foo a b c | a -> b c where
+  fooMember :: a -> b
+
+wrap :: forall @a. Array a -> Array (Array a)
+wrap as = [as]
+
+arrFooMember :: forall c. Array (Foo Int Boolean c => Int -> Boolean)
+arrFooMember = [fooMember]
+
+test2 :: forall c. Array (Array (Foo Int Boolean c => Int -> Boolean))
+test2 = wrap @(Foo Int Boolean _ => _) arrFooMember -- neither wildcard should warn IMO
+
+main :: Effect Unit
+main = log "Done"
