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 new file mode 100644 index 0000000000..416405a015 --- /dev/null +++ b/examples/passing/NewtypeInstance.purs @@ -0,0 +1,30 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +newtype X = X String + +derive newtype instance showX :: Show X + +derive newtype instance eqX :: Eq X + +derive newtype instance ordX :: Ord X + +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 (singleton "test" :: Y String) + log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index d0de7e674c..740bfc9eb8 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 @@ -570,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/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..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 @@ -192,6 +193,7 @@ parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) <*> pure Nothing + parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do reserved "instance" @@ -216,8 +218,9 @@ parseTypeInstanceDeclaration = do parseDerivingInstanceDeclaration :: TokenParser Declaration parseDerivingInstanceDeclaration = do reserved "derive" + ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance) instanceDecl <- parseInstanceDeclaration - return $ instanceDecl DerivedInstance + return $ instanceDecl ty positioned :: TokenParser Declaration -> TokenParser Declaration positioned = withSourceSpan PositionedDeclaration 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 7262224dd7..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: @@ -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) @@ -287,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 086d4ae18c..ff57c7e1f7 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@(_ : _) NewtypeInstance) + | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) + , mn == fromMaybe mn mn' + = 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 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 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 (init tys ++ [replaceAllTypeVars subst wrapped])) + go (PositionedDeclaration _ _ d) = go d + go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys + dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] 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