From 6e2912ca699041c85d703db642fce26578f94075 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 11 Sep 2016 15:12:04 -0700 Subject: [PATCH 1/3] Newtype deriving --- examples/passing/NewtypeInstance.purs | 22 ++++++++++++++++ src/Language/PureScript/AST/Declarations.hs | 12 ++++++--- src/Language/PureScript/Errors.hs | 10 ++++++++ .../PureScript/Parser/Declarations.hs | 18 ++++++++++--- src/Language/PureScript/Sugar/TypeClasses.hs | 4 +++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 25 +++++++++++++++++++ 6 files changed, 84 insertions(+), 7 deletions(-) create mode 100644 examples/passing/NewtypeInstance.purs diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs new file mode 100644 index 0000000000..71aaa91ecd --- /dev/null +++ b/examples/passing/NewtypeInstance.purs @@ -0,0 +1,22 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +newtype X = X String + +newtype instance showX :: Show X + +newtype instance eqX :: Eq X + +newtype instance ordX :: Ord X + +newtype Y a = Y (Array a) + +newtype instance showY :: Show (Y String) + +main = do + logShow (X "test") + logShow (Y ["test"]) + log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index d0de7e674c..ac86a7ec14 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -77,6 +77,7 @@ data SimpleErrorMessage | NoInstanceFound Constraint | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] | CannotDerive (Qualified (ProperName 'ClassName)) [Type] + | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) | DuplicateLabel String (Maybe Expr) | DuplicateValueDeclaration Ident @@ -374,10 +375,15 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix -- | The members of a type class instance declaration data TypeInstanceBody - -- | This is a derived instance = DerivedInstance - -- | This is a regular (explicit) instance + -- ^ 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. | ExplicitInstance [Declaration] + -- ^ This is a regular (explicit) instance deriving (Show) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody @@ -385,8 +391,8 @@ mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) -- | A traversal for TypeInstanceBody traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody -traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds +traverseTypeInstanceBody _ other = pure other -- | -- Test if a declaration is a value declaration diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5be9fe20a1..39e3e7b640 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -120,6 +120,7 @@ errorCode em = case unwrapErrorMessage em of NoInstanceFound{} -> "NoInstanceFound" PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" CannotDerive{} -> "CannotDerive" + InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" CannotFindDerivingType{} -> "CannotFindDerivingType" DuplicateLabel{} -> "DuplicateLabel" DuplicateValueDeclaration{} -> "DuplicateValueDeclaration" @@ -262,6 +263,7 @@ 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 (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx @@ -642,6 +644,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , Box.vcat Box.left (map typeAtomAsBox ts) ] ] + renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) = + paras [ line "Cannot derive newtype instance for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line "Make sure this is a newtype." + ] renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c8e66e7f93..57b0d493d7 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -63,9 +63,8 @@ kindedIdent :: TokenParser (String, Maybe Kind) kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) -parseDataDeclaration :: TokenParser Declaration -parseDataDeclaration = do - dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) +parseDataDeclaration :: DataDeclType -> TokenParser Declaration +parseDataDeclaration dtype = do name <- indented *> typeName tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do @@ -219,6 +218,16 @@ parseDerivingInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration return $ instanceDecl DerivedInstance +parseNewtypeInstanceDeclaration :: TokenParser Declaration +parseNewtypeInstanceDeclaration = do + instanceDecl <- parseInstanceDeclaration + return $ instanceDecl NewtypeInstance + +parseNewtypeOrNewtypeInstance :: TokenParser Declaration +parseNewtypeOrNewtypeInstance = + reserved "newtype" *> + (parseDataDeclaration Newtype <|> parseNewtypeInstanceDeclaration) + positioned :: TokenParser Declaration -> TokenParser Declaration positioned = withSourceSpan PositionedDeclaration @@ -227,7 +236,8 @@ positioned = withSourceSpan PositionedDeclaration -- parseDeclaration :: TokenParser Declaration parseDeclaration = positioned (P.choice - [ parseDataDeclaration + [ parseNewtypeOrNewtypeInstance + , reserved "data" *> parseDataDeclaration Data , parseTypeDeclaration , parseTypeSynonymDeclaration , parseValueDeclaration diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 7262224dd7..ceaa6997b5 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -181,6 +181,10 @@ desugarDecl mn exps = go desugared <- desugarCases members dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) + go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do + let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys + constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) + return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))]) go (PositionedDeclaration pos com d) = do (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d return (dr, map (PositionedDeclaration pos com) ds) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 086d4ae18c..cc33b84591 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -54,6 +54,12 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys +deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] NewtypeInstance) + | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds ty tyCon args +deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) + = throwError . errorMessage $ InvalidNewtypeInstance className tys deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d deriveInstance _ _ e = return e @@ -66,6 +72,25 @@ unwrapTypeConstructor = fmap (second reverse) . go return (tyCon, arg : args) go _ = Nothing +deriveNewtypeInstance + :: forall m + . MonadError MultipleErrors m + => Qualified (ProperName 'ClassName) + -> [Declaration] + -> Type + -> ProperName 'TypeName + -> [Type] + -> m Expr +deriveNewtypeInstance className ds ty tyConNm dargs = do + tyCon <- findTypeDecl tyConNm ds + go tyCon + where + go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do + let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs + return (SuperClassDictionary className [replaceAllTypeVars subst wrapped]) + go (PositionedDeclaration _ _ d) = go d + go _ = throwError . errorMessage $ InvalidNewtypeInstance className [ty] + dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] From df45daa85a0a950f7443ec3a941e16705cf526ea Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 11 Sep 2016 20:09:25 -0700 Subject: [PATCH 2/3] Syntax changes. Rename SuperclassDictionary to DeferredDictionary --- examples/passing/NewtypeInstance.purs | 8 +++---- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 2 +- .../PureScript/Parser/Declarations.hs | 23 +++++++------------ src/Language/PureScript/Pretty/Values.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 4 ++-- src/Language/PureScript/Sugar/TypeClasses.hs | 4 ++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- .../PureScript/TypeChecker/Skolems.hs | 6 ++--- src/Language/PureScript/TypeChecker/Types.hs | 4 ++-- 10 files changed, 25 insertions(+), 32 deletions(-) diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index 71aaa91ecd..f61f420378 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -6,15 +6,15 @@ import Control.Monad.Eff.Console newtype X = X String -newtype instance showX :: Show X +derive newtype instance showX :: Show X -newtype instance eqX :: Eq X +derive newtype instance eqX :: Eq X -newtype instance ordX :: Ord X +derive newtype instance ordX :: Ord X newtype Y a = Y (Array a) -newtype instance showY :: Show (Y String) +derive newtype instance showY :: Show (Y String) main = do logShow (X "test") diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index ac86a7ec14..740bfc9eb8 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -576,7 +576,7 @@ data Expr -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking -- - | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type] + | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type] -- | -- A placeholder for an anonymous function argument -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 7a851fbf86..4271166326 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -583,6 +583,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls _ = mempty forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c)) - forValues (SuperClassDictionary _ tys) = mconcat (map f tys) + forValues (DeferredDictionary _ tys) = mconcat (map f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 57b0d493d7..890a46e134 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -17,6 +17,7 @@ module Language.PureScript.Parser.Declarations import Prelude hiding (lex) +import Data.Functor (($>)) import Data.Maybe (fromMaybe) import Control.Applicative @@ -63,8 +64,9 @@ kindedIdent :: TokenParser (String, Maybe Kind) kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) -parseDataDeclaration :: DataDeclType -> TokenParser Declaration -parseDataDeclaration dtype = do +parseDataDeclaration :: TokenParser Declaration +parseDataDeclaration = do + dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) name <- indented *> typeName tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do @@ -191,6 +193,7 @@ parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) <*> pure Nothing + parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do reserved "instance" @@ -215,18 +218,9 @@ parseTypeInstanceDeclaration = do parseDerivingInstanceDeclaration :: TokenParser Declaration parseDerivingInstanceDeclaration = do reserved "derive" + ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance) instanceDecl <- parseInstanceDeclaration - return $ instanceDecl DerivedInstance - -parseNewtypeInstanceDeclaration :: TokenParser Declaration -parseNewtypeInstanceDeclaration = do - instanceDecl <- parseInstanceDeclaration - return $ instanceDecl NewtypeInstance - -parseNewtypeOrNewtypeInstance :: TokenParser Declaration -parseNewtypeOrNewtypeInstance = - reserved "newtype" *> - (parseDataDeclaration Newtype <|> parseNewtypeInstanceDeclaration) + return $ instanceDecl ty positioned :: TokenParser Declaration -> TokenParser Declaration positioned = withSourceSpan PositionedDeclaration @@ -236,8 +230,7 @@ positioned = withSourceSpan PositionedDeclaration -- parseDeclaration :: TokenParser Declaration parseDeclaration = positioned (P.choice - [ parseNewtypeOrNewtypeInstance - , reserved "data" *> parseDataDeclaration Data + [ parseDataDeclaration , parseTypeDeclaration , parseTypeSynonymDeclaration , parseValueDeclaration diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 549fbe9ecb..bd36555911 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -61,7 +61,7 @@ prettyPrintValue d (Let ds val) = prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys -prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 10d09d2301..149c5929b9 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -332,9 +332,9 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do tys' <- traverse (goType' pos) tys return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints) - goExpr pos (SuperClassDictionary cls tys) = do + goExpr pos (DeferredDictionary cls tys) = do tys' <- traverse (goType' pos) tys - return (pos, SuperClassDictionary cls tys') + return (pos, DeferredDictionary cls tys') goExpr pos (TypedValue check v ty) = do ty' <- goType' pos ty return (pos, TypedValue check v ty') diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index ceaa6997b5..eec69635e4 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -129,7 +129,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- -- subString :: {} -> Sub String -- subString _ = { sub: "", --- , "__superclass_Foo_0": \_ -> +-- , "__superclass_Foo_0": \_ -> -- } -- -- and finally as the generated javascript: @@ -291,7 +291,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames implies `zip` - [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs) + [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs) | (Constraint superclass suTyArgs _) <- implies , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index cc33b84591..a5a6d8c3e5 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -87,7 +87,7 @@ deriveNewtypeInstance className ds ty tyConNm dargs = do where go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - return (SuperClassDictionary className [replaceAllTypeVars subst wrapped]) + return (DeferredDictionary className [replaceAllTypeVars subst wrapped]) go (PositionedDeclaration _ _ d) = go d go _ = throwError . errorMessage $ InvalidNewtypeInstance className [ty] diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 62d61089ad..b0ca42fdd2 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -61,7 +61,7 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss) -- | -- This function has one purpose - to skolemize type variables appearing in a --- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the +-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the -- only example of scoped type variables. -- skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr @@ -71,8 +71,8 @@ skolemizeTypesInValue ident sko scope ss = in runIdentity . f where onExpr :: [String] -> Expr -> Identity ([String], Expr) - onExpr sco (SuperClassDictionary c ts) - | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts)) + onExpr sco (DeferredDictionary c ts) + | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) onExpr sco (TypedValue check val ty) | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) onExpr sco other = return (sco, other) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 8a97bdb2c4..5b2136dc9b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -311,7 +311,7 @@ infer' (IfThenElse cond th el) = do infer' (Let ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer return $ TypedValue True (Let ds' val') valTy -infer' (SuperClassDictionary className tys) = do +infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- gets checkHints return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints @@ -583,7 +583,7 @@ check' v@(Var var) ty = do case v' of Nothing -> internalError "check: unable to check the subsumes relation." Just v'' -> return $ TypedValue True v'' ty' -check' (SuperClassDictionary className tys) _ = do +check' (DeferredDictionary className tys) _ = do {- -- Here, we replace a placeholder for a superclass dictionary with a regular -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the From 8a7c432fda4215a07f01a927ecb0b9819c20b803 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 14 Sep 2016 21:35:50 -0700 Subject: [PATCH 3/3] Examples, generalize --- examples/failing/NewtypeInstance.purs | 8 ++++++++ examples/failing/NewtypeInstance2.purs | 8 ++++++++ examples/failing/NewtypeInstance3.purs | 8 ++++++++ examples/failing/NewtypeInstance4.purs | 8 ++++++++ examples/passing/NewtypeInstance.purs | 10 +++++++++- .../PureScript/Sugar/TypeClasses/Deriving.hs | 14 +++++++------- 6 files changed, 48 insertions(+), 8 deletions(-) create mode 100644 examples/failing/NewtypeInstance.purs create mode 100644 examples/failing/NewtypeInstance2.purs create mode 100644 examples/failing/NewtypeInstance3.purs create mode 100644 examples/failing/NewtypeInstance4.purs diff --git a/examples/failing/NewtypeInstance.purs b/examples/failing/NewtypeInstance.purs new file mode 100644 index 0000000000..3ffe08036e --- /dev/null +++ b/examples/failing/NewtypeInstance.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +data X = X + +derive newtype instance showX :: Show X diff --git a/examples/failing/NewtypeInstance2.purs b/examples/failing/NewtypeInstance2.purs new file mode 100644 index 0000000000..67b16fcbe3 --- /dev/null +++ b/examples/failing/NewtypeInstance2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +data X a = X a a + +derive newtype instance showX :: Show a => Show (X a) diff --git a/examples/failing/NewtypeInstance3.purs b/examples/failing/NewtypeInstance3.purs new file mode 100644 index 0000000000..528eefb67f --- /dev/null +++ b/examples/failing/NewtypeInstance3.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +class Nullary + +derive newtype instance nullary :: Nullary diff --git a/examples/failing/NewtypeInstance4.purs b/examples/failing/NewtypeInstance4.purs new file mode 100644 index 0000000000..4004520b4f --- /dev/null +++ b/examples/failing/NewtypeInstance4.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +data X = X | Y + +derive newtype instance showX :: Show X diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index f61f420378..416405a015 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -16,7 +16,15 @@ newtype Y a = Y (Array a) derive newtype instance showY :: Show (Y String) +class Singleton a b where + singleton :: a -> b + +instance singletonArray :: Singleton a (Array a) where + singleton x = [x] + +derive newtype instance singletonY :: Singleton a (Y a) + main = do logShow (X "test") - logShow (Y ["test"]) + logShow (singleton "test" :: Y String) log "Done" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index a5a6d8c3e5..ff57c7e1f7 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -54,10 +54,10 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] NewtypeInstance) - | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty +deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) + | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds ty tyCon args + = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) = throwError . errorMessage $ InvalidNewtypeInstance className tys deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d @@ -77,19 +77,19 @@ deriveNewtypeInstance . MonadError MultipleErrors m => Qualified (ProperName 'ClassName) -> [Declaration] - -> Type + -> [Type] -> ProperName 'TypeName -> [Type] -> m Expr -deriveNewtypeInstance className ds ty tyConNm dargs = do +deriveNewtypeInstance className ds tys tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds go tyCon where go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - return (DeferredDictionary className [replaceAllTypeVars subst wrapped]) + return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped])) go (PositionedDeclaration _ _ d) = go d - go _ = throwError . errorMessage $ InvalidNewtypeInstance className [ty] + go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]