From 639f195768eae5b3d85541eb84e18ef56b9b3668 Mon Sep 17 00:00:00 2001 From: Stefan Fehrenbach Date: Mon, 9 Jul 2018 16:50:00 +0100 Subject: [PATCH 1/2] Print type of missing typeclass member --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 6 ++++-- src/Language/PureScript/Sugar/TypeClasses.hs | 10 +++++----- tests/purs/failing/MissingClassMember.purs | 2 -- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 9c820071dc..19d7942f41 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -124,7 +124,7 @@ data SimpleErrorMessage | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) - | MissingClassMember Ident + | MissingClassMember Ident Type | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) | ExpectedType Type Kind -- | constructor name, expected argument count, actual argument count diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 135f98aa2f..0f8c12cf67 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -753,8 +753,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident) renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident - renderSimpleErrorMessage (MissingClassMember ident) = - line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented." + renderSimpleErrorMessage (MissingClassMember ident ty) = + paras [ line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented. It is expected to have the following type:" + , markCodeBox $ indent $ Box.text (T.unpack (showIdent ident)) Box.<> Box.text " :: " Box.<> typeAsBox ty + ] renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a6c80750b7..aa97cbef35 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -16,7 +16,7 @@ import Control.Monad.State import Control.Monad.Supply.Class import Data.List ((\\), find, sortBy) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) +import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe, fromJust) import Data.Text (Text) import qualified Language.PureScript.Constants as C import Language.PureScript.Crash @@ -285,12 +285,12 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m + -- Replace the type arguments with the appropriate types in the member types + let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers + case map fst typeClassMembers \\ mapMaybe declIdent decls of - member : _ -> throwError . errorMessage' ss $ MissingClassMember member + member : _ -> throwError . errorMessage' ss $ MissingClassMember member (fromJust (lookup member memberTypes)) [] -> do - -- Replace the type arguments with the appropriate types in the member types - let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers - -- Create values for the type instance members members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls diff --git a/tests/purs/failing/MissingClassMember.purs b/tests/purs/failing/MissingClassMember.purs index 488fccfc99..ab600c1b83 100644 --- a/tests/purs/failing/MissingClassMember.purs +++ b/tests/purs/failing/MissingClassMember.purs @@ -1,8 +1,6 @@ -- @shouldFailWith MissingClassMember module Main where -import Prelude - class A a where a :: a -> String b :: a -> Number From b61e762145062ae2585a74adc22e3de4c9c12e54 Mon Sep 17 00:00:00 2001 From: Stefan Fehrenbach Date: Tue, 10 Jul 2018 17:22:38 +0100 Subject: [PATCH 2/2] Print all missing type class members --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 10 ++++++---- src/Language/PureScript/Sugar/TypeClasses.hs | 12 ++++++++---- tests/purs/failing/MissingClassMember.purs | 1 + 4 files changed, 16 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 19d7942f41..2725f5da67 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -124,7 +124,7 @@ data SimpleErrorMessage | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) - | MissingClassMember Ident Type + | MissingClassMember (NEL.NonEmpty (Ident, Type)) | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) | ExpectedType Type Kind -- | constructor name, expected argument count, actual argument count diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 0f8c12cf67..2eb422d1d5 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -753,10 +753,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident) renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident - renderSimpleErrorMessage (MissingClassMember ident ty) = - paras [ line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented. It is expected to have the following type:" - , markCodeBox $ indent $ Box.text (T.unpack (showIdent ident)) Box.<> Box.text " :: " Box.<> typeAsBox ty - ] + renderSimpleErrorMessage (MissingClassMember identsAndTypes) = + paras $ [ line "The following type class members have not been implemented:" + , Box.vcat Box.left + [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> typeAsBox ty + | (ident, ty) <- NEL.toList identsAndTypes ] + ] renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index aa97cbef35..0645bcde7d 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -14,9 +14,11 @@ import Control.Arrow (first, second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class -import Data.List ((\\), find, sortBy) +import Data.List (find, sortBy) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe, fromJust) +import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Set as S import Data.Text (Text) import qualified Language.PureScript.Constants as C import Language.PureScript.Crash @@ -288,8 +290,10 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- Replace the type arguments with the appropriate types in the member types let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers - case map fst typeClassMembers \\ mapMaybe declIdent decls of - member : _ -> throwError . errorMessage' ss $ MissingClassMember member (fromJust (lookup member memberTypes)) + let declaredMembers = S.fromList $ mapMaybe declIdent decls + + case filter (\(ident, _) -> not $ S.member ident declaredMembers) memberTypes of + hd : tl -> throwError . errorMessage' ss $ MissingClassMember (hd NEL.:| tl) [] -> do -- Create values for the type instance members members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls diff --git a/tests/purs/failing/MissingClassMember.purs b/tests/purs/failing/MissingClassMember.purs index ab600c1b83..42a06a927f 100644 --- a/tests/purs/failing/MissingClassMember.purs +++ b/tests/purs/failing/MissingClassMember.purs @@ -4,6 +4,7 @@ module Main where class A a where a :: a -> String b :: a -> Number + c :: forall f. a -> f a instance aString :: A String where a s = s