diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 75144ad466..8dab6dee15 100644 --- 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 index e366302375..608c02f70c 100644 --- 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 index c874d750ae..be5753dd2e 100644 --- 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 index e3f3698a05..f730b600ef 100644 --- 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 index 3908fd708b..93d8be989a 100644 --- 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 index b2623bd549..2bd34f6672 100644 --- 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 index 5be826b6fe..531bffd8e3 100644 --- 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 index 59d38aba82..8851d9d763 100755 --- 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 index 752184d4f0..58a05a4be9 100644 --- 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 index fcb73d5d19..35c5dfd8ab 100644 --- 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 index 6275141a1a..cf79c73ad8 100644 --- 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 index d53002719a..19bf3e641c 100644 --- 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 index 367318c93f..56f963bfd3 100644 --- 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 new file mode 100644 index 0000000000..2e6cd66d59 --- /dev/null +++ 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 index 3662384dea..da42213319 100644 --- 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 new file mode 100644 index 0000000000..441a326c18 --- /dev/null +++ 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 \ No newline at end of file