Content-Length: 72870 | pFad | http://github.com/purescript/purescript/pull/3824.diff
thub.com diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index d7249be9dd..84b0dfa99e 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -440,19 +440,34 @@ pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (V pattern TypeFixityDeclaration :: SourceAnn -> Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (TypeFixity fixity name op)) +data DerivingStrategy + = DeriveNewtype + | DeriveVia SourceType + deriving (Show) + -- | The members of a type class instance declaration data TypeInstanceBody - = DerivedInstance + = DerivedInstance (Maybe (DerivingStrategy)) -- ^ This is a derived instance - | NewtypeInstance - -- ^ This is an instance derived from a newtype | NewtypeInstanceWithDictionary Expr -- ^ This is an instance derived from a newtype, desugared to include a -- dictionary for the type under the newtype. + | ViaInstanceWithDictionary SourceType Expr + -- ^ This is an instance derived via another type, desugared to include a + -- dictionary for the `via` type. | ExplicitInstance [Declaration] -- ^ This is a regular (explicit) instance deriving (Show) +pattern DerivedInstanceWithDictionary :: Expr -> TypeInstanceBody +pattern DerivedInstanceWithDictionary dict <- (derivedInstanceDict -> Just dict) + +derivedInstanceDict :: TypeInstanceBody -> Maybe Expr +derivedInstanceDict = \case + NewtypeInstanceWithDictionary dict -> Just dict + ViaInstanceWithDictionary _ dict -> Just dict + _ -> Nothing + mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index b8b57944bf..497f1960bd 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -479,12 +479,15 @@ convertDeclaration fileName decl = case decl of (convertType fileName <$> args) (AST.ExplicitInstance $ goInstanceBinding <$> maybe [] (NE.toList . snd) bd) uncurry goInst <$> zip [0..] (toList insts) - DeclDerive _ _ new (InstanceHead _ name _ ctrs cls args) -> do + DeclDerive _ _ strat (InstanceHead _ name _ ctrs cls args) -> do let name' = ident $ nameValue name - instTy - | isJust new = AST.NewtypeInstance - | otherwise = AST.DerivedInstance + instTy = case strat of + Just DeriveNewtype{} -> + AST.DerivedInstance (Just AST.DeriveNewtype) + Just (DeriveVia _ _ viaTy) -> + AST.DerivedInstance (Just (AST.DeriveVia $ convertType fileName viaTy)) + _ -> AST.DerivedInstance Nothing pure $ AST.TypeInstanceDeclaration ann [name'] 0 name' (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) (qualified cls) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 7f234ff168..e446b3bf05 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -35,7 +35,7 @@ import qualified Language.PureScript.Roles as R import Language.PureScript.PSString (PSString) } -%expect 95 +%expect 98 %name parseType type %name parseExpr expr @@ -123,6 +123,7 @@ import Language.PureScript.PSString (PSString) 'then' { SourceToken _ (TokLowerName [] "then") } 'true' { SourceToken _ (TokLowerName [] "true") } 'type' { SourceToken _ (TokLowerName [] "type") } + 'via' { SourceToken _ (TokLowerName [] "via") } 'where' { SourceToken _ (TokLowerName [] "where") } '(->)' { SourceToken _ (TokSymbolArr _) } '(..)' { SourceToken _ (TokSymbolName [] "..") } @@ -197,6 +198,7 @@ qualIdent :: { QualifiedName Ident } | 'nominal' {% toQualifiedName Ident $1 } | 'representational' {% toQualifiedName Ident $1 } | 'phantom' {% toQualifiedName Ident $1 } + | 'via' {% toQualifiedName Ident $1 } ident :: { Name Ident } : LOWER {% toName Ident $1 } @@ -207,6 +209,7 @@ ident :: { Name Ident } | 'nominal' {% toName Ident $1 } | 'representational' {% toName Ident $1 } | 'phantom' {% toName Ident $1 } + | 'via' {% toName Ident $1 } qualOp :: { QualifiedOpName } : OPERATOR {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } @@ -267,6 +270,7 @@ label :: { Label } | 'then' { toLabel $1 } | 'true' { toLabel $1 } | 'type' { toLabel $1 } + | 'via' { toLabel $1 } | 'where' { toLabel $1 } hole :: { Name Ident } @@ -672,7 +676,7 @@ decl :: { Declaration () } | 'newtype' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) } | 'type' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) } | 'derive' instHead { DeclDerive () $1 Nothing $2 } - | 'derive' 'newtype' instHead { DeclDerive () $1 (Just $2) $3 } + | 'derive' derivingStrategy instHead { DeclDerive () $1 (Just $2) $3 } | ident '::' type { DeclSignature () (Labeled $1 $2 $3) } | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) } | fixity { DeclFixity () $1 } @@ -735,6 +739,10 @@ fundep :: { ClassFundep } classMember :: { Labeled (Name Ident) (Type ()) } : ident '::' type {% checkNoWildcards $3 *> pure (Labeled $1 $2 $3) } +derivingStrategy :: { DerivingStrategy () } + : 'newtype' { DeriveNewtype () $1 } + | 'via' typeAtom { DeriveVia () $1 $2 } + instHead :: { InstanceHead () } : 'instance' ident '::' constraints '=>' qualProperName manyOrEmpty(typeAtom) { InstanceHead $1 $2 $3 (Just ($4, $5)) (getQualifiedProperName $6) $7 } diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs index c35c3e9d07..89e7a016bc 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs @@ -198,7 +198,7 @@ data Declaration a | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a)))) | DeclInstanceChain a (Separated (Instance a)) - | DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a) + | DeclDerive a SourceToken (Maybe (DerivingStrategy a)) (InstanceHead a) | DeclKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a)) | DeclSignature a (Labeled (Name Ident) (Type a)) | DeclValue a (ValueBindingFields a) @@ -259,6 +259,11 @@ data ClassFundep | FundepDetermines (NonEmpty (Name Ident)) SourceToken (NonEmpty (Name Ident)) deriving (Show, Eq, Ord, Generic) +data DerivingStrategy a + = DeriveNewtype a SourceToken + | DeriveVia a SourceToken (Type a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + data InstanceHead a = InstanceHead { instKeyword :: SourceToken , instName :: Name Ident diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 90dfc43fdd..b4202656fc 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -21,6 +21,7 @@ import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) import Data.List (transpose, nubBy, partition, dropWhileEnd, sort, sortBy) import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M import Data.Ord (comparing) @@ -106,12 +107,17 @@ data SimpleErrorMessage | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType] + | CannotDeriveNullaryTypeClassInstance DerivingStrategy (Qualified (ProperName 'ClassName)) | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [SourceType] - | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] - | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] + | InvalidViaType (Qualified (ProperName 'ClassName)) [SourceType] SourceType + | InvalidViaKind (Qualified (ProperName 'ClassName)) [SourceType] SourceType SourceType SourceType + | FloatingViaTypeVariables (Qualified (ProperName 'ClassName)) [SourceType] SourceType (NEL.NonEmpty Text) + | MissingSuperclassInstance DerivingStrategy (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] + | UnverifiableSuperclassInstance DerivingStrategy (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] | CannotFindDerivingType (ProperName 'TypeName) + | CannotFindViaType (ProperName 'TypeName) | DuplicateLabel Label (Maybe Expr) | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident @@ -265,12 +271,17 @@ errorCode em = case unwrapErrorMessage em of UnknownClass{} -> "UnknownClass" PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" CannotDerive{} -> "CannotDerive" + CannotDeriveNullaryTypeClassInstance{} -> "CannotDeriveNullaryTypeClassInstance" InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" - MissingNewtypeSuperclassInstance{} -> "MissingNewtypeSuperclassInstance" + InvalidViaType{} -> "InvalidViaType" + InvalidViaKind{} -> "InvalidViaKind" + FloatingViaTypeVariables{} -> "FloatingViaTypeVariables" + MissingSuperclassInstance{} -> "MissingSuperclassInstance" UnverifiableSuperclassInstance{} -> "UnverifiableSuperclassInstance" InvalidDerivedInstance{} -> "InvalidDerivedInstance" ExpectedTypeConstructor{} -> "ExpectedTypeConstructor" CannotFindDerivingType{} -> "CannotFindDerivingType" + CannotFindViaType{} -> "CannotFindViaType" DuplicateLabel{} -> "DuplicateLabel" DuplicateValueDeclaration{} -> "DuplicateValueDeclaration" ArgListLengthsDiffer{} -> "ArgListLengthsDiffer" @@ -434,9 +445,13 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts + gSimple (CannotDeriveNullaryTypeClassInstance strat cl) = pure $ CannotDeriveNullaryTypeClassInstance strat cl gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts - gSimple (MissingNewtypeSuperclassInstance cl1 cl2 ts) = MissingNewtypeSuperclassInstance cl1 cl2 <$> traverse f ts - gSimple (UnverifiableSuperclassInstance cl1 cl2 ts) = UnverifiableSuperclassInstance cl1 cl2 <$> traverse f ts + gSimple (InvalidViaType cl ts viaTy) = InvalidViaType cl <$> traverse f ts <*> f viaTy + gSimple (InvalidViaKind cl ts viaTy viaKind expectedKind) = InvalidViaKind cl <$> traverse f ts <*> f viaTy <*> f viaKind <*> f expectedKind + gSimple (FloatingViaTypeVariables cl ts viaTy viaTyVars) = FloatingViaTypeVariables cl <$> traverse f ts <*> f viaTy <*> pure viaTyVars + gSimple (MissingSuperclassInstance strat cl1 cl2 ts) = MissingSuperclassInstance strat cl1 cl2 <$> traverse f ts + gSimple (UnverifiableSuperclassInstance strat cl1 cl2 ts) = UnverifiableSuperclassInstance strat cl1 cl2 <$> traverse f ts gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k @@ -891,6 +906,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] , line "since instances of this type class are not derivable." ] + renderSimpleErrorMessage (CannotDeriveNullaryTypeClassInstance DeriveNewtype nm) = + paras [ line $ "Cannot derive newtype instance for" + , markCodeBox $ indent $ line (showQualified runProperName nm) + , line "Nullary type classes cannot be derived." + ] + renderSimpleErrorMessage (CannotDeriveNullaryTypeClassInstance (DeriveVia viaTy) nm) = + paras [ line $ "Cannot derive instance via " <> markCode (T.pack $ prettyPrintTypeSimplifiedInline viaTy) <> " for" + , markCodeBox $ indent $ line (showQualified runProperName nm) + , line "Nullary type classes cannot be derived." + ] renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) = paras [ line "Cannot derive newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left @@ -899,21 +924,94 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] , line "Make sure this is a newtype." ] - renderSimpleErrorMessage (MissingNewtypeSuperclassInstance su cl ts) = - paras [ line "The derived newtype instance for" + renderSimpleErrorMessage (InvalidViaType nm ts viaTy) = + paras [ line $ "Cannot derive instance via " <> markCode (T.pack $ prettyPrintTypeSimplifiedInline viaTy) <> " for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + ] + , line $ T.intercalate " " + [ "because the type" + , markCode . T.pack $ prettyPrintTypeSimplifiedInline viaTy + , "is not of the required form T a_1 ... a_n." + ] + ] + renderSimpleErrorMessage (InvalidViaKind nm ts viaTy viaKind expectedKind) = + paras [ line $ "Cannot derive instance via " <> markCode (T.pack $ prettyPrintTypeSimplifiedInline viaTy) <> " for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + ] + , line $ T.intercalate " " + [ "because" + , markCode . T.pack $ prettyPrintTypeSimplifiedInline (last ts) + , "has kind" + , markCode . T.pack $ prettyPrintTypeSimplifiedInline expectedKind + , "but" + , markCode . T.pack $ prettyPrintTypeSimplifiedInline viaTy + , "has kind" + , markCode (T.pack $ prettyPrintTypeSimplifiedInline viaKind) <> "." + ] + ] + renderSimpleErrorMessage (FloatingViaTypeVariables nm ts viaTy viaTyVars) = + paras [ line $ "Cannot derive instance via " <> markCode (T.pack $ prettyPrintTypeSimplifiedInline viaTy) <> " for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + ] + , line $ T.intercalate " " $ + "because" : case viaTyVars of + tv :| [] -> + [ "the type variable" + , markCode tv + , "is" + ] + _ -> + [ "type variables" + , T.intercalate ", " $ + markCode <$> NEL.init viaTyVars + , "and" + , markCode $ NEL.last viaTyVars + , "are" + ] + ++ [ "bound in" + , markCode . T.pack $ prettyPrintTypeSimplifiedInline viaTy + , "but" + , if length viaTyVars == 1 then "is" else "are" + , "not mentioned in the instance head." + ] + ] + renderSimpleErrorMessage (MissingSuperclassInstance DeriveNewtype su cl ts) = + paras [ line $ "The derived newtype instance for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName cl) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + ] + , line $ "implies a missing superclass instance for " <> markCode (showQualified runProperName su) <> "." + ] + renderSimpleErrorMessage (MissingSuperclassInstance (DeriveVia viaTy) su cl ts) = + paras [ line $ "The derived instance via " <> markCode (T.pack $ prettyPrintTypeSimplifiedInline viaTy) <> " for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName cl) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + ] + , line $ "implies a missing superclass instance for " <> markCode (showQualified runProperName su) <> "." + ] + renderSimpleErrorMessage (UnverifiableSuperclassInstance DeriveNewtype su cl ts) = + paras [ line $ "The derived newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cl) , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] - , line $ "does not include a derived superclass instance for " <> markCode (showQualified runProperName su) <> "." + , line $ "implies a superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified." ] - renderSimpleErrorMessage (UnverifiableSuperclassInstance su cl ts) = - paras [ line "The derived newtype instance for" + renderSimpleErrorMessage (UnverifiableSuperclassInstance (DeriveVia viaTy) su cl ts) = + paras [ line $ "The derived instance via " <> markCode (T.pack $ prettyPrintTypeSimplifiedInline viaTy) <> " for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cl) , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] - , line $ "implies an superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified." + , line $ "implies a superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified." ] renderSimpleErrorMessage (InvalidDerivedInstance nm ts argCount) = paras [ line "Cannot derive the type class instance" @@ -943,6 +1041,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found." + renderSimpleErrorMessage (CannotFindViaType nm) = + line $ "Cannot derive a type class instance via " <> markCode (runProperName nm) <> " because its type declaration could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = paras $ [ line $ "Label " <> markCode (prettyPrintLabel l) <> " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " @@ -1547,8 +1647,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where isSolverHint ErrorSolvingConstraint{} = True isSolverHint _ = False + stripRedundantHints InvalidViaType{} = stripFirst isInstanceHint + stripRedundantHints InvalidViaKind{} = stripFirst isInstanceHint + stripRedundantHints FloatingViaTypeVariables{} = stripFirst isInstanceHint stripRedundantHints _ = id + isInstanceHint ErrorInInstance{} = True + isInstanceHint _ = False + stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint] stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs @@ -1613,6 +1719,10 @@ prettyPrintKindSignatureFor NewtypeSig = "newtype" prettyPrintKindSignatureFor TypeSynonymSig = "type" prettyPrintKindSignatureFor ClassSig = "class" +prettyPrintTypeSimplifiedInline :: Type a -> String +prettyPrintTypeSimplifiedInline = + unwords . lines . prettyPrintType maxBound . eraseForAllKindAnnotations . eraseKindApps + prettyPrintSuggestedTypeSimplified :: Type a -> String prettyPrintSuggestedTypeSimplified = prettyPrintSuggestedType . eraseForAllKindAnnotations . eraseKindApps diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index ae1c2de5e7..495556448d 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -215,13 +215,16 @@ renameInModule imports (Module modSS coms mn decls exps) = <*> updateConstraints ss implies <*> pure deps <*> pure ds - updateDecl bound (TypeInstanceDeclaration sa@(ss, _) ch idx name cs cn ts ds) = + updateDecl bound (TypeInstanceDeclaration sa@(ss, _) ch idx name cs cn ts body) = fmap (bound,) $ TypeInstanceDeclaration sa ch idx name <$> updateConstraints ss cs <*> updateClassName cn ss <*> traverse updateTypesEverywhere ts - <*> pure ds + <*> case body of + DerivedInstance (Just (DeriveVia viaTy)) -> + DerivedInstance . Just . DeriveVia <$> updateTypesEverywhere viaTy + _ -> pure body updateDecl bound (KindDeclaration sa kindFor name ty) = fmap (bound,) $ KindDeclaration sa kindFor name diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index d79e88a070..03906c2706 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -322,10 +322,14 @@ updateTypes goType = (goDecl, goExpr, goBinder) goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do implies' <- traverse (overConstraintArgs (traverse (goType' ss))) implies return $ TypeClassDeclaration sa name args implies' deps decls - goDecl (TypeInstanceDeclaration sa@(ss, _) ch idx name cs className tys impls) = do + goDecl (TypeInstanceDeclaration sa@(ss, _) ch idx name cs className tys body) = do cs' <- traverse (overConstraintArgs (traverse (goType' ss))) cs tys' <- traverse (goType' ss) tys - return $ TypeInstanceDeclaration sa ch idx name cs' className tys' impls + body' <- case body of + DerivedInstance (Just (DeriveVia viaTy)) -> + DerivedInstance . Just . DeriveVia <$> goType' ss viaTy + _ -> return body + return $ TypeInstanceDeclaration sa ch idx name cs' className tys' body' goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = TypeSynonymDeclaration sa name args <$> goType' ss ty goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index b63f090f72..0c2b9df702 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -205,12 +205,12 @@ desugarDecl mn exps = go go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" + go (TypeInstanceDeclaration _ _ _ _ _ _ _ (DerivedInstance _)) = internalError "Derived instanced should have been desugared" go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) = do desugared <- desugarCases members dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) - go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do + go d@(TypeInstanceDeclaration sa _ _ name deps className tys (DerivedInstanceWithDictionary dict)) = do let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys constrainedTy = quantify (foldr (srcConstrainedType) dictTy deps) return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 009777571a..7fa86e62c8 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -30,33 +30,30 @@ import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) import Language.PureScript.TypeChecker.Synonyms (SynonymMap, KindMap, replaceAllTypeSynonymsM) --- | When deriving an instance for a newtype, we must ensure that all superclass --- instances were derived in the same way. This data structure is used to ensure --- this property. -data NewtypeDerivedInstances = NewtypeDerivedInstances - { ndiClasses :: M.Map (ModuleName, ProperName 'ClassName) ([Text], [SourceConstraint], [FunctionalDependency]) - -- ^ A list of superclass constraints for each type class. Since type classes - -- have not been desugared here, we need to track this. - , ndiDerivedInstances :: S.Set ((ModuleName, ProperName 'ClassName), (ModuleName, ProperName 'TypeName)) - -- ^ A list of newtype instances which were derived in this module. +-- | When deriving an instance we must ensure that all superclass are implemented. +data VerifySuperclassesEnv = VerifySuperclassesEnv + { classes :: M.Map (ModuleName, ProperName 'ClassName) ([Text], [SourceConstraint], [FunctionalDependency]) + -- ^ Since type classes have not been desugared yet we need to track their data. + , instances :: S.Set ((ModuleName, ProperName 'ClassName), (ModuleName, ProperName 'TypeName)) } deriving Show -instance Semigroup NewtypeDerivedInstances where +instance Semigroup VerifySuperclassesEnv where x <> y = - NewtypeDerivedInstances { ndiClasses = ndiClasses x <> ndiClasses y - , ndiDerivedInstances = ndiDerivedInstances x <> ndiDerivedInstances y - } + VerifySuperclassesEnv + { classes = classes x <> classes y + , instances = instances x <> instances y + } -instance Monoid NewtypeDerivedInstances where - mempty = NewtypeDerivedInstances mempty mempty +instance Monoid VerifySuperclassesEnv where + mempty = VerifySuperclassesEnv mempty mempty --- | Extract the name of the newtype appearing in the last type argument of --- a derived newtype instance. +-- | Extract the name of the type appearing in the last type argument of +-- a derived instance. -- --- Note: since newtypes in newtype instances can only be applied to type arguments +-- Note: since types in derived instances can only be applied to type arguments -- (no flexible instances allowed), we don't need to bother with unification when -- looking for matching superclass instances, which saves us a lot of work. Instead, --- we just match the newtype name. +-- we just match the type name. extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName) extractNewtypeName _ [] = Nothing extractNewtypeName mn xs = go (last xs) where @@ -72,7 +69,7 @@ deriveInstances -> Module -> m Module deriveInstances externs (Module ss coms mn ds exts) = - Module ss coms mn <$> mapM (deriveInstance mn synonyms kinds instanceData ds) ds <*> pure exts + Module ss coms mn <$> mapM (deriveInstance mn synonyms kinds verifySuperClassesEnv ds) ds <*> pure exts where kinds :: KindMap kinds = mempty @@ -91,20 +88,20 @@ deriveInstances externs (Module ss coms mn ds exts) = Just (Qualified (Just mn) name, (args, ty)) fromLocalDecl _ = Nothing - instanceData :: NewtypeDerivedInstances - instanceData = + verifySuperClassesEnv :: VerifySuperclassesEnv + verifySuperClassesEnv = foldMap (\ExternsFile{..} -> foldMap (fromExternsDecl efModuleName) efDeclarations) externs <> foldMap fromLocalDecl ds where fromExternsDecl mn' EDClass{..} = - NewtypeDerivedInstances (M.singleton (mn', edClassName) (map fst edClassTypeArguments, edClassConstraints, edFunctionalDependencies)) mempty + VerifySuperclassesEnv (M.singleton (mn', edClassName) (map fst edClassTypeArguments, edClassConstraints, edFunctionalDependencies)) mempty fromExternsDecl mn' EDInstance{..} = - foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn' edInstanceClassName, nm))) (extractNewtypeName mn' edInstanceTypes) + foldMap (\nm -> VerifySuperclassesEnv mempty (S.singleton (qualify mn' edInstanceClassName, nm))) (extractNewtypeName mn' edInstanceTypes) fromExternsDecl _ _ = mempty fromLocalDecl (TypeClassDeclaration _ cl args cons deps _) = - NewtypeDerivedInstances (M.singleton (mn, cl) (map fst args, cons, deps)) mempty + VerifySuperclassesEnv (M.singleton (mn, cl) (map fst args, cons, deps)) mempty fromLocalDecl (TypeInstanceDeclaration _ _ _ _ _ cl tys _) = - foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys) + foldMap (\nm -> VerifySuperclassesEnv mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys) fromLocalDecl _ = mempty -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, @@ -114,11 +111,11 @@ deriveInstance => ModuleName -> SynonymMap -> KindMap - -> NewtypeDerivedInstances + -> VerifySuperclassesEnv -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance) +deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys (DerivedInstance Nothing)) | className == Qualified (Just dataEq) (ProperName "Eq") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty @@ -173,13 +170,20 @@ deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 | otherwise = throwError . errorMessage' ss $ CannotDerive className tys -deriveInstance mn syns kinds ndis ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys NewtypeInstance) = +deriveInstance mn syns kinds env ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys (DerivedInstance (Just DeriveNewtype))) = case tys of _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyCon args + -> TypeInstanceDeclaration sa ch idx nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns kinds env className ds tys tyCon args | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys) - _ -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys + _ -> throwError . errorMessage' ss $ CannotDeriveNullaryTypeClassInstance DeriveNewtype className +deriveInstance mn syns kinds env _ (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys (DerivedInstance (Just (DeriveVia viaTy)))) = + case tys of + _ : _ | Just (Qualified mn' _, _) <- unwrapTypeConstructor (last tys) + , mn == fromMaybe mn mn' + -> TypeInstanceDeclaration sa ch idx nm deps className tys . uncurry ViaInstanceWithDictionary <$> deriveViaInstance ss mn syns kinds env className tys viaTy + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys) + _ -> throwError . errorMessage' ss $ CannotDeriveNullaryTypeClassInstance (DeriveVia viaTy) className deriveInstance _ _ _ _ _ e = return e unwrapTypeConstructor :: SourceType -> Maybe (Qualified (ProperName 'TypeName), [SourceType]) @@ -198,15 +202,15 @@ deriveNewtypeInstance -> ModuleName -> SynonymMap -> KindMap - -> NewtypeDerivedInstances + -> VerifySuperclassesEnv -> Qualified (ProperName 'ClassName) -> [Declaration] -> [SourceType] -> ProperName 'TypeName -> [SourceType] -> m Expr -deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do - verifySuperclasses +deriveNewtypeInstance ss mn syns kinds env className ds tys tyConNm dargs = do + verifySuperclasses ss mn env className tys DeriveNewtype tyCon <- findTypeDecl ss tyConNm ds go tyCon where @@ -237,30 +241,55 @@ deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do | arg == arg' = stripRight args t stripRight _ _ = Nothing - verifySuperclasses :: m () - verifySuperclasses = - for_ (M.lookup (qualify mn className) (ndiClasses ndis)) $ \(args, superclasses, _) -> - for_ superclasses $ \Constraint{..} -> do - let constraintClass' = qualify (error "verifySuperclasses: unknown class module") constraintClass - for_ (M.lookup constraintClass' (ndiClasses ndis)) $ \(_, _, deps) -> - -- We need to check whether the newtype is mentioned, because of classes like MonadWriter - -- with its Monoid superclass constraint. - when (not (null args) && any ((last args `elem`) . usedTypeVariables) constraintArgs) $ do - -- For now, we only verify superclasses where the newtype is the only argument, - -- or for which all other arguments are determined by functional dependencies. - -- Everything else raises a UnverifiableSuperclassInstance warning. - -- This covers pretty much all cases we're interested in, but later we might want to do - -- more work to extend this to other superclass relationships. - let determined = map (srcTypeVar . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps - if eqType (last constraintArgs) (srcTypeVar (last args)) && all (`elem` determined) (init constraintArgs) - then do - -- Now make sure that a superclass instance was derived. Again, this is not a complete - -- check, since the superclass might have multiple type arguments, so overlaps might still - -- be possible, so we warn again. - for_ (extractNewtypeName mn tys) $ \nm -> - unless ((constraintClass', nm) `S.member` ndiDerivedInstances ndis) $ - tell . errorMessage' ss $ MissingNewtypeSuperclassInstance constraintClass className tys - else tell . errorMessage' ss $ UnverifiableSuperclassInstance constraintClass className tys +deriveViaInstance + :: forall m + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => SourceSpan + -> ModuleName + -> SynonymMap + -> KindMap + -> VerifySuperclassesEnv + -> Qualified (ProperName 'ClassName) + -> [SourceType] + -> SourceType + -> m (SourceType, Expr) +deriveViaInstance ss mn syns kinds env className tys viaTy = do + viaTy' <- replaceAllTypeSynonymsM syns kinds viaTy + verifySuperclasses ss mn env className tys (DeriveVia viaTy') + return (viaTy', DeferredDictionary className (init tys ++ [viaTy'])) + +verifySuperclasses + :: MonadWriter MultipleErrors m + => SourceSpan + -> ModuleName + -> VerifySuperclassesEnv + -> Qualified (ProperName 'ClassName) + -> [SourceType] + -> DerivingStrategy + -> m () +verifySuperclasses ss mn env className tys derivingStrategy = + for_ (M.lookup (qualify mn className) (classes env)) $ \(args, superclasses, _) -> + for_ superclasses $ \Constraint{..} -> do + let constraintClass' = qualify (error "verifySuperclasses: unknown class module") constraintClass + for_ (M.lookup constraintClass' (classes env)) $ \(_, _, deps) -> + -- We need to check whether the newtype is mentioned, because of classes like MonadWriter + -- with its Monoid superclass constraint. + when (not (null args) && any ((last args `elem`) . usedTypeVariables) constraintArgs) $ do + -- For now, we only verify superclasses where the newtype is the only argument, + -- or for which all other arguments are determined by functional dependencies. + -- Everything else raises a UnverifiableSuperclassInstance warning. + -- This covers pretty much all cases we're interested in, but later we might want to do + -- more work to extend this to other superclass relationships. + let determined = map (srcTypeVar . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps + if eqType (last constraintArgs) (srcTypeVar (last args)) && all (`elem` determined) (init constraintArgs) + then do + -- Now make sure that a superclass instance was derived. Again, this is not a complete + -- check, since the superclass might have multiple type arguments, so overlaps might still + -- be possible, so we warn again. + for_ (extractNewtypeName mn tys) $ \nm -> + unless ((constraintClass', nm) `S.member` instances env) $ + tell . errorMessage' ss $ MissingSuperclassInstance derivingStrategy constraintClass className tys + else tell . errorMessage' ss $ UnverifiableSuperclassInstance derivingStrategy constraintClass className tys dataGenericRep :: ModuleName dataGenericRep = ModuleName "Data.Generic.Rep" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 36a616b330..07ff128c39 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -12,13 +12,15 @@ module Language.PureScript.TypeChecker import Prelude.Compat import Protolude (headMay, ordNub) -import Control.Monad (when, unless, void, forM,) +import Control.Monad (when, unless, void, forM, replicateM) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..), modify, gets) -import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Control.Monad.State (MonadState(..), modify, gets, runStateT) +import Control.Monad.Supply (runSupply) +import Control.Monad.Supply.Class (MonadSupply, fresh) +import Control.Monad.Writer (MonadWriter(..), censor, runWriterT) -import Data.Foldable (for_, traverse_, toList) +import Data.Foldable (for_, traverse_, toList, foldl') +import Data.Function ((&)) import Data.List (nub, nubBy, (\\), sort, group, intersect) import Data.Maybe import Data.Text (Text) @@ -28,12 +30,14 @@ import qualified Data.Set as S import qualified Data.Text as T import Language.PureScript.AST +import Language.PureScript.Constants.Prim (pattern Coercible) import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Linter import Language.PureScript.Names import Language.PureScript.Roles +import Language.PureScript.TypeChecker.Entailment (SolverOptions(..), entails) import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Synonyms as T @@ -393,11 +397,63 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance dictName className tys' nonOrphanModules let qualifiedChain = Qualified (Just moduleName) <$> ch checkOverlappingInstance qualifiedChain dictName className typeClass tys' nonOrphanModules + checkInstanceBody body _ <- traverseTypeInstanceBody checkInstanceMembers body deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps' let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys' (Just deps'') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d + where + checkInstanceBody (ViaInstanceWithDictionary viaTy _) = do + (tyConName, tyConArgs) <- unapplyTypeConstructor (last tys) + & maybe (throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys)) return + (viaTyConName, viaTyConArgs) <- unapplyTypeConstructor viaTy + & maybe (throwError . errorMessage' ss $ InvalidViaType className tys viaTy) return + kinds <- gets (types . checkEnv) + (kind, _) <- M.lookup tyConName kinds + & maybe (throwError . errorMessage' ss . CannotFindDerivingType $ disqualify tyConName) return + (viaKind, _) <- M.lookup viaTyConName kinds + & maybe (throwError . errorMessage' ss . CannotFindViaType $ disqualify viaTyConName) return + let tyVars = S.fromList $ usedTypeVariables (last tys) + viaTyVars = S.fromList $ usedTypeVariables viaTy + floating = NEL.nonEmpty . S.toList $ viaTyVars `S.difference` tyVars + FloatingViaTypeVariables className tys viaTy <$> floating + & maybe (return ()) (throwError . errorMessage' ss) + checkViaKind moduleName ss className tys viaTy + let saturate' = saturate $ tyVars `S.union` viaTyVars + a = saturate' kind (last tys) (length tyConArgs) + b = saturate' viaKind viaTy (length viaTyConArgs) + constraint = srcConstraint Coercible [] [a, b] Nothing + solverOptions = + SolverOptions + { solverShouldGeneralize = False + , solverDeferErrors = False + } + void . flip runStateT M.empty . runWriterT $ + entails solverOptions constraint M.empty [] + checkInstanceBody _ = return () + + unapplyTypeConstructor ty = + case unapplyTypes ty of + (TypeConstructor _ name, _, args) -> + Just (name, args) + _ -> Nothing + + saturate vars k ty n = fst . runSupply 0 $ do + names <- replicateM (kindArity k - n) (freshVar vars "t") + return $ foldl' srcTypeApp ty (srcTypeVar <$> names) + + kindArity = go' 0 where + go' n (TypeApp _ (TypeApp _ k _) b) + | k == tyFunction = go' (n + 1) b + go' n (ForAll _ _ _ k _) = go' n k + go' n _ = n + + freshVar vars name = do + v <- (name <>) . T.pack . show <$> fresh + if v `elem` vars + then freshVar vars name + else return v checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m () checkInstanceArity dictName className typeClass tys = do diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index e3306fb488..b69d7cea3f 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -17,12 +17,14 @@ module Language.PureScript.TypeChecker.Kinds , elaborateKind , checkConstraint , checkInstanceDeclaration + , checkViaKind , checkKindDeclaration , checkTypeKind , unknownsWithKinds ) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) @@ -845,6 +847,22 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do varKinds <- traverse (traverse (fmap (replaceUnknownsWithVars unknownVars) . apply)) $ (snd <$> unknownVars) <> (first runProperName <$> freeVarsDict) pure (allConstraints, allKinds, allArgs, varKinds) +checkViaKind + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> SourceSpan + -> Qualified (ProperName 'ClassName) + -> [SourceType] + -> SourceType + -> m () +checkViaKind moduleName ss className tys viaTy = do + let freeVars = ordNub $ freeTypeVariables viaTy ++ freeTypeVariables (last tys) + freeVarsDict <- for freeVars $ \v -> (ProperName v,) <$> freshKind ss + bindLocalTypeVariables moduleName freeVarsDict $ do + (_, viaKind) <- inferKind viaTy + (_, expectedKind) <- inferKind (last tys) + unifyKindsWithFailure (\_ _ -> throwError . errorMessage' ss $ InvalidViaKind className tys viaTy viaKind expectedKind) viaKind expectedKind + checkKindDeclaration :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m) => ModuleName diff --git a/tests/purs/failing/FloatingViaTypeVariables.out b/tests/purs/failing/FloatingViaTypeVariables.out new file mode 100644 index 0000000000..d6700e0f43 --- /dev/null +++ b/tests/purs/failing/FloatingViaTypeVariables.out @@ -0,0 +1,14 @@ +Error found: +in module [33mMain[0m +at tests/purs/failing/FloatingViaTypeVariables.purs:9:1 - 9:36 (line 9, column 1 - line 9, column 36) + + Cannot derive instance via [33mV a[0m for + [33m [0m + [33m Main.C D[0m + [33m [0m + because the type variable [33ma[0m is bound in [33mV a[0m but is not mentioned in the instance head. + + +See https://github.com/purescript/documentation/blob/master/errors/FloatingViaTypeVariables.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FloatingViaTypeVariables.purs b/tests/purs/failing/FloatingViaTypeVariables.purs new file mode 100644 index 0000000000..703dbb1abf --- /dev/null +++ b/tests/purs/failing/FloatingViaTypeVariables.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith FloatingViaTypeVariables +module Main where + +class C a + +data D = D +data V a = V + +derive via (V a) instance cd :: C D diff --git a/tests/purs/failing/InvalidViaKind.out b/tests/purs/failing/InvalidViaKind.out new file mode 100644 index 0000000000..3ddb4ab153 --- /dev/null +++ b/tests/purs/failing/InvalidViaKind.out @@ -0,0 +1,14 @@ +Error found: +in module [33mMain[0m +at tests/purs/failing/InvalidViaKind.purs:12:1 - 12:32 (line 12, column 1 - line 12, column 32) + + Cannot derive instance via [33mV[0m for + [33m [0m + [33m Main.C D[0m + [33m [0m + because [33mD[0m has kind [33mType[0m but [33mV[0m has kind [33mforall k. k -> Type[0m. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidViaKind.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidViaKind.purs b/tests/purs/failing/InvalidViaKind.purs new file mode 100644 index 0000000000..061173e784 --- /dev/null +++ b/tests/purs/failing/InvalidViaKind.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith InvalidViaKind +module Main where + +class C a + +data V a = V + +instance cv :: C (V a) + +data D = D + +derive via V instance cd :: C D diff --git a/tests/purs/failing/InvalidViaType.out b/tests/purs/failing/InvalidViaType.out new file mode 100644 index 0000000000..c69bc5430c --- /dev/null +++ b/tests/purs/failing/InvalidViaType.out @@ -0,0 +1,14 @@ +Error found: +in module [33mMain[0m +at tests/purs/failing/InvalidViaType.purs:8:1 - 8:32 (line 8, column 1 - line 8, column 32) + + Cannot derive instance via [33m_[0m for + [33m [0m + [33m Main.C D[0m + [33m [0m + because the type [33m_[0m is not of the required form T a_1 ... a_n. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidViaType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidViaType.purs b/tests/purs/failing/InvalidViaType.purs new file mode 100644 index 0000000000..5cb1a21795 --- /dev/null +++ b/tests/purs/failing/InvalidViaType.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidViaType +module Main where + +class C a + +data D = D + +derive via _ instance cd :: C D diff --git a/tests/purs/failing/InvalidViaType2.out b/tests/purs/failing/InvalidViaType2.out new file mode 100644 index 0000000000..654eceb4ce --- /dev/null +++ b/tests/purs/failing/InvalidViaType2.out @@ -0,0 +1,14 @@ +Error found: +in module [33mMain[0m +at tests/purs/failing/InvalidViaType2.purs:8:1 - 8:32 (line 8, column 1 - line 8, column 32) + + Cannot derive instance via [33ma[0m for + [33m [0m + [33m Main.C D[0m + [33m [0m + because the type [33ma[0m is not of the required form T a_1 ... a_n. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidViaType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidViaType2.purs b/tests/purs/failing/InvalidViaType2.purs new file mode 100644 index 0000000000..bc7567c2e7 --- /dev/null +++ b/tests/purs/failing/InvalidViaType2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidViaType +module Main where + +class C a + +data D = D + +derive via a instance cd :: C D diff --git a/tests/purs/failing/InvalidViaType3.out b/tests/purs/failing/InvalidViaType3.out new file mode 100644 index 0000000000..f65568b387 --- /dev/null +++ b/tests/purs/failing/InvalidViaType3.out @@ -0,0 +1,14 @@ +Error found: +in module [33mMain[0m +at tests/purs/failing/InvalidViaType3.purs:8:1 - 8:33 (line 8, column 1 - line 8, column 33) + + Cannot derive instance via [33m()[0m for + [33m [0m + [33m Main.C D[0m + [33m [0m + because the type [33m()[0m is not of the required form T a_1 ... a_n. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidViaType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidViaType3.purs b/tests/purs/failing/InvalidViaType3.purs new file mode 100644 index 0000000000..3b70ea5fb0 --- /dev/null +++ b/tests/purs/failing/InvalidViaType3.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidViaType +module Main where + +class C a + +data D = D + +derive via () instance cd :: C D diff --git a/tests/purs/failing/InvalidViaType4.out b/tests/purs/failing/InvalidViaType4.out new file mode 100644 index 0000000000..8ee027adf7 --- /dev/null +++ b/tests/purs/failing/InvalidViaType4.out @@ -0,0 +1,14 @@ +Error found: +in module [33mMain[0m +at tests/purs/failing/InvalidViaType4.purs:8:1 - 8:33 (line 8, column 1 - line 8, column 33) + + Cannot derive instance via [33m""[0m for + [33m [0m + [33m Main.C D[0m + [33m [0m + because the type [33m""[0m is not of the required form T a_1 ... a_n. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidViaType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidViaType4.purs b/tests/purs/failing/InvalidViaType4.purs new file mode 100644 index 0000000000..930f850697 --- /dev/null +++ b/tests/purs/failing/InvalidViaType4.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidViaType +module Main where + +class C a + +data D = D + +derive via "" instance cd :: C D diff --git a/tests/purs/failing/NewtypeInstance3.out b/tests/purs/failing/NewtypeInstance3.out index d5ed7a8c4c..dcddae4f46 100644 --- a/tests/purs/failing/NewtypeInstance3.out +++ b/tests/purs/failing/NewtypeInstance3.out @@ -2,12 +2,12 @@ Error found: at tests/purs/failing/NewtypeInstance3.purs:8:1 - 8:43 (line 8, column 1 - line 8, column 43) Cannot derive newtype instance for - [33m [0m - [33m Main.Nullary [0m - [33m [0m - Make sure this is a newtype. + [33m [0m + [33m Main.Nullary[0m + [33m [0m + Nullary type classes cannot be derived. -See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveNullaryTypeClassInstance.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance3.purs b/tests/purs/failing/NewtypeInstance3.purs index 528eefb67f..535785865e 100644 --- a/tests/purs/failing/NewtypeInstance3.purs +++ b/tests/purs/failing/NewtypeInstance3.purs @@ -1,4 +1,4 @@ --- @shouldFailWith InvalidNewtypeInstance +-- @shouldFailWith CannotDeriveNullaryTypeClassInstance module Main where import Prelude diff --git a/tests/purs/failing/ViaInstanceNonCoercibleViaType.out b/tests/purs/failing/ViaInstanceNonCoercibleViaType.out new file mode 100644 index 0000000000..f326982843 --- /dev/null +++ b/tests/purs/failing/ViaInstanceNonCoercibleViaType.out @@ -0,0 +1,18 @@ +Error found: +in module [33mMain[0m +at tests/purs/failing/ViaInstanceNonCoercibleViaType.purs:12:1 - 12:32 (line 12, column 1 - line 12, column 32) + + No type class instance was found for + [33m [0m + [33m Prim.Coerce.Coercible D[0m + [33m V[0m + [33m [0m + +in type class instance +[33m [0m +[33m Main.C D[0m +[33m [0m + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ViaInstanceNonCoercibleViaType.purs b/tests/purs/failing/ViaInstanceNonCoercibleViaType.purs new file mode 100644 index 0000000000..524233cd76 --- /dev/null +++ b/tests/purs/failing/ViaInstanceNonCoercibleViaType.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class C (a :: Type) + +data V = V + +instance cv :: C V + +data D = D + +derive via V instance cd :: C D diff --git a/tests/purs/failing/ViaInstanceNullaryTypeClass.out b/tests/purs/failing/ViaInstanceNullaryTypeClass.out new file mode 100644 index 0000000000..677693fd5f --- /dev/null +++ b/tests/purs/failing/ViaInstanceNullaryTypeClass.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/ViaInstanceNullaryTypeClass.purs:8:1 - 8:41 (line 8, column 1 - line 8, column 41) + + Cannot derive instance via [33mV[0m for + [33m [0m + [33m Main.Nullary[0m + [33m [0m + Nullary type classes cannot be derived. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveNullaryTypeClassInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ViaInstanceNullaryTypeClass.purs b/tests/purs/failing/ViaInstanceNullaryTypeClass.purs new file mode 100644 index 0000000000..e83ae6a1c3 --- /dev/null +++ b/tests/purs/failing/ViaInstanceNullaryTypeClass.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotDeriveNullaryTypeClassInstance +module Main where + +class Nullary + +data V + +derive via V instance nullary :: Nullary diff --git a/tests/purs/passing/DerivingVia.purs b/tests/purs/passing/DerivingVia.purs new file mode 100644 index 0000000000..3f3b47c5cc --- /dev/null +++ b/tests/purs/passing/DerivingVia.purs @@ -0,0 +1,68 @@ +module Main where + +import Prelude + +import Data.Either (Either(..)) +import Data.Functor.Compose (Compose) +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Bounded (class GenericBottom, class GenericTop, genericBottom, genericTop) +import Data.Maybe (Maybe(..)) +import Data.Newtype (class Newtype, wrap) +import Effect.Console (log) +import Test.Assert (assert) + +newtype ManyErrors e a = ManyErrors (Either e (Maybe a)) + +derive instance eqManyErrors :: (Eq e, Eq a) => Eq (ManyErrors e a) + +derive via (Compose (Either e) Maybe) + instance manyErrorsFunctor :: Functor (ManyErrors e) + +newtype GenericBounded a = GenericBounded a + +derive instance eqGenericBounded :: Eq a => Eq (GenericBounded a) +derive instance ordGenericBounded :: Ord a => Ord (GenericBounded a) +derive instance newtypeGenericBounded :: Newtype (GenericBounded a) _ + +instance boundedGenericBounded :: + ( Ord a + , Generic a rep + , GenericBottom rep + , GenericTop rep + ) => Bounded (GenericBounded a) where + bottom = wrap genericBottom + top = wrap genericTop + +data ABC = A | B | C + +derive instance eqABC :: Eq ABC +derive instance ordABC :: Ord ABC +derive instance genericABC :: Generic ABC _ + +derive via (GenericBounded ABC) instance boundedABC :: Bounded ABC + +data XYZ = X | Y | Z + +derive instance eqXYZ :: Eq XYZ +derive instance ordXYZ :: Ord XYZ +derive instance genericXYZ :: Generic XYZ _ + +type V = GenericBounded XYZ +derive via V instance boundedXYZ :: Bounded XYZ + +viaNotReserved :: ∀ a. a -> a +viaNotReserved via = via + +data ViaNotReserved via = ViaNotReserved via + +type ViaNotReservedInRows a = ( via :: a ) + +main = do + assert $ (map (_ + 1) $ ManyErrors (Left unit) :: ManyErrors Unit Int) == (ManyErrors $ Left unit) + assert $ (map (_ + 1) $ ManyErrors (Right Nothing) :: ManyErrors Unit Int) == (ManyErrors $ Right Nothing) + assert $ (map (_ + 1) $ ManyErrors (Right $ Just 0) :: ManyErrors Unit Int) == (ManyErrors (Right $ Just 1)) + + assert $ bottom == A + assert $ top == C + + log "Done" diff --git a/tests/purs/warning/NewtypeInstance.out b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance.out similarity index 51% rename from tests/purs/warning/NewtypeInstance.out rename to tests/purs/warning/NewtypeInstanceMissingSuperclassInstance.out index 72c32ddb3c..5ddc086b6b 100644 --- a/tests/purs/warning/NewtypeInstance.out +++ b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance.out @@ -1,13 +1,13 @@ Warning found: -at tests/purs/warning/NewtypeInstance.purs:8:1 - 8:38 (line 8, column 1 - line 8, column 38) +at tests/purs/warning/NewtypeInstanceMissingSuperclassInstance.purs:8:1 - 8:38 (line 8, column 1 - line 8, column 38) The derived newtype instance for [33m [0m [33m Data.Ord.Ord X[0m [33m [0m - does not include a derived superclass instance for [33mData.Eq.Eq[0m. + implies a missing superclass instance for [33mData.Eq.Eq[0m. -See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/MissingSuperclassInstance.md for more information, or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance.purs b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance.purs similarity index 64% rename from tests/purs/warning/NewtypeInstance.purs rename to tests/purs/warning/NewtypeInstanceMissingSuperclassInstance.purs index 944ee45415..6ed4c8183d 100644 --- a/tests/purs/warning/NewtypeInstance.purs +++ b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance.purs @@ -1,4 +1,4 @@ --- @shouldWarnWith MissingNewtypeSuperclassInstance +-- @shouldWarnWith MissingSuperclassInstance module Main where import Prelude diff --git a/tests/purs/warning/NewtypeInstance2.out b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance2.out similarity index 57% rename from tests/purs/warning/NewtypeInstance2.out rename to tests/purs/warning/NewtypeInstanceMissingSuperclassInstance2.out index 8f6eed3101..e4ab0070a0 100644 --- a/tests/purs/warning/NewtypeInstance2.out +++ b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance2.out @@ -1,14 +1,14 @@ Warning found: -at tests/purs/warning/NewtypeInstance2.purs:15:1 - 15:86 (line 15, column 1 - line 15, column 86) +at tests/purs/warning/NewtypeInstanceMissingSuperclassInstance2.purs:15:1 - 15:86 (line 15, column 1 - line 15, column 86) The derived newtype instance for [33m [0m [33m Main.MonadWriter w [0m [33m (MyWriter w)[0m [33m [0m - does not include a derived superclass instance for [33mControl.Monad.Monad[0m. + implies a missing superclass instance for [33mControl.Monad.Monad[0m. -See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/MissingSuperclassInstance.md for more information, or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance2.purs b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance2.purs similarity index 87% rename from tests/purs/warning/NewtypeInstance2.purs rename to tests/purs/warning/NewtypeInstanceMissingSuperclassInstance2.purs index d148ed037b..6940abac12 100644 --- a/tests/purs/warning/NewtypeInstance2.purs +++ b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance2.purs @@ -1,4 +1,4 @@ --- @shouldWarnWith MissingNewtypeSuperclassInstance +-- @shouldWarnWith MissingSuperclassInstance module Main where import Prelude diff --git a/tests/purs/warning/NewtypeInstance3.out b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance3.out similarity index 58% rename from tests/purs/warning/NewtypeInstance3.out rename to tests/purs/warning/NewtypeInstanceMissingSuperclassInstance3.out index 7c8a7e79c6..8fe22e1150 100644 --- a/tests/purs/warning/NewtypeInstance3.out +++ b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance3.out @@ -1,14 +1,14 @@ Warning found: -at tests/purs/warning/NewtypeInstance3.purs:21:1 - 21:86 (line 21, column 1 - line 21, column 86) +at tests/purs/warning/NewtypeInstanceMissingSuperclassInstance3.purs:21:1 - 21:86 (line 21, column 1 - line 21, column 86) The derived newtype instance for [33m [0m [33m Main.MonadWriter w [0m [33m (MyWriter w)[0m [33m [0m - does not include a derived superclass instance for [33mMain.MonadTell[0m. + implies a missing superclass instance for [33mMain.MonadTell[0m. -See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/MissingSuperclassInstance.md for more information, or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance3.purs b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance3.purs similarity index 91% rename from tests/purs/warning/NewtypeInstance3.purs rename to tests/purs/warning/NewtypeInstanceMissingSuperclassInstance3.purs index f61a558c87..52d78405b4 100644 --- a/tests/purs/warning/NewtypeInstance3.purs +++ b/tests/purs/warning/NewtypeInstanceMissingSuperclassInstance3.purs @@ -1,4 +1,4 @@ --- @shouldWarnWith MissingNewtypeSuperclassInstance +-- @shouldWarnWith MissingSuperclassInstance module Main where import Prelude diff --git a/tests/purs/warning/NewtypeInstance4.out b/tests/purs/warning/NewtypeInstanceUnverifiableSuperclassInstance.out similarity index 64% rename from tests/purs/warning/NewtypeInstance4.out rename to tests/purs/warning/NewtypeInstanceUnverifiableSuperclassInstance.out index 9874bf408a..7b2ec1c0e7 100644 --- a/tests/purs/warning/NewtypeInstance4.out +++ b/tests/purs/warning/NewtypeInstanceUnverifiableSuperclassInstance.out @@ -1,12 +1,12 @@ Warning found: -at tests/purs/warning/NewtypeInstance4.purs:23:1 - 23:86 (line 23, column 1 - line 23, column 86) +at tests/purs/warning/NewtypeInstanceUnverifiableSuperclassInstance.purs:23:1 - 23:86 (line 23, column 1 - line 23, column 86) The derived newtype instance for [33m [0m [33m Main.MonadWriter w [0m [33m (MyWriter w)[0m [33m [0m - implies an superclass instance for [33mMain.MonadTell[0m which could not be verified. + implies a superclass instance for [33mMain.MonadTell[0m which could not be verified. See https://github.com/purescript/documentation/blob/master/errors/UnverifiableSuperclassInstance.md for more information, diff --git a/tests/purs/warning/NewtypeInstance4.purs b/tests/purs/warning/NewtypeInstanceUnverifiableSuperclassInstance.purs similarity index 100% rename from tests/purs/warning/NewtypeInstance4.purs rename to tests/purs/warning/NewtypeInstanceUnverifiableSuperclassInstance.purs diff --git a/tests/purs/warning/ViaInstanceMissingSuperclassInstance.out b/tests/purs/warning/ViaInstanceMissingSuperclassInstance.out new file mode 100644 index 0000000000..12ec89c781 --- /dev/null +++ b/tests/purs/warning/ViaInstanceMissingSuperclassInstance.out @@ -0,0 +1,13 @@ +Warning found: +at tests/purs/warning/ViaInstanceMissingSuperclassInstance.purs:8:1 - 8:41 (line 8, column 1 - line 8, column 41) + + The derived instance via [33mString[0m for + [33m [0m + [33m Data.Ord.Ord X[0m + [33m [0m + implies a missing superclass instance for [33mData.Eq.Eq[0m. + + +See https://github.com/purescript/documentation/blob/master/errors/MissingSuperclassInstance.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/ViaInstanceMissingSuperclassInstance.purs b/tests/purs/warning/ViaInstanceMissingSuperclassInstance.purs new file mode 100644 index 0000000000..c077390784 --- /dev/null +++ b/tests/purs/warning/ViaInstanceMissingSuperclassInstance.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith MissingSuperclassInstance +module Main where + +import Prelude + +newtype X = X String + +derive via String instance ordX :: Ord X diff --git a/tests/purs/warning/ViaInstanceMissingSuperclassInstance2.out b/tests/purs/warning/ViaInstanceMissingSuperclassInstance2.out new file mode 100644 index 0000000000..f78d811486 --- /dev/null +++ b/tests/purs/warning/ViaInstanceMissingSuperclassInstance2.out @@ -0,0 +1,14 @@ +Warning found: +at tests/purs/warning/ViaInstanceMissingSuperclassInstance2.purs:15:1 - 15:92 (line 15, column 1 - line 15, column 92) + + The derived instance via [33mTuple w[0m for + [33m [0m + [33m Main.MonadWriter w [0m + [33m (MyWriter w)[0m + [33m [0m + implies a missing superclass instance for [33mControl.Monad.Monad[0m. + + +See https://github.com/purescript/documentation/blob/master/errors/MissingSuperclassInstance.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/ViaInstanceMissingSuperclassInstance2.purs b/tests/purs/warning/ViaInstanceMissingSuperclassInstance2.purs new file mode 100644 index 0000000000..90feddc63d --- /dev/null +++ b/tests/purs/warning/ViaInstanceMissingSuperclassInstance2.purs @@ -0,0 +1,15 @@ +-- @shouldWarnWith MissingSuperclassInstance +module Main where + +import Prelude +import Data.Tuple (Tuple(..)) + +class (Monad m, Monoid w) <= MonadWriter w m | m -> w where + tell :: w -> m Unit + +instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where + tell w = Tuple w unit + +newtype MyWriter w a = MyWriter (Tuple w a) + +derive via (Tuple w) instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) diff --git a/tests/purs/warning/ViaInstanceMissingSuperclassInstance3.out b/tests/purs/warning/ViaInstanceMissingSuperclassInstance3.out new file mode 100644 index 0000000000..491a2039fe --- /dev/null +++ b/tests/purs/warning/ViaInstanceMissingSuperclassInstance3.out @@ -0,0 +1,14 @@ +Warning found: +at tests/purs/warning/ViaInstanceMissingSuperclassInstance3.purs:21:1 - 21:92 (line 21, column 1 - line 21, column 92) + + The derived instance via [33mTuple w[0m for + [33m [0m + [33m Main.MonadWriter w [0m + [33m (MyWriter w)[0m + [33m [0m + implies a missing superclass instance for [33mMain.MonadTell[0m. + + +See https://github.com/purescript/documentation/blob/master/errors/MissingSuperclassInstance.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/ViaInstanceMissingSuperclassInstance3.purs b/tests/purs/warning/ViaInstanceMissingSuperclassInstance3.purs new file mode 100644 index 0000000000..7be56172f5 --- /dev/null +++ b/tests/purs/warning/ViaInstanceMissingSuperclassInstance3.purs @@ -0,0 +1,21 @@ +-- @shouldWarnWith MissingSuperclassInstance +module Main where + +import Prelude +import Data.Tuple (Tuple(..)) + +class (Monad m, Monoid w) <= MonadTell w m | m -> w where + tell :: w -> m Unit + +class (MonadTell w m) <= MonadWriter w m | m -> w where + listen :: forall a. m a -> m (Tuple w a) + +instance monadTellTuple :: Monoid w => MonadTell w (Tuple w) where + tell w = Tuple w unit + +instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where + listen (Tuple w a) = Tuple w (Tuple w a) + +newtype MyWriter w a = MyWriter (Tuple w a) + +derive via (Tuple w) instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) diff --git a/tests/purs/warning/ViaInstanceUnverifiableSuperclassInstance.out b/tests/purs/warning/ViaInstanceUnverifiableSuperclassInstance.out new file mode 100644 index 0000000000..76be193513 --- /dev/null +++ b/tests/purs/warning/ViaInstanceUnverifiableSuperclassInstance.out @@ -0,0 +1,14 @@ +Warning found: +at tests/purs/warning/ViaInstanceUnverifiableSuperclassInstance.purs:23:1 - 23:92 (line 23, column 1 - line 23, column 92) + + The derived instance via [33mTuple w[0m for + [33m [0m + [33m Main.MonadWriter w [0m + [33m (MyWriter w)[0m + [33m [0m + implies a superclass instance for [33mMain.MonadTell[0m which could not be verified. + + +See https://github.com/purescript/documentation/blob/master/errors/UnverifiableSuperclassInstance.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/ViaInstanceUnverifiableSuperclassInstance.purs b/tests/purs/warning/ViaInstanceUnverifiableSuperclassInstance.purs new file mode 100644 index 0000000000..c0765a5c05 --- /dev/null +++ b/tests/purs/warning/ViaInstanceUnverifiableSuperclassInstance.purs @@ -0,0 +1,23 @@ +-- @shouldWarnWith UnverifiableSuperclassInstance +module Main where + +import Prelude +import Data.Tuple (Tuple(..)) + +class Monoid w <= MonadTell w m where + tell :: w -> m Unit + +class (MonadTell w m) <= MonadWriter w m where + listen :: forall a. m a -> m (Tuple w a) + +instance monadTellTuple :: Monoid w => MonadTell w (Tuple w) where + tell w = Tuple w unit + +instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where + listen (Tuple w a) = Tuple w (Tuple w a) + +newtype MyWriter w a = MyWriter (Tuple w a) + +-- No fundep means this is unverifiable +derive via (Tuple w) instance monadTellMyWriter :: Monoid w => MonadTell w (MyWriter w) +derive via (Tuple w) instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) diff --git a/tests/support/bower.json b/tests/support/bower.json index 850a61c429..408ea321bd 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -11,6 +11,7 @@ "purescript-either": "4.0.0", "purescript-foldable-traversable": "4.0.0", "purescript-functions": "4.0.0", + "purescript-functors": "3.1.1", "purescript-gen": "2.0.0", "purescript-generics-rep": "6.0.0", "purescript-globals": "4.0.0",Fetched URL: http://github.com/purescript/purescript/pull/3824.diff
Alternative Proxies: