diff --git a/CHANGELOG.d/feature_local-type-synonyms.md b/CHANGELOG.d/feature_local-type-synonyms.md new file mode 100644 index 0000000000..6fbffbb33e --- /dev/null +++ b/CHANGELOG.d/feature_local-type-synonyms.md @@ -0,0 +1,4 @@ +* Support local type synonyms + + This feature enables type synonyms to be defined in do, let, and where + blocks, alongside value definitions. diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index cf0c83a42d..9762c374bd 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -99,7 +99,8 @@ data HintCategory | CheckHint | PositionHint | SolverHint - | DeclarationHint + | TypeDeclarationHint + | ValueDeclarationHint | OtherHint deriving (Show, Eq) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index abbe6e5a15..1afa321b32 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -18,9 +18,9 @@ import Data.Map qualified as M import Data.Set qualified as S import Language.PureScript.AST.Binders (Binder(..), binderNames) -import Language.PureScript.AST.Declarations (CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, ValueDeclarationData(..), mapTypeInstanceBody, traverseTypeInstanceBody) +import Language.PureScript.AST.Declarations (CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, ValueDeclarationData(..), declName, mapTypeInstanceBody, traverseTypeInstanceBody) import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Name(..)) import Language.PureScript.Traversals (sndM, sndM', thirdM) import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), SourceType, mapConstraintArgs) @@ -538,50 +538,53 @@ everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0, k' s (ConditionGuard e) = ConditionGuard <$> g'' s e k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e -data ScopedIdent = LocalIdent Ident | ToplevelIdent Ident +data ScopedName = LocalName Name | ToplevelName Name deriving (Show, Eq, Ord) -inScope :: Ident -> S.Set ScopedIdent -> Bool -inScope i s = (LocalIdent i `S.member` s) || (ToplevelIdent i `S.member` s) +inScope' :: Name -> S.Set ScopedName -> Bool +inScope' n s = (LocalName n `S.member` s) || (ToplevelName n `S.member` s) + +inScope :: Ident -> S.Set ScopedName -> Bool +inScope = inScope' . IdentName everythingWithScope :: forall r . (Monoid r) - => (S.Set ScopedIdent -> Declaration -> r) - -> (S.Set ScopedIdent -> Expr -> r) - -> (S.Set ScopedIdent -> Binder -> r) - -> (S.Set ScopedIdent -> CaseAlternative -> r) - -> (S.Set ScopedIdent -> DoNotationElement -> r) - -> ( S.Set ScopedIdent -> Declaration -> r - , S.Set ScopedIdent -> Expr -> r - , S.Set ScopedIdent -> Binder -> r - , S.Set ScopedIdent -> CaseAlternative -> r - , S.Set ScopedIdent -> DoNotationElement -> r + => (S.Set ScopedName -> Declaration -> r) + -> (S.Set ScopedName -> Expr -> r) + -> (S.Set ScopedName -> Binder -> r) + -> (S.Set ScopedName -> CaseAlternative -> r) + -> (S.Set ScopedName -> DoNotationElement -> r) + -> ( S.Set ScopedName -> Declaration -> r + , S.Set ScopedName -> Expr -> r + , S.Set ScopedName -> Binder -> r + , S.Set ScopedName -> CaseAlternative -> r + , S.Set ScopedName -> DoNotationElement -> r ) everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) where - f'' :: S.Set ScopedIdent -> Declaration -> r + f'' :: S.Set ScopedName -> Declaration -> r f'' s a = f s a <> f' s a - f' :: S.Set ScopedIdent -> Declaration -> r + f' :: S.Set ScopedName -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds)))) + let s' = S.union s (S.fromList (map ToplevelName (mapMaybe declName (NEL.toList ds)))) in foldMap (f'' s') ds f' s (ValueDecl _ name _ bs val) = - let s' = S.insert (ToplevelIdent name) s + let s' = S.insert (ToplevelName (IdentName name)) s s'' = S.union s' (S.fromList (concatMap localBinderNames bs)) in foldMap (h'' s') bs <> foldMap (l' s'') val f' s (BindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds))) + let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelName (IdentName name)) ds))) in foldMap (\(_, _, val) -> g'' s' val) ds f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds f' _ _ = mempty - g'' :: S.Set ScopedIdent -> Expr -> r + g'' :: S.Set ScopedName -> Expr -> r g'' s a = g s a <> g' s a - g' :: S.Set ScopedIdent -> Expr -> r + g' :: S.Set ScopedName -> Expr -> r g' s (Literal _ l) = lit g'' s l g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 @@ -599,7 +602,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts g' s (TypedValue _ v1 _) = g'' s v1 g' s (Let _ ds v1) = - let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds))) + let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds))) in foldMap (f'' s') ds <> g'' s' v1 g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es g' s (Ado _ es v1) = @@ -608,46 +611,46 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = mempty - h'' :: S.Set ScopedIdent -> Binder -> r + h'' :: S.Set ScopedName -> Binder -> r h'' s a = h s a <> h' s a - h' :: S.Set ScopedIdent -> Binder -> r + h' :: S.Set ScopedName -> Binder -> r h' s (LiteralBinder _ l) = lit h'' s l h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3] h' s (ParensInBinder b) = h'' s b - h' s (NamedBinder _ name b1) = h'' (S.insert (LocalIdent name) s) b1 + h' s (NamedBinder _ name b1) = h'' (S.insert (LocalName (IdentName name)) s) b1 h' s (PositionedBinder _ _ b1) = h'' s b1 h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = mempty - lit :: (S.Set ScopedIdent -> a -> r) -> S.Set ScopedIdent -> Literal a -> r + lit :: (S.Set ScopedName -> a -> r) -> S.Set ScopedName -> Literal a -> r lit go s (ArrayLiteral as) = foldMap (go s) as lit go s (ObjectLiteral as) = foldMap (go s . snd) as lit _ _ _ = mempty - i'' :: S.Set ScopedIdent -> CaseAlternative -> r + i'' :: S.Set ScopedName -> CaseAlternative -> r i'' s a = i s a <> i' s a - i' :: S.Set ScopedIdent -> CaseAlternative -> r + i' :: S.Set ScopedName -> CaseAlternative -> r i' s (CaseAlternative bs gs) = let s' = S.union s (S.fromList (concatMap localBinderNames bs)) in foldMap (h'' s) bs <> foldMap (l' s') gs - j'' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r) + j'' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r) j'' s a = let (s', r) = j' s a in (s', j s a <> r) - j' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r) + j' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r) j' s (DoNotationValue v) = (s, g'' s v) j' s (DoNotationBind b v) = let s' = S.union (S.fromList (localBinderNames b)) s in (s', h'' s b <> g'' s v) j' s (DoNotationLet ds) = - let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds))) + let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds))) in (s', foldMap (f'' s') ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 - k' :: S.Set ScopedIdent -> Guard -> (S.Set ScopedIdent, r) + k' :: S.Set ScopedName -> Guard -> (S.Set ScopedName, r) k' s (ConditionGuard e) = (s, g'' s e) k' s (PatternGuard b e) = let s' = S.union (S.fromList (localBinderNames b)) s @@ -658,12 +661,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let (s', r) = k' s grd in r <> l' s' (GuardedExpr gs e) - getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd) - getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td) - getDeclIdent _ = Nothing - - localBinderNames = map LocalIdent . binderNames + localBinderNames = map (LocalName . IdentName) . binderNames accumTypes :: (Monoid r) diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index c75d333dcc..b9b24a5546 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -236,6 +236,16 @@ convertLetBinding fileName = \case binding@(LetBindingPattern _ a _ b) -> do let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b) + binding@(LetBindingType _ (DataHead _ a vars) _ bd) -> do + let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding + AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd) + binding@(LetBindingKindSignature _ _ (Labeled name _ ty)) -> do + let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding + AST.KindDeclaration ann AST.TypeSynonymSig (nameValue name) $ convertType fileName ty + where + goTypeVar = \case + TypeVarKinded (Wrapped _ (Labeled (_, x) _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y) + TypeVarName (_, x) -> (getIdent $ nameValue x, Nothing) convertExpr :: forall a. String -> Expr a -> AST.Expr convertExpr fileName = go diff --git a/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs index 890614070d..bd0426e6ad 100644 --- a/src/Language/PureScript/CST/Flatten.hs +++ b/src/Language/PureScript/CST/Flatten.hs @@ -164,6 +164,8 @@ flattenLetBinding = \case LetBindingSignature _ a -> flattenLabeled flattenName flattenType a LetBindingName _ a -> flattenValueBindingFields a LetBindingPattern _ a b c -> flattenBinder a <> pure b <> flattenWhere c + LetBindingType _ a b c -> flattenDataHead a <> pure b <> flattenType c + LetBindingKindSignature _ a b -> pure a <> flattenLabeled flattenName flattenType b flattenWhere :: Where a -> DList SourceToken flattenWhere (Where a b) = diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 55aa95da79..938bf880ed 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -460,6 +460,8 @@ letBinding :: { LetBinding () } | ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) } | ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) } | binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 } + | typeHead '=' type {% checkNoWildcards $3 *> pure (LetBindingType () $1 $2 $3) } + | 'type' properName '::' type {% checkNoWildcards $4 *> pure (LetBindingKindSignature () $1 (Labeled (getProperName $2) $3 $4)) } caseBranch :: { (Separated (Binder ()), Guarded ()) } : sep(binder1, ',') guardedCase { ($1, $2) } diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index 20d5724271..13bb59cfde 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -305,6 +305,8 @@ letBindingRange = \case LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b) LetBindingName _ a -> valueBindingFieldsRange a LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b) + LetBindingType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b) + LetBindingKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b) doStatementRange :: DoStatement a -> TokenRange doStatementRange = \case diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index ba90f7e95b..6fa0e5ea52 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -403,6 +403,8 @@ data LetBinding a = LetBindingSignature a (Labeled (Name Ident) (Type a)) | LetBindingName a (ValueBindingFields a) | LetBindingPattern a (Binder a) SourceToken (Where a) + | LetBindingType a (DataHead a) SourceToken (Type a) + | LetBindingKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data DoBlock a = DoBlock diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 56d962b3c7..54af669790 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -81,7 +81,7 @@ data SimpleErrorMessage | OrphanKindDeclaration (ProperName 'TypeName) | OrphanRoleDeclaration (ProperName 'TypeName) | RedefinedIdent Ident - | OverlappingNamesInLet Ident + | OverlappingNamesInLet Name | UnknownName (Qualified Name) | UnknownImport ModuleName Name | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) @@ -143,10 +143,10 @@ data SimpleErrorMessage | TransitiveExportError DeclarationRef [DeclarationRef] | TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName] | HiddenConstructors DeclarationRef (Qualified (ProperName 'ClassName)) - | ShadowedName Ident + | ShadowedName Name | ShadowedTypeVar Text | UnusedTypeVar Text - | UnusedName Ident + | UnusedName Name | UnusedDeclaration Ident | WildcardInferredType SourceType Context | HoleInferredType Text SourceType Context (Maybe TypeSearch) @@ -744,7 +744,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon renderSimpleErrorMessage InvalidDoLet = line "The last statement in a 'do' block must be an expression, but this block ends with a let binding." renderSimpleErrorMessage (OverlappingNamesInLet name) = - line $ "The name " <> markCode (showIdent name) <> " was defined multiple times in a binding group" + line $ "The " <> printName (Qualified ByNullSourcePos name) <> " was defined multiple times in a binding group" renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " , markCodeBox $ indent $ prettyType ty @@ -1122,11 +1122,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , line "Such instance allows to match and construct values of this type, effectively making the constructors public." ] renderSimpleErrorMessage (ShadowedName nm) = - line $ "Name " <> markCode (showIdent nm) <> " was shadowed." + line $ "The " <> printName (Qualified ByNullSourcePos nm) <> " was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = line $ "Type variable " <> markCode tv <> " was shadowed." renderSimpleErrorMessage (UnusedName nm) = - line $ "Name " <> markCode (showIdent nm) <> " was introduced but not used." + line $ "The " <> printName (Qualified ByNullSourcePos nm) <> " was introduced but not used." renderSimpleErrorMessage (UnusedDeclaration nm) = line $ "Declaration " <> markCode (showIdent nm) <> " was not used, and is not exported." renderSimpleErrorMessage (UnusedTypeVar tv) = @@ -1768,17 +1768,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon hintCategory ErrorCheckingKind{} = CheckHint hintCategory ErrorSolvingConstraint{} = SolverHint hintCategory PositionedError{} = PositionHint - hintCategory ErrorInDataConstructor{} = DeclarationHint - hintCategory ErrorInTypeConstructor{} = DeclarationHint - hintCategory ErrorInBindingGroup{} = DeclarationHint - hintCategory ErrorInDataBindingGroup{} = DeclarationHint - hintCategory ErrorInTypeSynonym{} = DeclarationHint - hintCategory ErrorInValueDeclaration{} = DeclarationHint - hintCategory ErrorInTypeDeclaration{} = DeclarationHint - hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint - hintCategory ErrorInKindDeclaration{} = DeclarationHint - hintCategory ErrorInRoleDeclaration{} = DeclarationHint - hintCategory ErrorInForeignImport{} = DeclarationHint + hintCategory ErrorInDataConstructor{} = TypeDeclarationHint + hintCategory ErrorInTypeConstructor{} = TypeDeclarationHint + hintCategory ErrorInDataBindingGroup{} = TypeDeclarationHint + hintCategory ErrorInTypeSynonym{} = TypeDeclarationHint + hintCategory ErrorInTypeDeclaration{} = TypeDeclarationHint + hintCategory ErrorInTypeClassDeclaration{} = TypeDeclarationHint + hintCategory ErrorInKindDeclaration{} = TypeDeclarationHint + hintCategory ErrorInRoleDeclaration{} = TypeDeclarationHint + hintCategory ErrorInBindingGroup{} = ValueDeclarationHint + hintCategory ErrorInValueDeclaration{} = ValueDeclarationHint + hintCategory ErrorInForeignImport{} = ValueDeclarationHint hintCategory _ = OtherHint prettyPrintPlainIdent :: Ident -> Text diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 3e773efe5a..139815c400 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -141,7 +141,7 @@ applySearch module_ search = P.Var sp i | Just ideValue <- preview _IdeDeclValue (P.disqualify search) , P.isQualified search - || not (P.LocalIdent (_ideValueIdent ideValue) `Set.member` scope) -> + || not (P.LocalName (P.IdentName $ _ideValueIdent ideValue) `Set.member` scope) -> [sp | map P.runIdent i == map identifierFromIdeDeclaration search] P.Constructor sp name | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 9bce1909de..d085b2d58d 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -7,6 +7,7 @@ import Prelude import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Data.Bifunctor (second) import Data.Maybe (mapMaybe) import Data.Set qualified as S import Data.Text (Text) @@ -18,7 +19,7 @@ import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHi import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L import Language.PureScript.Names (Ident(..), Qualified(..), QualifiedBy(..), getIdentName, runIdent) -import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everythingWithContextOnTypes) +import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everythingOnTypes, everythingWithContextOnTypes) import Language.PureScript.Constants.Libs qualified as C -- | Lint the PureScript AST. @@ -30,11 +31,8 @@ lint modl@(Module _ _ mn ds _) = do censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds where - moduleNames :: S.Set ScopedIdent - moduleNames = S.fromList (map ToplevelIdent (mapMaybe getDeclIdent ds)) - - getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent = getIdentName <=< declName + moduleNames :: S.Set ScopedName + moduleNames = S.fromList (map ToplevelName (mapMaybe declName ds)) lintDeclaration :: Declaration -> m () lintDeclaration = tell . f @@ -52,29 +50,29 @@ lint modl@(Module _ _ mn ds _) = do addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars ss s (tydeclType td)) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec - stepE :: S.Set ScopedIdent -> Expr -> MultipleErrors - stepE s (Abs (VarBinder ss name) _) | name `inScope` s = errorMessage' ss (ShadowedName name) + stepE :: S.Set ScopedName -> Expr -> MultipleErrors + stepE s (Abs (VarBinder ss name) _) | name `inScope` s = errorMessage' ss (ShadowedName $ IdentName name) stepE s (Let _ ds' _) = foldMap go ds' where - go d | Just i <- getDeclIdent d - , inScope i s = errorMessage' (declSourceSpan d) (ShadowedName i) + go d | Just n <- declName d + , inScope' n s = errorMessage' (declSourceSpan d) (ShadowedName n) | otherwise = mempty stepE _ _ = mempty - stepB :: S.Set ScopedIdent -> Binder -> MultipleErrors + stepB :: S.Set ScopedName -> Binder -> MultipleErrors stepB s (VarBinder ss name) | name `inScope` s - = errorMessage' ss (ShadowedName name) + = errorMessage' ss (ShadowedName $ IdentName name) stepB s (NamedBinder ss name _) | inScope name s - = errorMessage' ss (ShadowedName name) + = errorMessage' ss (ShadowedName $ IdentName name) stepB _ _ = mempty - stepDo :: S.Set ScopedIdent -> DoNotationElement -> MultipleErrors + stepDo :: S.Set ScopedName -> DoNotationElement -> MultipleErrors stepDo s (DoNotationLet ds') = foldMap go ds' where go d - | Just i <- getDeclIdent d, i `inScope` s = errorMessage' (declSourceSpan d) (ShadowedName i) + | Just n <- declName d, n `inScope'` s = errorMessage' (declSourceSpan d) (ShadowedName n) | otherwise = mempty stepDo _ _ = mempty @@ -177,25 +175,25 @@ lintUnused (Module modSS _ mn modDecls exports) = goDecl :: Declaration -> (S.Set Ident, MultipleErrors) goDecl (ValueDeclaration vd) = let allExprs = concatMap unguard $ valdeclExpression vd - bindNewNames = S.fromList (concatMap binderNamesWithSpans $ valdeclBinders vd) + bindNewNames = S.fromList (concatMap binderNamesWithSpans' $ valdeclBinders vd) (vars, errs) = removeAndWarn bindNewNames $ mconcat $ map go allExprs errs' = addHint (ErrorInValueDeclaration $ valdeclIdent vd) errs in - (vars, errs') + (S.fromDistinctAscList . mapMaybe getIdentName $ S.toAscList vars, errs') goDecl (ValueFixityDeclaration _ _ (Qualified _ (Left v)) _) = (S.singleton v, mempty) goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls goDecl _ = mempty - go :: Expr -> (S.Set Ident, MultipleErrors) - go (Var _ (Qualified (BySourcePos _) v)) = (S.singleton v, mempty) + go :: Expr -> (S.Set Name, MultipleErrors) + go (Var _ (Qualified (BySourcePos _) v)) = (S.singleton $ IdentName v, mempty) go (Var _ _) = (S.empty, mempty) go (Let _ ds e) = onDecls ds (go e) go (Abs binder v1) = - let newNames = S.fromList (binderNamesWithSpans binder) + let newNames = S.fromList (binderNamesWithSpans' binder) in removeAndWarn newNames $ go v1 @@ -217,14 +215,14 @@ lintUnused (Module modSS _ mn modDecls exports) = go (IfThenElse v1 v2 v3) = go v1 <> go v2 <> go v3 go (Case vs alts) = let f (CaseAlternative binders gexprs) = - let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders) + let bindNewNames = S.fromList (concatMap binderNamesWithSpans' binders) allExprs = concatMap unguard gexprs in removeAndWarn bindNewNames $ mconcat $ map go allExprs in mconcat $ map go vs ++ map f alts - go (TypedValue _ v1 _) = go v1 + go (TypedValue _ v1 ty) = go v1 <> goType ty go (Do _ es) = doElts es Nothing go (Ado _ es v1) = doElts es (Just v1) @@ -242,30 +240,35 @@ lintUnused (Module modSS _ mn modDecls exports) = go AnonymousArgument = mempty go (Hole _) = mempty + goType :: SourceType -> (S.Set Name, MultipleErrors) + goType = everythingOnTypes (<>) $ \case + TypeConstructor _ (Qualified (BySourcePos _) t) -> (S.singleton $ TyName t, mempty) + _ -> mempty - doElts :: [DoNotationElement] -> Maybe Expr -> (S.Set Ident, MultipleErrors) + doElts :: [DoNotationElement] -> Maybe Expr -> (S.Set Name, MultipleErrors) doElts (DoNotationValue e : rest) v = go e <> doElts rest v doElts (DoNotationBind binder e : rest) v = - let bindNewNames = S.fromList (binderNamesWithSpans binder) + let bindNewNames = S.fromList (binderNamesWithSpans' binder) in go e <> removeAndWarn bindNewNames (doElts rest v) doElts (DoNotationLet ds : rest) v = onDecls ds (doElts rest v) doElts (PositionedDoNotationElement _ _ e : rest) v = doElts (e : rest) v - doElts [] (Just e) = go e <> (rebindable, mempty) - doElts [] Nothing = (rebindable, mempty) + doElts [] (Just e) = go e <> (S.mapMonotonic IdentName rebindable, mempty) + doElts [] Nothing = (S.mapMonotonic IdentName rebindable, mempty) - -- (non-recursively, recursively) bound idents in decl - declIdents :: Declaration -> (S.Set (SourceSpan, Ident), S.Set (SourceSpan, Ident)) - declIdents (ValueDecl (ss,_) ident _ _ _) = (S.empty, S.singleton (ss, ident)) - declIdents (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans binders, S.empty) - declIdents _ = (S.empty, S.empty) + -- (non-recursively, recursively) bound names in decl + declNames :: Declaration -> (S.Set (SourceSpan, Name), S.Set (SourceSpan, Name)) + declNames (ValueDecl (ss,_) ident _ _ _) = (S.empty, S.singleton (ss, IdentName ident)) + declNames (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans' binders, S.empty) + declNames (TypeSynonymDeclaration (ss,_) ty _ _) = (S.singleton (ss, TyName ty), S.empty) + declNames _ = (S.empty, S.empty) - onDecls :: [ Declaration ] -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors) + onDecls :: [ Declaration ] -> (S.Set Name, MultipleErrors) -> (S.Set Name, MultipleErrors) onDecls ds errs = let onDecl d (accErrs, accLetNamesRec) = - let (letNames, recNames) = declIdents d + let (letNames, recNames) = declNames d dErrs = underDecl d errs' = dErrs <> removeAndWarn letNames accErrs in @@ -276,24 +279,34 @@ lintUnused (Module modSS _ mn modDecls exports) = -- let f x = e -- check the x in e (but not the f) underDecl (ValueDecl _ _ _ binders gexprs) = - let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders) + let bindNewNames = S.fromList (concatMap binderNamesWithSpans' binders) allExprs = concatMap unguard gexprs in removeAndWarn bindNewNames $ foldr1 (<>) $ map go allExprs -- let {x} = e -- no binding to check inside e underDecl (BoundValueDeclaration _ _ expr) = go expr + -- let f :: t -- check t + underDecl (TypeDeclaration TypeDeclarationData{..}) = goType tydeclType underDecl _ = (mempty, mempty) unguard (GuardedExpr guards expr) = map unguard' guards ++ [expr] unguard' (ConditionGuard ee) = ee unguard' (PatternGuard _ ee) = ee - removeAndWarn :: S.Set (SourceSpan, Ident) -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors) + shouldWarnForName :: Name -> Bool + shouldWarnForName = \case + IdentName nm -> not . Text.isPrefixOf "_" $ runIdent nm + _ -> True + + removeAndWarn :: S.Set (SourceSpan, Name) -> (S.Set Name, MultipleErrors) -> (S.Set Name, MultipleErrors) removeAndWarn newNamesWithSpans (used, errors) = let newNames = S.map snd newNamesWithSpans filteredUsed = used `S.difference` newNames - warnUnused = S.filter (not . Text.isPrefixOf "_" . runIdent) (newNames `S.difference` used) - warnUnusedSpans = S.filter (\(_,ident) -> ident `elem` warnUnused) newNamesWithSpans - combinedErrors = if not $ S.null warnUnusedSpans then errors <> mconcat (map (\(ss,ident) -> errorMessage' ss $ UnusedName ident) $ S.toList warnUnusedSpans) else errors + warnUnused = S.filter shouldWarnForName (newNames `S.difference` used) + warnUnusedSpans = S.filter (\(_,name) -> name `elem` warnUnused) newNamesWithSpans + combinedErrors = if not $ S.null warnUnusedSpans then errors <> mconcat (map (\(ss,name) -> errorMessage' ss $ UnusedName name) $ S.toList warnUnusedSpans) else errors in (filteredUsed, combinedErrors) + + binderNamesWithSpans' :: Binder -> [(SourceSpan, Name)] + binderNamesWithSpans' = map (second IdentName) . binderNamesWithSpans diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4d5a5ec604..b2c4a8ea57 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -11,6 +11,7 @@ import Prelude hiding ((<>)) import Control.Arrow (second) +import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.List.NonEmpty qualified as NEL import Data.Monoid qualified as Monoid ((<>)) @@ -75,10 +76,10 @@ prettyPrintValue d (Case values binders) = prettyPrintValue d (Let FromWhere ds val) = prettyPrintValue (d - 1) val // moveRight 2 (text "where" // - vcat left (map (prettyPrintDeclaration (d - 1)) ds)) + vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds)) prettyPrintValue d (Let FromLet ds val) = text "let" // - moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // + moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds)) // (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do m els) = textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) @@ -139,6 +140,12 @@ prettyPrintDeclaration d (BindingGroupDeclaration ds) = toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e] prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" +prettyPrintDeclaration' :: Int -> Declaration -> Maybe Box +prettyPrintDeclaration' d = \case + KindDeclaration{} -> Nothing + TypeSynonymDeclaration{} -> Nothing + decl -> Just $ prettyPrintDeclaration d decl + prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box prettyPrintCaseAlternative d _ | d < 0 = ellipsis prettyPrintCaseAlternative d (CaseAlternative binders result) = @@ -184,7 +191,7 @@ prettyPrintDoNotationElement d (DoNotationBind binder val) = textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val prettyPrintDoNotationElement d (DoNotationLet ds) = text "let" // - moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) + moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds)) prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el prettyPrintBinderAtom :: Binder -> Text diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d2f9aebf2b..eea7b1c8f7 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -28,7 +28,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (NameKind) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), errorMessage', parU, positionedError) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName) import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), everythingOnTypes) data VertexType @@ -171,11 +171,11 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def - usedNamesE :: S.Set ScopedIdent -> Expr -> [Ident] + usedNamesE :: S.Set ScopedName -> Expr -> [Ident] usedNamesE scope (Var _ (Qualified (BySourcePos _) name)) - | LocalIdent name `S.notMember` scope = [name] + | LocalName (IdentName name) `S.notMember` scope = [name] usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name)) - | moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name] + | moduleName == moduleName' && ToplevelName (IdentName name) `S.notMember` scope = [name] usedNamesE _ _ = [] usedImmediateIdents :: ModuleName -> Declaration -> [Ident] @@ -202,6 +202,7 @@ usedTypeNames moduleName = go usedNames :: SourceType -> [ProperName 'TypeName] usedNames (ConstrainedType _ con _) = usedConstraint con + usedNames (TypeConstructor _ (Qualified (BySourcePos _) name)) = [name] usedNames (TypeConstructor _ (Qualified (ByModuleName moduleName') name)) | moduleName == moduleName' = [name] usedNames _ = [] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index d081764d7f..ad55d736ff 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -12,7 +12,7 @@ module Language.PureScript.Sugar.Names import Prelude import Protolude (sortOn, swap, foldl') -import Control.Arrow (first, second, (&&&)) +import Control.Arrow (first, second) import Control.Monad (foldM, when, (>=>)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy (MonadState, StateT(..), gets, modify) @@ -184,49 +184,49 @@ renameInModule imports (Module modSS coms mn decls exps) = updateGuard updateDecl - :: M.Map Ident SourcePos + :: M.Map Name SourcePos -> Declaration - -> m (M.Map Ident SourcePos, Declaration) + -> m (M.Map Name SourcePos, Declaration) updateDecl bound (DataDeclaration sa dtype name args dctors) = fmap (bound,) $ DataDeclaration sa dtype name - <$> updateTypeArguments args - <*> traverse (traverseDataCtorFields (traverse (sndM updateTypesEverywhere))) dctors - updateDecl bound (TypeSynonymDeclaration sa name ps ty) = - fmap (bound,) $ + <$> updateTypeArguments bound args + <*> traverse (traverseDataCtorFields (traverse (sndM (updateTypesEverywhere bound)))) dctors + updateDecl bound (TypeSynonymDeclaration sa@(ss, _) name ps ty) = + fmap (M.insert (TyName name) (spanStart ss) bound,) $ TypeSynonymDeclaration sa name - <$> updateTypeArguments ps - <*> updateTypesEverywhere ty + <$> updateTypeArguments bound ps + <*> updateTypesEverywhere bound ty updateDecl bound (TypeClassDeclaration sa className args implies deps ds) = fmap (bound,) $ TypeClassDeclaration sa className - <$> updateTypeArguments args - <*> updateConstraints implies + <$> updateTypeArguments bound args + <*> updateConstraints bound implies <*> pure deps <*> pure ds updateDecl bound (TypeInstanceDeclaration sa na@(ss, _) ch idx name cs cn ts ds) = fmap (bound,) $ TypeInstanceDeclaration sa na ch idx name - <$> updateConstraints cs + <$> updateConstraints bound cs <*> updateClassName cn ss - <*> traverse updateTypesEverywhere ts + <*> traverse (updateTypesEverywhere bound) ts <*> pure ds updateDecl bound (KindDeclaration sa kindFor name ty) = fmap (bound,) $ KindDeclaration sa kindFor name - <$> updateTypesEverywhere ty + <$> updateTypesEverywhere bound ty updateDecl bound (TypeDeclaration (TypeDeclarationData sa name ty)) = fmap (bound,) $ TypeDeclaration . TypeDeclarationData sa name - <$> updateTypesEverywhere ty + <$> updateTypesEverywhere bound ty updateDecl bound (ExternDeclaration sa name ty) = - fmap (M.insert name (spanStart $ fst sa) bound,) $ + fmap (M.insert (IdentName name) (spanStart $ fst sa) bound,) $ ExternDeclaration sa name - <$> updateTypesEverywhere ty + <$> updateTypesEverywhere bound ty updateDecl bound (ExternDataDeclaration sa name ki) = fmap (bound,) $ ExternDataDeclaration sa name - <$> updateTypesEverywhere ki + <$> updateTypesEverywhere bound ki updateDecl bound (TypeFixityDeclaration sa@(ss, _) fixity alias op) = fmap (bound,) $ TypeFixityDeclaration sa fixity @@ -246,86 +246,69 @@ renameInModule imports (Module modSS coms mn decls exps) = return (b, d) updateValue - :: (SourceSpan, M.Map Ident SourcePos) + :: (SourceSpan, M.Map Name SourcePos) -> Expr - -> m ((SourceSpan, M.Map Ident SourcePos), Expr) + -> m ((SourceSpan, M.Map Name SourcePos), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((pos', bound), v) updateValue (pos, bound) (Abs (VarBinder ss arg) val') = - return ((pos, M.insert arg (spanStart ss) bound), Abs (VarBinder ss arg) val') + return ((pos, M.insert (IdentName arg) (spanStart ss) bound), Abs (VarBinder ss arg) val') updateValue (pos, bound) (Let w ds val') = do let - args = mapMaybe letBoundVariable ds + names = mapMaybe letBoundName ds groupByFst = map (\ts -> (fst (NEL.head ts), snd <$> ts)) . NEL.groupAllWith fst - duplicateArgsErrs = foldMap mkArgError $ groupByFst args - mkArgError (ident, poses) + duplicateNameErrs = foldMap mkNameError $ groupByFst names + mkNameError (name, poses) | NEL.length poses < 2 = mempty - | otherwise = errorMessage'' (NEL.reverse poses) (OverlappingNamesInLet ident) - when (nonEmpty duplicateArgsErrs) $ - throwError duplicateArgsErrs + | otherwise = errorMessage'' (NEL.reverse poses) (OverlappingNamesInLet name) + when (nonEmpty duplicateNameErrs) $ + throwError duplicateNameErrs return ((pos, declarationsToMap ds `M.union` bound), Let w ds val') - updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident)) = - ((ss, bound), ) <$> case (M.lookup ident bound, qualifiedBy) of - -- bound idents that have yet to be locally qualified. - (Just sourcePos, ByNullSourcePos) -> - pure $ Var ss (Qualified (BySourcePos sourcePos) ident) - -- unbound idents are likely import unqualified imports, so we - -- handle them through updateValueName if they don't exist as a - -- local binding. - (Nothing, ByNullSourcePos) -> - Var ss <$> updateValueName name' ss - -- bound/unbound idents with explicit qualification is still - -- handled through updateValueName, as it fully resolves the - -- ModuleName. - (_, ByModuleName _) -> - Var ss <$> updateValueName name' ss - -- encountering non-null source spans may be a bug in previous - -- desugaring steps or with the AST traversals. - (_, BySourcePos _) -> - internalError "updateValue: ident is locally-qualified by a non-null source position" + updateValue (_, bound) (Var ss qname) = + ((ss, bound), ) <$> (Var ss <$> updateBoundName bound IdentName updateValueName qname ss) updateValue (_, bound) (Op ss op) = ((ss, bound), ) <$> (Op ss <$> updateValueOpName op ss) updateValue (_, bound) (Constructor ss name) = ((ss, bound), ) <$> (Constructor ss <$> updateDataConstructorName name ss) - updateValue s (TypedValue check val ty) = - (s, ) <$> (TypedValue check val <$> updateTypesEverywhere ty) - updateValue s (VisibleTypeApp val ty) = - (s, ) <$> VisibleTypeApp val <$> updateTypesEverywhere ty + updateValue s@(_, bound) (TypedValue check val ty) = + (s, ) <$> (TypedValue check val <$> updateTypesEverywhere bound ty) + updateValue s@(_, bound) (VisibleTypeApp val ty) = + (s, ) <$> VisibleTypeApp val <$> updateTypesEverywhere bound ty updateValue s v = return (s, v) updateBinder - :: (SourceSpan, M.Map Ident SourcePos) + :: (SourceSpan, M.Map Name SourcePos) -> Binder - -> m ((SourceSpan, M.Map Ident SourcePos), Binder) + -> m ((SourceSpan, M.Map Name SourcePos), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((pos, bound), v) updateBinder (_, bound) (ConstructorBinder ss name b) = ((ss, bound), ) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b) updateBinder (_, bound) (OpBinder ss op) = ((ss, bound), ) <$> (OpBinder ss <$> updateValueOpName op ss) - updateBinder s (TypedBinder t b) = do - t' <- updateTypesEverywhere t + updateBinder s@(_, bound) (TypedBinder t b) = do + t' <- updateTypesEverywhere bound t return (s, TypedBinder t' b) updateBinder s v = return (s, v) updateCase - :: (SourceSpan, M.Map Ident SourcePos) + :: (SourceSpan, M.Map Name SourcePos) -> CaseAlternative - -> m ((SourceSpan, M.Map Ident SourcePos), CaseAlternative) + -> m ((SourceSpan, M.Map Name SourcePos), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs _) = - return ((pos, rUnionMap binderNamesWithSpans' bs `M.union` bound), c) + return ((pos, M.mapKeysMonotonic IdentName (rUnionMap binderNamesWithSpans' bs) `M.union` bound), c) where rUnionMap f = foldl' (flip (M.union . f)) M.empty updateGuard - :: (SourceSpan, M.Map Ident SourcePos) + :: (SourceSpan, M.Map Name SourcePos) -> Guard - -> m ((SourceSpan, M.Map Ident SourcePos), Guard) + -> m ((SourceSpan, M.Map Name SourcePos), Guard) updateGuard (pos, bound) g@(ConditionGuard _) = return ((pos, bound), g) updateGuard (pos, bound) g@(PatternGuard b _) = - return ((pos, binderNamesWithSpans' b `M.union` bound), g) + return ((pos, M.mapKeysMonotonic IdentName (binderNamesWithSpans' b) `M.union` bound), g) binderNamesWithSpans' :: Binder -> M.Map Ident SourcePos binderNamesWithSpans' @@ -333,40 +316,42 @@ renameInModule imports (Module modSS coms mn decls exps) = . fmap (second spanStart . swap) . binderNamesWithSpans - letBoundVariable :: Declaration -> Maybe (Ident, SourceSpan) - letBoundVariable = fmap (valdeclIdent &&& (fst . valdeclSourceAnn)) . getValueDeclaration + letBoundName :: Declaration -> Maybe (Name, SourceSpan) + letBoundName d = (, declSourceSpan d) <$> declName d - declarationsToMap :: [Declaration] -> M.Map Ident SourcePos + declarationsToMap :: [Declaration] -> M.Map Name SourcePos declarationsToMap = foldl goDTM M.empty where goDTM a (ValueDeclaration ValueDeclarationData {..}) = - M.insert valdeclIdent (spanStart $ fst valdeclSourceAnn) a + M.insert (IdentName valdeclIdent) (spanStart $ fst valdeclSourceAnn) a + goDTM a (TypeSynonymDeclaration (ss, _) name _ _) = + M.insert (TyName name) (spanStart ss) a goDTM a _ = a updateTypeArguments :: (Traversable f, Traversable g) - => f (a, g SourceType) -> m (f (a, g SourceType)) - updateTypeArguments = traverse (sndM (traverse updateTypesEverywhere)) + => M.Map Name SourcePos -> f (a, g SourceType) -> m (f (a, g SourceType)) + updateTypeArguments bound = traverse (sndM (traverse (updateTypesEverywhere bound))) - updateTypesEverywhere :: SourceType -> m SourceType - updateTypesEverywhere = everywhereOnTypesM updateType + updateTypesEverywhere :: M.Map Name SourcePos -> SourceType -> m SourceType + updateTypesEverywhere bound = everywhereOnTypesM updateType where updateType :: SourceType -> m SourceType updateType (TypeOp ann@(ss, _) name) = TypeOp ann <$> updateTypeOpName name ss - updateType (TypeConstructor ann@(ss, _) name) = TypeConstructor ann <$> updateTypeName name ss + updateType (TypeConstructor ann@(ss, _) name) = TypeConstructor ann <$> updateBoundName bound TyName updateTypeName name ss updateType (ConstrainedType ann c t) = ConstrainedType ann <$> updateInConstraint c <*> pure t updateType t = return t updateInConstraint :: SourceConstraint -> m SourceConstraint updateInConstraint (Constraint ann@(ss, _) name ks ts info) = Constraint ann <$> updateClassName name ss <*> pure ks <*> pure ts <*> pure info - updateConstraints :: [SourceConstraint] -> m [SourceConstraint] - updateConstraints = traverse $ \(Constraint ann@(pos, _) name ks ts info) -> + updateConstraints :: M.Map Name SourcePos -> [SourceConstraint] -> m [SourceConstraint] + updateConstraints bound = traverse $ \(Constraint ann@(pos, _) name ks ts info) -> Constraint ann <$> updateClassName name pos - <*> traverse updateTypesEverywhere ks - <*> traverse updateTypesEverywhere ts + <*> traverse (updateTypesEverywhere bound) ks + <*> traverse (updateTypesEverywhere bound) ts <*> pure info updateTypeName @@ -402,6 +387,31 @@ renameInModule imports (Module modSS coms mn decls exps) = -> m (Qualified (OpName 'ValueOpName)) updateValueOpName = update (importedValueOps imports) ValOpName + updateBoundName + :: M.Map Name SourcePos + -> (a -> Name) + -> (Qualified a -> SourceSpan -> m (Qualified a)) + -> Qualified a -> SourceSpan -> m (Qualified a) + updateBoundName bound toName updateUnboundName qname@(Qualified qualifiedBy name) ss = + case (M.lookup (toName name) bound, qualifiedBy) of + -- bound names that have yet to be locally qualified. + (Just sourcePos, ByNullSourcePos) -> + pure $ Qualified (BySourcePos sourcePos) name + -- unbound names are likely import unqualified imports, so we + -- handle them through updateUnboundName if they don't exist as a + -- local binding. + (Nothing, ByNullSourcePos) -> + updateUnboundName qname ss + -- bound/unbound names with explicit qualification are still + -- handled through updateUnboundName, as it fully resolves the + -- ModuleName. + (_, ByModuleName _) -> + updateUnboundName qname ss + -- encountering non-null source spans may be a bug in previous + -- desugaring steps or with the AST traversals. + (_, BySourcePos _) -> + internalError "updateBoundName: name is locally-qualified by a non-null source position" + -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canonical qualified names -- (e.g. M.Map -> Data.Map.Map). diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f012..3b34d00d22 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -19,7 +19,7 @@ import Control.Monad.Writer.Class (MonadWriter, tell) import Data.Foldable (for_, traverse_, toList) import Data.List (nubBy, (\\), sort, group) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Either (partitionEithers) import Data.Text (Text) import Data.List.NonEmpty qualified as NEL @@ -190,16 +190,6 @@ addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } where insertState st = M.insertWith (M.unionWith (M.unionWith (<>))) mn entries (typeClassDictionaries . checkEnv $ st) -checkDuplicateTypeArguments - :: (MonadState CheckState m, MonadError MultipleErrors m) - => [Text] - -> m () -checkDuplicateTypeArguments args = for_ firstDup $ \dup -> - throwError . errorMessage $ DuplicateTypeArgument dup - where - firstDup :: Maybe Text - firstDup = listToMaybe $ args \\ ordNub args - checkTypeClassInstance :: (MonadState CheckState m, MonadError MultipleErrors m) => TypeClassData diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5be87c0057..fe94185fa7 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -7,6 +7,7 @@ module Language.PureScript.TypeChecker.Kinds , kindOfWithScopedVars , kindOfData , kindOfTypeSynonym + , kindOfLocalTypeSynonym , kindOfClass , kindsOfAll , unifyKinds @@ -572,18 +573,18 @@ elaborateKind = \case ty -> throwError . errorMessage' (fst (getAnnForType ty)) $ UnsupportedTypeInKind ty -checkEscapedSkolems :: MonadError MultipleErrors m => SourceType -> m () -checkEscapedSkolems ty = +checkEscapedSkolems :: (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName -> SourceType -> m () +checkEscapedSkolems moduleName ty = do + env <- getEnv + let typesInScope = E.types env + go :: SourceType -> SourceType -> (SourceType, [(SourceSpan, Text, SourceType)]) + go ty' = \case + Skolem ss name _ _ _ | M.notMember (Qualified (ByModuleName moduleName) (ProperName name)) typesInScope -> (ty', [(fst ss, name, ty')]) + _ -> (ty', []) traverse_ (throwError . toSkolemError) . everythingWithContextOnTypes ty [] (<>) go $ ty where - go :: SourceType -> SourceType -> (SourceType, [(SourceSpan, Text, SourceType)]) - go ty' = \case - Skolem ss name _ _ _ -> (ty', [(fst ss, name, ty')]) - ty''@(KindApp _ _ _) -> (ty'', []) - _ -> (ty', []) - toSkolemError (ss, name, ty') = errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty' @@ -687,6 +688,24 @@ kindOfTypeSynonym kindOfTypeSynonym moduleName typeDecl = head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] +-- | Local type synonym kind inference differs from that of top-level type +-- | synonyms for two reasons: local type synonyms can't appear in +-- | recursive binding groups, and they are not generalized. Instead of using +-- | kindsOfAll, they need their own (simpler) logic. +kindOfLocalTypeSynonym + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> TypeDeclarationArgs + -> m TypeDeclarationResult +kindOfLocalTypeSynonym moduleName typeDecl@((ss, _), synName, _, _) = do + synKind <- existingSignatureOrFreshKind ByNullSourcePos ss synName + bindLocalTypeVariables moduleName [(synName, synKind)] $ do + synBody <- inferTypeSynonym moduleName typeDecl + synKind' <- apply synKind + synBody' <- apply synBody + checkEscapedSkolems moduleName synBody' + pure (synBody', synKind') + inferTypeSynonym :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName @@ -935,13 +954,13 @@ checkKindDeclaration _ ty = do existingSignatureOrFreshKind :: forall m. MonadState CheckState m - => ModuleName + => QualifiedBy -> SourceSpan -> ProperName 'TypeName -> m SourceType -existingSignatureOrFreshKind moduleName ss name = do +existingSignatureOrFreshKind qb ss name = do env <- getEnv - case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of + case M.lookup (Qualified qb name) (E.types env) of Nothing -> freshKind ss Just (kind, _) -> pure kind @@ -953,9 +972,9 @@ kindsOfAll -> [ClassDeclarationArgs] -> m ([TypeDeclarationResult], [DataDeclarationResult], [ClassDeclarationResult]) kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do - synDict <- for syns $ \(sa, synName, _, _) -> (synName,) <$> existingSignatureOrFreshKind moduleName (fst sa) synName - datDict <- for dats $ \(sa, datName, _, _) -> (datName,) <$> existingSignatureOrFreshKind moduleName (fst sa) datName - clsDict <- for clss $ \(sa, clsName, _, _, _) -> fmap (coerceProperName clsName,) $ existingSignatureOrFreshKind moduleName (fst sa) $ coerceProperName clsName + synDict <- for syns $ \(sa, synName, _, _) -> (synName,) <$> existingSignatureOrFreshKind (ByModuleName moduleName) (fst sa) synName + datDict <- for dats $ \(sa, datName, _, _) -> (datName,) <$> existingSignatureOrFreshKind (ByModuleName moduleName) (fst sa) datName + clsDict <- for clss $ \(sa, clsName, _, _, _) -> fmap (coerceProperName clsName,) $ existingSignatureOrFreshKind (ByModuleName moduleName) (fst sa) $ coerceProperName clsName let bindingGroup = synDict <> datDict <> clsDict bindLocalTypeVariables moduleName bindingGroup $ do synResults <- for syns (inferTypeSynonym moduleName) @@ -1013,7 +1032,7 @@ kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do unkBinders = unknownVarNames (usedTypeVariables synKind <> usedTypeVariables synBody) tyUnks genBody = replaceUnknownsWithVars unkBinders $ replaceTypeCtors synBody genSig = generalizeUnknownsWithVars unkBinders synKind - checkEscapedSkolems genBody + checkEscapedSkolems moduleName genBody checkTypeQuantification genBody checkVisibleTypeQuantification genSig pure (genBody, genSig) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index ba27d0299b..f5911d206f 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -246,6 +246,25 @@ bindLocalTypeVariables bindLocalTypeVariables moduleName bindings = bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) +-- | Temporarily bind a local type synonym +bindLocalTypeSynonym + :: (MonadState CheckState m) + => SourceSpan + -> ProperName 'TypeName + -> [(Text, Maybe SourceType)] + -> SourceType + -> SourceType + -> m a + -> m a +bindLocalTypeSynonym ss name args ty kind action = do + let qname = Qualified (BySourcePos $ spanStart ss) name + orig <- getEnv + modifyEnv $ \env -> env { types = M.insert qname (kind, LocalTypeVariable) (types env) + , typeSynonyms = M.insert qname (args, ty) (typeSynonyms env) } + a <- action + modifyEnv $ \env -> env { types = types orig, typeSynonyms = typeSynonyms orig } + return a + -- | Update the visibility of all names to Defined makeBindingGroupVisible :: (MonadState CheckState m) => m () makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index aa49997fd6..ef782b5a58 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -12,11 +12,12 @@ import Prelude import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) +import Data.Bifunctor (second) import Data.Foldable (traverse_) import Data.Functor.Identity (Identity(), runIdentity) import Data.Set (Set, fromList, notMember) import Data.Text (Text) -import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), SourceAnn, SourceSpan, everythingWithContextOnValues, everywhereWithContextOnValuesM, nonEmptySpan) +import Language.PureScript.AST (Binder(..), Declaration(..), ErrorMessageHint(..), Expr(..), SourceAnn, SourceSpan, everythingWithContextOnValues, everywhereWithContextOnValuesM, nonEmptySpan) import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), positionedError, singleError) import Language.PureScript.Traversals (defS) @@ -56,26 +57,41 @@ skolemizeTypesInValue ann ident mbK sko scope = runIdentity . onExpr' where onExpr' :: Expr -> Identity Expr - (_, onExpr', _, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS defS + (_, onExpr', _, _, _, _) = everywhereWithContextOnValuesM [] onDecl onExpr onBinder defS defS defS + + onDecl :: [Text] -> Declaration -> Identity ([Text], Declaration) + onDecl sco decl@(TypeSynonymDeclaration sa name args ty) + | ident `notElem` sco = return (sco ++ argNames, decl') + where + argNames = map fst args + decl' = + if ident `elem` argNames + then decl + else TypeSynonymDeclaration sa name (map (second . fmap $ skolemizeInner) args) (skolemizeInner ty) + onDecl sco (KindDeclaration sa kindFor name ty) = return (sco, KindDeclaration sa kindFor name (skolemizeInner ty)) + onDecl sco other = return (sco, other) onExpr :: [Text] -> Expr -> Identity ([Text], Expr) onExpr sco (DeferredDictionary c ts) - | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ann ident mbK sko scope) ts)) + | ident `notElem` sco = return (sco, DeferredDictionary c (map skolemizeInner ts)) onExpr sco (TypedValue check val ty) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ann ident mbK sko scope ty)) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemizeInner ty)) onExpr sco (VisibleTypeApp val ty) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, VisibleTypeApp val (skolemize ann ident mbK sko scope ty)) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, VisibleTypeApp val (skolemizeInner ty)) onExpr sco other = return (sco, other) onBinder :: [Text] -> Binder -> Identity ([Text], Binder) onBinder sco (TypedBinder ty b) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ann ident mbK sko scope ty) b) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemizeInner ty) b) onBinder sco other = return (sco, other) peelTypeVars :: SourceType -> [Text] peelTypeVars (ForAll _ _ i _ ty _) = i : peelTypeVars ty peelTypeVars _ = [] + skolemizeInner :: SourceType -> SourceType + skolemizeInner = skolemize ann ident mbK sko scope + -- | Ensure skolem variables do not escape their scope -- -- Every skolem variable is created when a 'ForAll' type is skolemized. diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3f758805c6..dca6cffc01 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -5,6 +5,7 @@ module Language.PureScript.TypeChecker.Types ( BindingGroupType(..) , typesOf , checkTypeKind + , checkDuplicateTypeArguments ) where {- @@ -35,11 +36,13 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Bifunctor (bimap) import Data.Either (partitionEithers) +import Data.Foldable (for_) import Data.Functor (($>)) import Data.List (transpose, (\\), partition, delete) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Text (Text) import Data.Traversable (for) +import Data.Tuple (swap) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Data.Set qualified as S @@ -48,11 +51,11 @@ import Data.IntSet qualified as IS import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment -import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) +import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU, positionedError, warnAndRethrow) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) -import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) +import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfLocalTypeSynonym, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope, newSkolemConstant, newSkolemScope, skolemEscapeCheck, skolemize, skolemizeTypesInValue) import Language.PureScript.TypeChecker.Subsumption (subsumes) @@ -610,8 +613,36 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do bindNames dict $ do makeBindingGroupVisible inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j +inferLetBinding seen (TypeSynonymDeclaration sa@(ss, _) name args ty : rest) ret j = do + moduleName <- unsafeCheckCurrentModule + typesInScope <- types <$> getEnv + let isTypeVarInScope var = Qualified (ByModuleName moduleName) (ProperName var) `M.member` typesInScope + (kind', ty') <- warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (positionedError ss)) $ do + checkDuplicateTypeArguments $ map fst args + let checkForAlls = tell . foldMap (errorMessage . ShadowedTypeVar) . filter isTypeVarInScope . collectTypeArgs + forM_ args $ \(arg, mbK) -> do + when (isTypeVarInScope arg) . tell . errorMessage . ShadowedTypeVar $ arg + forM_ mbK checkForAlls + checkForAlls ty + traverse replaceAllTypeSynonyms . swap =<< kindOfLocalTypeSynonym moduleName (sa, name, args, ty) + bindLocalTypeSynonym ss name args ty' kind' $ + inferLetBinding (seen ++ [TypeSynonymDeclaration sa name args ty']) rest ret j +inferLetBinding seen (KindDeclaration sa@(ss, _) kindFor name ty : rest) ret j = do + moduleName <- unsafeCheckCurrentModule + typesInScope <- types <$> getEnv + let isTypeVarInScope var = Qualified (ByModuleName moduleName) (ProperName var) `M.member` typesInScope + ty' <- warnAndRethrow (addHint (ErrorInKindDeclaration name) . addHint (positionedError ss)) $ do + tell . foldMap (errorMessage . ShadowedTypeVar) . filter isTypeVarInScope . collectTypeArgs $ ty + fst <$> kindOf ty + bindTypes (M.singleton (Qualified ByNullSourcePos name) (ty', LocalTypeVariable)) $ + inferLetBinding (seen ++ [KindDeclaration sa kindFor name ty']) rest ret j inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" +collectTypeArgs :: SourceType -> [Text] +collectTypeArgs = S.toAscList . everythingOnTypes (<>) (\case + ForAll _ _ arg _ _ _ -> S.singleton arg + _ -> mempty) + -- | Infer the types of variables brought into scope by a binder inferBinder :: forall m @@ -1038,3 +1069,13 @@ withErrorMessageHint' -> m a -> m a withErrorMessageHint' expr = if isInternal expr then const id else withErrorMessageHint + +checkDuplicateTypeArguments + :: (MonadState CheckState m, MonadError MultipleErrors m) + => [Text] + -> m () +checkDuplicateTypeArguments args = for_ firstDup $ \dup -> + throwError . errorMessage $ DuplicateTypeArgument dup + where + firstDup :: Maybe Text + firstDup = listToMaybe $ args \\ ordNub args diff --git a/tests/purs/failing/DuplicateDeclarationsInLet.out b/tests/purs/failing/DuplicateDeclarationsInLet.out index 038e5e23c9..f0307ac1f2 100644 --- a/tests/purs/failing/DuplicateDeclarationsInLet.out +++ b/tests/purs/failing/DuplicateDeclarationsInLet.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/DuplicateDeclarationsInLet.purs:9:3 - 9:14 (line 9, column 3 - line 9, column 14) - The name a was defined multiple times in a binding group + The value a was defined multiple times in a binding group See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, diff --git a/tests/purs/failing/DuplicateDeclarationsInLet2.out b/tests/purs/failing/DuplicateDeclarationsInLet2.out index 25957ecbc8..b5b5970434 100644 --- a/tests/purs/failing/DuplicateDeclarationsInLet2.out +++ b/tests/purs/failing/DuplicateDeclarationsInLet2.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/DuplicateDeclarationsInLet2.purs:10:3 - 10:24 (line 10, column 3 - line 10, column 24) - The name interrupted was defined multiple times in a binding group + The value interrupted was defined multiple times in a binding group See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, diff --git a/tests/purs/failing/DuplicateDeclarationsInLet3.out b/tests/purs/failing/DuplicateDeclarationsInLet3.out index 33d911057f..70fdb2d73c 100644 --- a/tests/purs/failing/DuplicateDeclarationsInLet3.out +++ b/tests/purs/failing/DuplicateDeclarationsInLet3.out @@ -3,7 +3,7 @@ Error 1 of 2: in module Main at tests/purs/failing/DuplicateDeclarationsInLet3.purs:9:3 - 9:11 (line 9, column 3 - line 9, column 11) - The name a was defined multiple times in a binding group + The value a was defined multiple times in a binding group See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, @@ -14,7 +14,7 @@ Error 2 of 2: in module Main at tests/purs/failing/DuplicateDeclarationsInLet3.purs:16:3 - 16:24 (line 16, column 3 - line 16, column 24) - The name interrupted was defined multiple times in a binding group + The value interrupted was defined multiple times in a binding group See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, diff --git a/tests/purs/failing/LocalStandaloneKindSignatures.out b/tests/purs/failing/LocalStandaloneKindSignatures.out new file mode 100644 index 0000000000..350cfb8a57 --- /dev/null +++ b/tests/purs/failing/LocalStandaloneKindSignatures.out @@ -0,0 +1,26 @@ +Error found: +in module Main +at tests/purs/failing/LocalStandaloneKindSignatures.purs:9:20 - 9:25 (line 9, column 20 - line 9, column 25) + + Could not match kind +   +  Symbol +   + with kind +   +  Type +   + +while checking that type "foo" + has kind Type +while inferring the kind of Fst Int "foo" +in type synonym F +while checking that expression result  +  where  +  result = 0 + has type Int +in value declaration foo + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalStandaloneKindSignatures.purs b/tests/purs/failing/LocalStandaloneKindSignatures.purs new file mode 100644 index 0000000000..f170e0dd80 --- /dev/null +++ b/tests/purs/failing/LocalStandaloneKindSignatures.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +foo :: Int +foo = result + where + type Fst :: forall k. k -> k -> k + type Fst a b = a + type F = Fst Int "foo" + result = 0 diff --git a/tests/purs/failing/LocalStandaloneKindSignatures2.out b/tests/purs/failing/LocalStandaloneKindSignatures2.out new file mode 100644 index 0000000000..469225a2f4 --- /dev/null +++ b/tests/purs/failing/LocalStandaloneKindSignatures2.out @@ -0,0 +1,26 @@ +Error found: +in module Main +at tests/purs/failing/LocalStandaloneKindSignatures2.purs:10:19 - 10:20 (line 10, column 19 - line 10, column 20) + + Could not match kind +   +  k +   + with kind +   +  Type +   + +in type synonym ConstK +while checking that expression Proxy  +  where + has type Proxy @t0 k1 +in value declaration foo + +where k1 is a rigid type variable + bound at (line 7, column 7 - line 7, column 36) + t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalStandaloneKindSignatures2.purs b/tests/purs/failing/LocalStandaloneKindSignatures2.purs new file mode 100644 index 0000000000..a704a6e232 --- /dev/null +++ b/tests/purs/failing/LocalStandaloneKindSignatures2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data Proxy a = Proxy + +foo :: forall k. Proxy k +foo = Proxy :: Proxy (ConstK "foo") + where + type ConstK :: forall k. k -> Type + type ConstK a = a diff --git a/tests/purs/failing/LocalTypeSynonyms.out b/tests/purs/failing/LocalTypeSynonyms.out new file mode 100644 index 0000000000..f8f8a8192a --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/failing/LocalTypeSynonyms.purs:7:3 - 7:21 (line 7, column 3 - line 7, column 21) + + A cycle appears in a set of type synonym definitions: + + {T1, T2} + + Cycles are disallowed because they can lead to loops in the type checker. + Consider using a 'newtype' instead. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms.purs b/tests/purs/failing/LocalTypeSynonyms.purs new file mode 100644 index 0000000000..982a59b7f6 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CycleInTypeSynonym +module Main where + +foo :: Int +foo = result + where + type T1 = Array T2 + type T2 = T1 + result = 0 diff --git a/tests/purs/failing/LocalTypeSynonyms10.out b/tests/purs/failing/LocalTypeSynonyms10.out new file mode 100644 index 0000000000..b04e3d3bd4 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms10.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms10.purs:9:13 - 9:18 (line 9, column 13 - line 9, column 18) + + Could not match kind +   +  Type +   + with kind +   +  forall k. k -> Type +   + +in type synonym A +while checking that expression 0  +  where + has type Int +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms10.purs b/tests/purs/failing/LocalTypeSynonyms10.purs new file mode 100644 index 0000000000..031dab1576 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms10.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data Proxy a = Proxy + +test :: Int +test = 0 + where + type A :: Proxy -- this should fail, not the actual synonym declaration + type A = "nope" diff --git a/tests/purs/failing/LocalTypeSynonyms11.out b/tests/purs/failing/LocalTypeSynonyms11.out new file mode 100644 index 0000000000..33dc20341e --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms11.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/LocalTypeSynonyms11.purs:7:3 - 7:16 (line 7, column 3 - line 7, column 16) + + A cycle appears in a set of kind declarations: + + {T1, T2} + + Kind declarations may not refer to themselves in their own signatures. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInKindDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms11.purs b/tests/purs/failing/LocalTypeSynonyms11.purs new file mode 100644 index 0000000000..de778f755c --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms11.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith CycleInKindDeclaration +module Main where + +foo :: Int +foo = result + where + type T1 :: T2 + type T1 = Type + type T2 :: T1 + type T2 = Type + result = 0 diff --git a/tests/purs/failing/LocalTypeSynonyms12.out b/tests/purs/failing/LocalTypeSynonyms12.out new file mode 100644 index 0000000000..fe122a7d0a --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms12.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms12.purs:8:3 - 8:18 (line 8, column 3 - line 8, column 18) + + The type T was defined multiple times in a binding group + + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms12.purs b/tests/purs/failing/LocalTypeSynonyms12.purs new file mode 100644 index 0000000000..efc606f563 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms12.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith OverlappingNamesInLet +module Main where + +foo :: Int +foo = result + where + type T = Int + type T = String + result = 0 diff --git a/tests/purs/failing/LocalTypeSynonyms2.out b/tests/purs/failing/LocalTypeSynonyms2.out new file mode 100644 index 0000000000..2180725779 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms2.out @@ -0,0 +1,11 @@ +Error found: +at tests/purs/failing/LocalTypeSynonyms2.purs:7:3 - 7:21 (line 7, column 3 - line 7, column 21) + + A cycle appears in the definition of type synonym T1 + Cycles are disallowed because they can lead to loops in the type checker. + Consider using a 'newtype' instead. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms2.purs b/tests/purs/failing/LocalTypeSynonyms2.purs new file mode 100644 index 0000000000..a29c0d6b0a --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CycleInTypeSynonym +module Main where + +foo :: Int +foo = result + where + type T1 = Array T1 + result = 0 diff --git a/tests/purs/failing/LocalTypeSynonyms3.out b/tests/purs/failing/LocalTypeSynonyms3.out new file mode 100644 index 0000000000..f5a1db149c --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms3.out @@ -0,0 +1,18 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms3.purs:10:14 - 10:17 (line 10, column 14 - line 10, column 17) + + Type synonym F is partially applied. + Type synonyms must be applied to all of their type arguments. + +in type synonym G +while checking that expression f identity  +  where  +  f = \k ->  +  k "Done" + has type String +in value declaration foo + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms3.purs b/tests/purs/failing/LocalTypeSynonyms3.purs new file mode 100644 index 0000000000..25cd6cac31 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms3.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +foo :: String +foo = f identity + where + type F x y = x -> y + type G x = F x + f :: G String String -> String + f k = k "Done" diff --git a/tests/purs/failing/LocalTypeSynonyms4.out b/tests/purs/failing/LocalTypeSynonyms4.out new file mode 100644 index 0000000000..fdc4b08965 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms4.out @@ -0,0 +1,30 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms4.purs:8:13 - 8:14 (line 8, column 13 - line 8, column 14) + + Could not match kind +   +  Type +   + with kind +   +  Row Type +   + +while checking that type a0 + has kind Row Type +while inferring the kind of T a0 +while checking that expression result  +  where  +  result = { wrapped: ... +  }  + has type { wrapped :: a0 + }  +in value declaration wrap + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms4.purs b/tests/purs/failing/LocalTypeSynonyms4.purs new file mode 100644 index 0000000000..6abfcfb9fb --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms4.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +wrap :: forall a. a -> { wrapped :: a } +wrap a = result + where + type T r = { wrapped :: a | r } + result :: T a + result = { wrapped: a } diff --git a/tests/purs/failing/LocalTypeSynonyms5.out b/tests/purs/failing/LocalTypeSynonyms5.out new file mode 100644 index 0000000000..d4c8b33c8d --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms5.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms5.purs:18:34 - 18:35 (line 18, column 34 - line 18, column 35) + + Could not match type +   +  { wrapped :: Int +  }  +   + with type +   +  Int +   + +while checking that type Int + is at least as general as type { wrapped :: Int + }  +while checking that expression 0 + has type { wrapped :: Int + }  +in value declaration foo + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms5.purs b/tests/purs/failing/LocalTypeSynonyms5.purs new file mode 100644 index 0000000000..9eeabe2de5 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms5.purs @@ -0,0 +1,18 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude + +-- Test that the inferred type doesn't leak the local type synonym in the +-- produced error message. + +intentionallyUntyped = wrap thing + where + type Wrapped a = { wrapped :: a } + wrap :: forall a. a -> Wrapped a + wrap wrapped = { wrapped } + thing :: Int + thing = 0 + +foo :: Int +foo = if intentionallyUntyped == 0 then 0 else 1 diff --git a/tests/purs/failing/LocalTypeSynonyms6.out b/tests/purs/failing/LocalTypeSynonyms6.out new file mode 100644 index 0000000000..34cac24868 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms6.out @@ -0,0 +1,23 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms6.purs:24:14 - 24:34 (line 24, column 14 - line 24, column 34) + + Could not match type +   +  Record +   + with type +   +  Wrapped +   + +while trying to match type { wrapped :: Int + }  + with type Wrapped Int +while checking that expression intentionallyUntyped + has type Wrapped Int +in value declaration foo + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms6.purs b/tests/purs/failing/LocalTypeSynonyms6.purs new file mode 100644 index 0000000000..af9d2cc95a --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms6.purs @@ -0,0 +1,24 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude + +-- Test that the inferred type doesn't leak and unify with the shadowed type +-- with the same name, and also that the error message doesn't include the +-- local type synonym. + +data Wrapped a = Wrapped a + +intentionallyUntyped = wrap thing + where + type Wrapped a = { wrapped :: a } + wrap :: forall a. a -> Wrapped a + wrap wrapped = { wrapped } + thing :: Int + thing = 0 + +unwrap :: Wrapped Int -> Int +unwrap (Wrapped w) = w + +foo :: Int +foo = unwrap intentionallyUntyped diff --git a/tests/purs/failing/LocalTypeSynonyms7.out b/tests/purs/failing/LocalTypeSynonyms7.out new file mode 100644 index 0000000000..14413001ba --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms7.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms7.purs:7:3 - 7:27 (line 7, column 3 - line 7, column 27) + + Type argument a appears more than once. + +in type synonym DoubleArg +while checking that expression result  +  where  +  result = 0 + has type Int +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateTypeArgument.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms7.purs b/tests/purs/failing/LocalTypeSynonyms7.purs new file mode 100644 index 0000000000..2b9bfc2bf7 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms7.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DuplicateTypeArgument +module Main where + +test :: Int +test = result + where + type DoubleArg a a = Int + result = 0 diff --git a/tests/purs/failing/LocalTypeSynonyms8.out b/tests/purs/failing/LocalTypeSynonyms8.out new file mode 100644 index 0000000000..6689aec7ce --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms8.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms8.purs:11:12 - 11:19 (line 11, column 12 - line 11, column 19) + + The type variable k, bound at + + tests/purs/failing/LocalTypeSynonyms8.purs:11:18 - 11:19 (line 11, column 18 - line 11, column 19) + + has escaped its scope, appearing in the type +   +  Proxy A +   + +in type synonym B +while checking that expression 0  +  where + has type Int +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/EscapedSkolem.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms8.purs b/tests/purs/failing/LocalTypeSynonyms8.purs new file mode 100644 index 0000000000..7076d9aa49 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms8.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith EscapedSkolem +module Main where + +data Proxy a = Proxy + +data A (a :: forall k. k -> Type) = A + +test :: Int +test = 0 + where + type B = Proxy A diff --git a/tests/purs/failing/LocalTypeSynonyms9.out b/tests/purs/failing/LocalTypeSynonyms9.out new file mode 100644 index 0000000000..24da9eb477 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms9.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/LocalTypeSynonyms9.purs:8:32 - 8:35 (line 8, column 32 - line 8, column 35) + + Could not match kind +   +  Type +   + with kind +   +  Symbol +   + +while checking that type Int + has kind Symbol +while inferring the kind of ShouldNotGeneralize Int +in type synonym A +while checking that expression 0  +  where + has type Int +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LocalTypeSynonyms9.purs b/tests/purs/failing/LocalTypeSynonyms9.purs new file mode 100644 index 0000000000..4b252aaf14 --- /dev/null +++ b/tests/purs/failing/LocalTypeSynonyms9.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +test :: Int +test = 0 + where + type ShouldNotGeneralize a = a + type A = ShouldNotGeneralize Int + type B = ShouldNotGeneralize "symbol" diff --git a/tests/purs/failing/SkolemEscapeKinds.out b/tests/purs/failing/SkolemEscapeKinds.out index a1732cc381..e5df9e409e 100644 --- a/tests/purs/failing/SkolemEscapeKinds.out +++ b/tests/purs/failing/SkolemEscapeKinds.out @@ -7,9 +7,9 @@ at tests/purs/failing/SkolemEscapeKinds.purs:8:10 - 8:17 (line 8, column 10 - li tests/purs/failing/SkolemEscapeKinds.purs:8:16 - 8:17 (line 8, column 16 - line 8, column 17) has escaped its scope, appearing in the type -   -  Proxy -   +   +  Proxy A +   in type synonym B diff --git a/tests/purs/passing/LocalStandaloneKindSignatures.purs b/tests/purs/passing/LocalStandaloneKindSignatures.purs new file mode 100644 index 0000000000..ac9304f1b2 --- /dev/null +++ b/tests/purs/passing/LocalStandaloneKindSignatures.purs @@ -0,0 +1,29 @@ +module Main where + +import Effect.Console (log) + +data Pair :: forall k. k -> k -> Type +data Pair a b = Pair + +data Proxy a = Proxy + +foo :: forall k (s :: k) (t :: k). Proxy s -> Proxy t -> Proxy k +foo = result + where + type Fst :: forall k. k -> k -> k + type Fst a b = a + + test1 = 42 :: Fst Int String + test2 = Pair :: Pair (Fst "foo" "bar") "baz" + + type ConstS :: forall t. t -> k + type ConstS a = s + + type Const :: forall k t. k -> t -> k + type Const s a = s + + result :: Proxy (ConstS "foo") -> Proxy (Const t "bar") -> Proxy k + result _ _ = Proxy + + +main = log "Done" diff --git a/tests/purs/passing/LocalTypeSynonyms.purs b/tests/purs/passing/LocalTypeSynonyms.purs new file mode 100644 index 0000000000..885b43742f --- /dev/null +++ b/tests/purs/passing/LocalTypeSynonyms.purs @@ -0,0 +1,52 @@ +module Main where + +import Prelude + +import Effect (Effect) +import Effect.Console (log) + +foo :: forall a. a -> { left :: Int, right :: a } +foo a = result + where + result = result' + where + type Bravo a = { left :: a, right :: Alpha } + result' :: Bravo Int + result' = { left: 0, right: a } + type Alpha = a + +bar :: Effect Int +bar = do + log "hello" + let type Alpha = Int + pure (1 :: Alpha) + +baz :: forall r a. { a :: a | r } -> { a :: a, b :: Int } +baz = f + where + type In = { a :: a | r } + type Out = { a :: a, b :: Int } + f :: In -> Out + f { a } = { a, b: 0 } + +kinded :: Effect Int +kinded = do + let type Alpha (a :: Type) = Type + let type Bravo (a :: Alpha String -> Type) = a Unit + let type Charlie (a :: Alpha String) = Int + pure (1 :: Bravo Charlie) + + +intentionallyUntyped = wrap thing + where + type Wrapped a = { wrapped :: a } + wrap :: forall a. a -> Wrapped a + wrap wrapped = { wrapped } + thing :: Int + thing = 0 + + +main :: Effect Unit +main = if intentionallyUntyped.wrapped == 0 + then log "Done" + else log "Fail" diff --git a/tests/purs/warning/2411.out b/tests/purs/warning/2411.out index 8798346cda..bdde5849e4 100644 --- a/tests/purs/warning/2411.out +++ b/tests/purs/warning/2411.out @@ -2,7 +2,7 @@ Warning found: in module Main at tests/purs/warning/2411.purs:11:7 - 11:15 (line 11, column 7 - line 11, column 15) - Name x was shadowed. + The value x was shadowed. in value declaration test diff --git a/tests/purs/warning/LocalStandaloneKindSignatures.out b/tests/purs/warning/LocalStandaloneKindSignatures.out new file mode 100644 index 0000000000..1168df1f8c --- /dev/null +++ b/tests/purs/warning/LocalStandaloneKindSignatures.out @@ -0,0 +1,25 @@ +Warning 1 of 2: + + in module Main + at tests/purs/warning/LocalStandaloneKindSignatures.purs:9:3 - 9:23 (line 9, column 3 - line 9, column 23) + + The type Foo was introduced but not used. + + in value declaration test + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 2 of 2: + + in module Main + at tests/purs/warning/LocalStandaloneKindSignatures.purs:8:3 - 8:34 (line 8, column 3 - line 8, column 34) + + Type variable a was shadowed. + + in kind declaration for Foo + in value declaration test + + See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalStandaloneKindSignatures.purs b/tests/purs/warning/LocalStandaloneKindSignatures.purs new file mode 100644 index 0000000000..3de60b76c3 --- /dev/null +++ b/tests/purs/warning/LocalStandaloneKindSignatures.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith UnusedName +-- @shouldWarnWith ShadowedTypeVar +module Main where + +test :: forall a. a -> a +test x = x + where + type Foo :: forall a. a -> Type + type Foo b = Boolean diff --git a/tests/purs/warning/LocalTypeSynonyms.out b/tests/purs/warning/LocalTypeSynonyms.out new file mode 100644 index 0000000000..37d404064e --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms.out @@ -0,0 +1,11 @@ +Warning found: +in module Main +at tests/purs/warning/LocalTypeSynonyms.purs:10:3 - 10:24 (line 10, column 3 - line 10, column 24) + + The type LocalApp was introduced but not used. + +in value declaration generalized + +See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalTypeSynonyms.purs b/tests/purs/warning/LocalTypeSynonyms.purs new file mode 100644 index 0000000000..71b7b8320b --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms.purs @@ -0,0 +1,10 @@ +-- @shouldWarnWith UnusedName +module Main where + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +generalized :: forall f. Proxy f -> Int +generalized _ = 0 + where + type LocalApp a = f a -- This is being tested not to warn about polymorphic kinds diff --git a/tests/purs/warning/LocalTypeSynonyms2.out b/tests/purs/warning/LocalTypeSynonyms2.out new file mode 100644 index 0000000000..93b38bdf79 --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms2.out @@ -0,0 +1,11 @@ +Warning found: +in module Main +at tests/purs/warning/LocalTypeSynonyms2.purs:9:3 - 9:21 (line 9, column 3 - line 9, column 21) + + The type Foo was shadowed. + +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalTypeSynonyms2.purs b/tests/purs/warning/LocalTypeSynonyms2.purs new file mode 100644 index 0000000000..124ab30191 --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms2.purs @@ -0,0 +1,11 @@ +-- @shouldWarnWith ShadowedName +module Main where + +type Foo = Int + +test :: Foo +test = if truth then 0 else 1 + where + type Foo = Boolean + truth :: Foo + truth = true diff --git a/tests/purs/warning/LocalTypeSynonyms3.out b/tests/purs/warning/LocalTypeSynonyms3.out new file mode 100644 index 0000000000..e0766902dd --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms3.out @@ -0,0 +1,12 @@ +Warning found: +in module Main +at tests/purs/warning/LocalTypeSynonyms3.purs:7:3 - 7:23 (line 7, column 3 - line 7, column 23) + + Type variable a was shadowed. + +in type synonym Foo +in binding group test + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalTypeSynonyms3.purs b/tests/purs/warning/LocalTypeSynonyms3.purs new file mode 100644 index 0000000000..a07de5856e --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms3.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith ShadowedTypeVar +module Main where + +test :: forall a. a -> a +test x = if truth then x else test x + where + type Foo a = Boolean + truth :: Foo Int + truth = true diff --git a/tests/purs/warning/LocalTypeSynonyms4.out b/tests/purs/warning/LocalTypeSynonyms4.out new file mode 100644 index 0000000000..59c60e53ed --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms4.out @@ -0,0 +1,12 @@ +Warning found: +in module Main +at tests/purs/warning/LocalTypeSynonyms4.purs:7:3 - 7:30 (line 7, column 3 - line 7, column 30) + + Type variable a was shadowed. + +in type synonym Foo +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalTypeSynonyms4.purs b/tests/purs/warning/LocalTypeSynonyms4.purs new file mode 100644 index 0000000000..2be684d3f2 --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms4.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith ShadowedTypeVar +module Main where + +test :: forall a. a -> a +test x = id x + where + type Foo = forall a. a -> a + id :: Foo + id y = y diff --git a/tests/purs/warning/LocalTypeSynonyms5.out b/tests/purs/warning/LocalTypeSynonyms5.out new file mode 100644 index 0000000000..56ef778445 --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms5.out @@ -0,0 +1,25 @@ +Warning 1 of 2: + + in module Main + at tests/purs/warning/LocalTypeSynonyms5.purs:8:3 - 8:47 (line 8, column 3 - line 8, column 47) + + The type Foo was introduced but not used. + + in value declaration test + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 2 of 2: + + in module Main + at tests/purs/warning/LocalTypeSynonyms5.purs:8:3 - 8:47 (line 8, column 3 - line 8, column 47) + + Type variable a was shadowed. + + in type synonym Foo + in value declaration test + + See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalTypeSynonyms5.purs b/tests/purs/warning/LocalTypeSynonyms5.purs new file mode 100644 index 0000000000..a57304a26f --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms5.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith UnusedName +-- @shouldWarnWith ShadowedTypeVar +module Main where + +test :: forall a. a -> a +test x = x + where + type Foo (f :: forall a. a -> a) = f Boolean diff --git a/tests/purs/warning/LocalTypeSynonyms6.out b/tests/purs/warning/LocalTypeSynonyms6.out new file mode 100644 index 0000000000..259206f163 --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms6.out @@ -0,0 +1,24 @@ +Warning 1 of 2: + + in module Main + at tests/purs/warning/LocalTypeSynonyms6.purs:12:3 - 12:21 (line 12, column 3 - line 12, column 21) + + The type Foo was introduced but not used. + + in value declaration test1 + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 2 of 2: + + in module Main + at tests/purs/warning/LocalTypeSynonyms6.purs:16:7 - 16:25 (line 16, column 7 - line 16, column 25) + + The type Foo was introduced but not used. + + in value declaration test2 + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalTypeSynonyms6.purs b/tests/purs/warning/LocalTypeSynonyms6.purs new file mode 100644 index 0000000000..21584932ad --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms6.purs @@ -0,0 +1,30 @@ +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +module Main where + +import Prelude + +import Effect (Effect) + +test1 :: Int +test1 = 0 + where + type Foo = Boolean + +test2 :: Effect Int +test2 = do + let type Foo = Boolean + pure 0 + +test3 :: Int +test3 = if truth then 0 else 1 + where + type Foo = Boolean + truth = (true :: Foo) + +test4 :: Effect Int +test4 = do + let type Foo = Boolean + truth :: Foo + truth = true + pure $ if truth then 0 else 1 diff --git a/tests/purs/warning/LocalTypeSynonyms7.out b/tests/purs/warning/LocalTypeSynonyms7.out new file mode 100644 index 0000000000..9e8d3095b4 --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms7.out @@ -0,0 +1,11 @@ +Warning found: +in module Main +at tests/purs/warning/LocalTypeSynonyms7.purs:11:5 - 11:23 (line 11, column 5 - line 11, column 23) + + The type Foo was shadowed. + +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/LocalTypeSynonyms7.purs b/tests/purs/warning/LocalTypeSynonyms7.purs new file mode 100644 index 0000000000..26f9f6f838 --- /dev/null +++ b/tests/purs/warning/LocalTypeSynonyms7.purs @@ -0,0 +1,13 @@ +-- @shouldWarnWith ShadowedName +module Main where + +test :: Int +test = result + where + type Foo = Int + result :: Foo + result = if truth then 0 else 1 + where + type Foo = Boolean + truth :: Foo + truth = true diff --git a/tests/purs/warning/ShadowedBinderPatternGuard.out b/tests/purs/warning/ShadowedBinderPatternGuard.out index b3918f5358..83d09b3640 100644 --- a/tests/purs/warning/ShadowedBinderPatternGuard.out +++ b/tests/purs/warning/ShadowedBinderPatternGuard.out @@ -2,7 +2,7 @@ Warning found: in module Main at tests/purs/warning/ShadowedBinderPatternGuard.purs:6:7 - 6:8 (line 6, column 7 - line 6, column 8) - Name i was shadowed. + The value i was shadowed. in value declaration f diff --git a/tests/purs/warning/ShadowedNameParens.out b/tests/purs/warning/ShadowedNameParens.out index 7a0e22f64c..c7638dd07c 100644 --- a/tests/purs/warning/ShadowedNameParens.out +++ b/tests/purs/warning/ShadowedNameParens.out @@ -2,7 +2,7 @@ Warning found: in module Main at tests/purs/warning/ShadowedNameParens.purs:7:5 - 7:6 (line 7, column 5 - line 7, column 6) - Name n was shadowed. + The value n was shadowed. in value declaration f diff --git a/tests/purs/warning/UnusedVar.out b/tests/purs/warning/UnusedVar.out index 7556b6ebb6..4bbf7390fc 100644 --- a/tests/purs/warning/UnusedVar.out +++ b/tests/purs/warning/UnusedVar.out @@ -3,7 +3,7 @@ Warning 1 of 9: in module Main at tests/purs/warning/UnusedVar.purs:16:20 - 16:32 (line 16, column 20 - line 16, column 32) - Name lambdaUnused was introduced but not used. + The value lambdaUnused was introduced but not used. in value declaration unusedInLambda @@ -15,7 +15,7 @@ Warning 2 of 9: in module Main at tests/purs/warning/UnusedVar.purs:20:7 - 20:20 (line 20, column 7 - line 20, column 20) - Name letUnused was introduced but not used. + The value letUnused was introduced but not used. in value declaration unusedLetName @@ -27,7 +27,7 @@ Warning 3 of 9: in module Main at tests/purs/warning/UnusedVar.purs:26:9 - 26:24 (line 26, column 9 - line 26, column 24) - Name whereUnused was introduced but not used. + The value whereUnused was introduced but not used. in value declaration unusedWhereIsLet @@ -39,7 +39,7 @@ Warning 4 of 9: in module Main at tests/purs/warning/UnusedVar.purs:30:11 - 30:23 (line 30, column 11 - line 30, column 23) - Name letArgUnused was introduced but not used. + The value letArgUnused was introduced but not used. in value declaration unusedLetArgument @@ -51,7 +51,7 @@ Warning 5 of 9: in module Main at tests/purs/warning/UnusedVar.purs:44:5 - 44:15 (line 44, column 5 - line 44, column 15) - Name caseUnused was introduced but not used. + The value caseUnused was introduced but not used. in value declaration unusedCaseBinder @@ -63,7 +63,7 @@ Warning 6 of 9: in module Main at tests/purs/warning/UnusedVar.purs:62:34 - 62:35 (line 62, column 34 - line 62, column 35) - Name x was introduced but not used. + The value x was introduced but not used. in value declaration unusedShadowedByRecursiveBinding @@ -75,7 +75,7 @@ Warning 7 of 9: in module Main at tests/purs/warning/UnusedVar.purs:69:8 - 69:9 (line 69, column 8 - line 69, column 9) - Name x was introduced but not used. + The value x was introduced but not used. in value declaration unusedShadowingLet @@ -87,7 +87,7 @@ Warning 8 of 9: in module Main at tests/purs/warning/UnusedVar.purs:87:7 - 87:8 (line 87, column 7 - line 87, column 8) - Name x was introduced but not used. + The value x was introduced but not used. in value declaration notOops @@ -99,7 +99,7 @@ Warning 9 of 9: in module Main at tests/purs/warning/UnusedVar.purs:63:7 - 63:16 (line 63, column 7 - line 63, column 16) - Name x was shadowed. + The value x was shadowed. in value declaration unusedShadowedByRecursiveBinding diff --git a/tests/purs/warning/UnusedVarDecls.out b/tests/purs/warning/UnusedVarDecls.out index 58b2f20c78..bd80f1466f 100644 --- a/tests/purs/warning/UnusedVarDecls.out +++ b/tests/purs/warning/UnusedVarDecls.out @@ -3,7 +3,7 @@ Warning 1 of 2: in module Main at tests/purs/warning/UnusedVarDecls.purs:13:15 - 13:24 (line 13, column 15 - line 13, column 24) - Name unusedArg was introduced but not used. + The value unusedArg was introduced but not used. in value declaration unusedArgDecl diff --git a/tests/purs/warning/UnusedVarDo.out b/tests/purs/warning/UnusedVarDo.out index b25475df00..a3a4f1bf12 100644 --- a/tests/purs/warning/UnusedVarDo.out +++ b/tests/purs/warning/UnusedVarDo.out @@ -3,7 +3,7 @@ Warning 1 of 4: in module Main at tests/purs/warning/UnusedVarDo.purs:12:3 - 12:15 (line 12, column 3 - line 12, column 15) - Name unusedDoBind was introduced but not used. + The value unusedDoBind was introduced but not used. in value declaration unusedDoBinding @@ -15,7 +15,7 @@ Warning 2 of 4: in module Main at tests/purs/warning/UnusedVarDo.purs:24:7 - 24:23 (line 24, column 7 - line 24, column 23) - Name unusedDoLet was introduced but not used. + The value unusedDoLet was introduced but not used. in value declaration unusedDoLetBinding @@ -27,7 +27,7 @@ Warning 3 of 4: in module Main at tests/purs/warning/UnusedVarDo.purs:29:3 - 29:16 (line 29, column 3 - line 29, column 16) - Name unusedAdoBind was introduced but not used. + The value unusedAdoBind was introduced but not used. in value declaration unusedAdoBinding @@ -39,7 +39,7 @@ Warning 4 of 4: in module Main at tests/purs/warning/UnusedVarDo.purs:34:7 - 34:24 (line 34, column 7 - line 34, column 24) - Name unusedAdoLet was introduced but not used. + The value unusedAdoLet was introduced but not used. in value declaration unusedAdoLetBinding