purescript · natefaubion · Jan 13, 2019 · Dec 30, 2018 · Jan 1, 2019 · Jan 10, 2019
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -142,7 +142,7 @@ data SimpleErrorMessage
   | ShadowedTypeVar Text
   | UnusedTypeVar Text
   | WildcardInferredType SourceType Context
-  | HoleInferredType Text SourceType Context TypeSearch
+  | HoleInferredType Text SourceType Context (Maybe TypeSearch)
   | MissingTypeDeclaration Ident SourceType
   | OverlappingPattern [[Binder]] Bool
   | IncompleteExhaustivityCheck

diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -115,7 +115,7 @@ convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)])
 convertDeclaration (P.ValueDecl sa _ _ _ _) title =
   -- If no explicit type declaration was provided, insert a wildcard, so that
   -- the actual type will be added during type checking.
-  basicDeclaration sa title (ValueDeclaration (P.TypeWildcard ()))
+  basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () Nothing))
 convertDeclaration (P.ExternDeclaration sa _ ty) title =
   basicDeclaration sa title (ValueDeclaration (ty $> ()))
 convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title =

diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
@@ -31,8 +31,8 @@ import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind)
 typeLiterals :: Pattern () PrettyPrintType RenderedCode
 typeLiterals = mkPattern match
   where
-  match PPTypeWildcard =
-    Just (syntax "_")
+  match (PPTypeWildcard name) =
+    Just $ maybe (syntax "_") (syntax . ("?" <>)) name
   match (PPTypeVar var) =
     Just (typeVar var)
   match (PPRecord row) =

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -296,7 +296,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
   gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
   gSimple (OrphanInstance nm cl noms ts) = OrphanInstance nm cl noms <$> traverse f ts
   gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
-  gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx  <*> onTypeSearchTypesM f env
+  gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx  <*> traverse (onTypeSearchTypesM f) env
   gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
   gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty
   gSimple other = pure other
@@ -852,7 +852,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
       let
         maxTSResults = 15
         tsResult = case ts of
-          (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) ->
+          Just (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) ->
             let
               formatTS (names, types) =
                 let
@@ -1461,6 +1461,9 @@ withPosition pos (ErrorMessage hints se) = ErrorMessage (positionedError pos : h
 positionedError :: SourceSpan -> ErrorMessageHint
 positionedError = PositionedError . pure
 
+filterErrors :: (ErrorMessage -> Bool) -> MultipleErrors -> MultipleErrors
+filterErrors f = MultipleErrors . filter f . runMultipleErrors
+
 -- | Runs a computation listening for warnings and then escalating any warnings
 -- that match the predicate to error status.
 escalateWarningWhen

diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
@@ -52,7 +52,7 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors
     encodeRebuildError err = case err of
       (P.ErrorMessage _
        ((P.HoleInferredType name _ _
-         (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields})))) ->
+         (Just (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields}))))) ->
         insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error err))
       _ ->
         (toJSON . toJSONError False P.Error) err

diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
@@ -37,7 +37,10 @@ parseTypeLevelString :: TokenParser SourceType
 parseTypeLevelString = withSourceAnnF $ flip TypeLevelString <$> stringLiteral
 
 parseTypeWildcard :: TokenParser SourceType
-parseTypeWildcard = withSourceAnnF $ underscore $> TypeWildcard
+parseTypeWildcard = withSourceAnnF $ do
+  name <- Just <$> holeLit
+      <|> Nothing <$ underscore
+  return $ flip TypeWildcard name
 
 parseTypeVariable :: TokenParser SourceType
 parseTypeVariable = withSourceAnnF $ do

diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
@@ -45,7 +45,7 @@ data PrettyPrintType
   = PPTUnknown Int
   | PPTypeVar Text
   | PPTypeLevelString PSString
-  | PPTypeWildcard
+  | PPTypeWildcard (Maybe Text)
   | PPTypeConstructor (Qualified (ProperName 'TypeName))
   | PPTypeOp (Qualified (OpName 'TypeOpName))
   | PPSkolem Text Int
@@ -68,7 +68,7 @@ convertPrettyPrintType = go
   go (TUnknown _ n) = PPTUnknown n
   go (TypeVar _ t) = PPTypeVar t
   go (TypeLevelString _ s) = PPTypeLevelString s
-  go (TypeWildcard _) = PPTypeWildcard
+  go (TypeWildcard _ n) = PPTypeWildcard n
   go (TypeConstructor _ c) = PPTypeConstructor c
   go (TypeOp _ o) = PPTypeOp o
   go (Skolem _ t n _) = PPSkolem t n
@@ -161,7 +161,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
   where
     typeLiterals :: Pattern () PrettyPrintType Box
     typeLiterals = mkPattern match where
-      match PPTypeWildcard = Just $ text "_"
+      match (PPTypeWildcard name) = Just $ maybe (text "_") (text . ('?' :) . T.unpack) name
       match (PPTypeVar var) = Just $ text $ T.unpack var
       match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
       match (PPRecord row) = Just $ prettyPrintRowWith tro '{' '}' row

diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -427,7 +427,7 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do
     argument' = App (Constructor ss argument)
 
 checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m ()
-checkIsWildcard _ _ (TypeWildcard _) = return ()
+checkIsWildcard _ _ (TypeWildcard _ Nothing) = return ()
 checkIsWildcard ss tyConNm _ =
   throwError . errorMessage' ss $ ExpectedWildcard tyConNm
 

diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -16,10 +16,10 @@ import Control.Monad (when, unless, void, forM)
 import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.State.Class (MonadState(..), modify, gets)
 import Control.Monad.Supply.Class (MonadSupply)
-import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Writer.Class (MonadWriter(..), censor)
 
 import Data.Foldable (for_, traverse_, toList)
-import Data.List (nub, nubBy, (\\), sort, group)
+import Data.List (nub, nubBy, (\\), sort, group, intersect)
 import Data.Maybe
 import Data.Text (Text)
 import qualified Data.List.NonEmpty as NEL
@@ -274,12 +274,13 @@ typeCheckAll moduleName _ = traverse go
     internalError "Type declarations should have been removed before typeCheckAlld"
   go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do
     env <- getEnv
-    warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) $ do
+    warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) . censorLocalUnnamedWildcards val $ do
       val' <- checkExhaustiveExpr ss env moduleName val
       valueIsNotDefined moduleName name
       [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')]
       addValue moduleName name ty nameKind
       return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
+    where
   go ValueDeclaration{} = internalError "Binders were not desugared"
   go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared"
   go (BindingGroupDeclaration vals) = do
@@ -464,6 +465,21 @@ typeCheckAll moduleName _ = traverse go
     | moduleName `S.member` nonOrphanModules = return ()
     | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules tys'
 
+  censorLocalUnnamedWildcards :: Expr -> m a -> m a
+  censorLocalUnnamedWildcards (TypedValue _ _ ty) = censor (filterErrors (not . isLocalUnnamedWildcardError ty))
+  censorLocalUnnamedWildcards _ = id
+
+  isLocalUnnamedWildcardError :: SourceType -> ErrorMessage -> Bool
+  isLocalUnnamedWildcardError ty err@(ErrorMessage _ (WildcardInferredType _ _)) =
+    let
+      ssWildcard (TypeWildcard (ss', _) Nothing) = [ss']
+      ssWildcard _ = []
+      sssWildcards = everythingOnTypes (<>) ssWildcard ty
+      sss = maybe [] NEL.toList $ errorSpan err
+    in
+      null $ intersect sss sssWildcards
+  isLocalUnnamedWildcardError _ _ = False
+
   -- |
   -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
   -- extracted from the kind of the type constructor itself.

diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -239,7 +239,7 @@ infer' other = (, []) <$> go other
     k' <- go ty
     unifyKinds k k'
     return k'
-  go (TypeWildcard ann) = freshKind ann
+  go (TypeWildcard ann _) = freshKind ann
   go (TUnknown ann _) = freshKind ann
   go (TypeLevelString ann _) = return $ kindSymbol $> ann
   go (TypeVar ann v) = do

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -151,12 +151,12 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
       -> ErrorMessage
       -> ErrorMessage
     runTypeSearch cons st = \case
-      ErrorMessage hints (HoleInferredType x ty y (TSBefore env)) ->
+      ErrorMessage hints (HoleInferredType x ty y (Just (TSBefore env))) ->
         let subst = checkSubstitution st
             searchResult = onTypeSearchTypes
               (substituteType subst)
               (uncurry TSAfter (typeSearch cons env st (substituteType subst ty)))
-        in ErrorMessage hints (HoleInferredType x ty y searchResult)
+        in ErrorMessage hints (HoleInferredType x ty y (Just searchResult))
       other -> other
 
     -- | Generalize type vars using forall and add inferred constraints
@@ -415,7 +415,7 @@ infer' (Hole name) = do
   ty <- freshType
   ctx <- getLocalContext
   env <- getEnv
-  tell . errorMessage $ HoleInferredType name ty ctx (TSBefore env)
+  tell . errorMessage $ HoleInferredType name ty ctx . Just $ TSBefore env
   return $ TypedValue True (Hole name) ty
 infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
   TypedValue t v ty <- infer' val

diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -184,10 +184,11 @@ replaceVarWithUnknown ident ty = do
 replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => SourceType -> m SourceType
 replaceTypeWildcards = everywhereOnTypesM replace
   where
-  replace (TypeWildcard ann) = do
+  replace (TypeWildcard ann name) = do
     t <- freshType
     ctx <- getLocalContext
-    warnWithPosition (fst ann) $ tell . errorMessage $ WildcardInferredType t ctx
+    let err = maybe (WildcardInferredType t ctx) (\n -> HoleInferredType n t ctx Nothing) name
+    warnWithPosition (fst ann) $ tell $ errorMessage err
     return t
   replace other = return other
 

diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
@@ -58,7 +58,7 @@ data Type a
   -- | A type-level string
   | TypeLevelString a PSString
   -- | A type wildcard, as would appear in a partial type synonym
-  | TypeWildcard a
+  | TypeWildcard a (Maybe Text)
   -- | A type constructor
   | TypeConstructor a (Qualified (ProperName 'TypeName))
   -- | A type operator. This will be desugared into a type constructor during the
@@ -101,7 +101,7 @@ srcTypeLevelString :: PSString -> SourceType
 srcTypeLevelString = TypeLevelString NullSourceAnn
 
 srcTypeWildcard :: SourceType
-srcTypeWildcard = TypeWildcard NullSourceAnn
+srcTypeWildcard = TypeWildcard NullSourceAnn Nothing
 
 srcTypeConstructor :: Qualified (ProperName 'TypeName) -> SourceType
 srcTypeConstructor = TypeConstructor NullSourceAnn
@@ -195,8 +195,8 @@ typeToJSON annToJSON ty =
       variant "TypeVar" a b
     TypeLevelString a b ->
       variant "TypeLevelString" a b
-    TypeWildcard a ->
-      nullary "TypeWildcard" a
+    TypeWildcard a b ->
+      variant "TypeWildcard" a b
     TypeConstructor a b ->
       variant "TypeConstructor" a b
     TypeOp a b ->
@@ -274,8 +274,9 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do
       TypeVar a <$> contents
     "TypeLevelString" ->
       TypeLevelString a <$> contents
-    "TypeWildcard" ->
-      pure $ TypeWildcard a
+    "TypeWildcard" -> do
+      b <- contents <|> pure Nothing
+      pure $ TypeWildcard a b
     "TypeConstructor" ->
       TypeConstructor a <$> contents
     "TypeOp" ->
@@ -518,7 +519,7 @@ annForType :: Lens' (Type a) a
 annForType k (TUnknown a b) = (\z -> TUnknown z b) <$> k a
 annForType k (TypeVar a b) = (\z -> TypeVar z b) <$> k a
 annForType k (TypeLevelString a b) = (\z -> TypeLevelString z b) <$> k a
-annForType k (TypeWildcard a) = TypeWildcard <$> k a
+annForType k (TypeWildcard a b) = (\z -> TypeWildcard z b) <$> k a
 annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a
 annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a
 annForType k (TypeApp a b c) = (\z -> TypeApp z b c) <$> k a
@@ -547,7 +548,7 @@ eqType :: Type a -> Type b -> Bool
 eqType (TUnknown _ a) (TUnknown _ a') = a == a'
 eqType (TypeVar _ a) (TypeVar _ a') = a == a'
 eqType (TypeLevelString _ a) (TypeLevelString _ a') = a == a'
-eqType (TypeWildcard _) (TypeWildcard _) = True
+eqType (TypeWildcard _ a) (TypeWildcard _ a') = a == a'
 eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a'
 eqType (TypeOp _ a) (TypeOp _ a') = a == a'
 eqType (TypeApp _ a b) (TypeApp _ a' b') = eqType a a' && eqType b b'
@@ -573,9 +574,9 @@ compareType (TypeLevelString _ a) (TypeLevelString _ a') = compare a a'
 compareType (TypeLevelString {}) _ = LT
 compareType _ (TypeLevelString {}) = GT
 
-compareType (TypeWildcard _) (TypeWildcard _) = EQ
-compareType (TypeWildcard _) _ = LT
-compareType _ (TypeWildcard _) = GT
+compareType (TypeWildcard _ a) (TypeWildcard _ a') = compare a a'
+compareType (TypeWildcard {}) _ = LT
+compareType _ (TypeWildcard {}) = GT
 
 compareType (TypeConstructor _ a) (TypeConstructor _ a') = compare a a'
 compareType (TypeConstructor {}) _ = LT

diff --git a/tests/purs/failing/TypedHole2.purs b/tests/purs/failing/TypedHole2.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith HoleInferredType
+module Main where
+
+import Prelude
+import Effect (Effect)
+
+main :: Effect ?ummm
+main = pure unit
diff --git a/tests/purs/warning/WildcardInferredType.purs b/tests/purs/warning/WildcardInferredType.purs
@@ -1,10 +1,7 @@
 -- @shouldWarnWith WildcardInferredType
 -- @shouldWarnWith WildcardInferredType
--- @shouldWarnWith WildcardInferredType
--- @shouldWarnWith WildcardInferredType
 module Main where
 
-x :: Int
 x = 0 :: _
 
 y :: _
@@ -15,9 +12,3 @@ z =
   let n :: _
       n = 0
   in n
-
-w :: Int
-w = n
-  where
-  n :: _
-  n = 0
diff --git a/tests/purs/warning/WildcardInferredType2.purs b/tests/purs/warning/WildcardInferredType2.purs
@@ -0,0 +1,14 @@
+-- @shouldWarnWith WildcardInferredType
+module Main where
+
+x :: _
+x = 42
+
+y :: Int
+y = 42 :: _
+
+z :: Int
+z = n
+  where
+  n :: _
+  n = 42