git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #2331, substutute types in newtype class deriving
c59f991Phil Freeman
examples/passing/DeriveNewtype.purs+10
compare with golang
unifiedsplit
@@ -14,4 +14,14 @@ t = wrap "hello"
14a :: String
14a :: String
15a = unwrap t
15a = unwrap t
16
16
17+newtype First a = First a
18+
19+derive instance newtypeFirst :: Newtype (First b) _
20+
21+f :: First Int
22+f = wrap 1
23+
24+i :: Int
25+i = unwrap f
26+
17main = log "Done"
27main = log "Done"
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+33−32
@@ -55,10 +55,10 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
55 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
55 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
56deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
56deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
57 | className == Qualified (Just dataNewtype) (ProperName "Newtype")
57 | className == Qualified (Just dataNewtype) (ProperName "Newtype")
58− , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy
58+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
59 , mn == fromMaybe mn mn'
59 , mn == fromMaybe mn mn'
60 = do
60 = do
61− (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy
61+ (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
62 return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
62 return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
63deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
63deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
64 = throwError . errorMessage $ CannotDerive className tys
64 = throwError . errorMessage $ CannotDerive className tys
@@ -427,40 +427,41 @@ deriveNewtype
427 => ModuleName
427 => ModuleName
428 -> [Declaration]
428 -> [Declaration]
429 -> ProperName 'TypeName
429 -> ProperName 'TypeName
430+ -> [Type]
430 -> Type
431 -> Type
431 -> m ([Declaration], Type)
432 -> m ([Declaration], Type)
432−deriveNewtype mn ds tyConNm unwrappedTy = do
433+deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
433− checkIsWildcard unwrappedTy
434+ checkIsWildcard unwrappedTy
434− go =<< findTypeDecl tyConNm ds
435+ go =<< findTypeDecl tyConNm ds
435 where
436 where
437+ go :: Declaration -> m ([Declaration], Type)
438+ go (DataDeclaration Data name _ _) =
439+ throwError . errorMessage $ CannotDeriveNewtypeForData name
440+ go (DataDeclaration Newtype name args dctors) = do
441+ checkNewtype name dctors
442+ wrappedIdent <- freshIdent "n"
443+ unwrappedIdent <- freshIdent "a"
444+ let (ctorName, [ty]) = head dctors
445+ inst =
446+ [ ValueDeclaration (Ident "wrap") Public [] $ Right $
447+ Constructor (Qualified (Just mn) ctorName)
448+ , ValueDeclaration (Ident "unwrap") Public [] $ Right $
449+ lamCase wrappedIdent
450+ [ CaseAlternative
451+ [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
452+ (Right (Var (Qualified Nothing unwrappedIdent)))
453+ ]
454+ ]
455+ subst = zipWith ((,) . fst) args tyConArgs
456+ return (inst, replaceAllTypeVars subst ty)
457+ go (PositionedDeclaration _ _ d) = go d
458+ go _ = internalError "deriveNewtype go: expected DataDeclaration"
436
459
437− go :: Declaration -> m ([Declaration], Type)
438− go (DataDeclaration Data name _ _) =
439− throwError . errorMessage $ CannotDeriveNewtypeForData name
440− go (DataDeclaration Newtype name _ dctors) = do
441− checkNewtype name dctors
442− let (ctorName, [ty]) = head dctors
443− wrappedIdent <- freshIdent "n"
444− unwrappedIdent <- freshIdent "a"
445− let inst =
446− [ ValueDeclaration (Ident "wrap") Public [] $ Right $
447− Constructor (Qualified (Just mn) ctorName)
448− , ValueDeclaration (Ident "unwrap") Public [] $ Right $
449− lamCase wrappedIdent
450− [ CaseAlternative
451− [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
452− (Right (Var (Qualified Nothing unwrappedIdent)))
453− ]
454− ]
455− return (inst, ty)
456− go (PositionedDeclaration _ _ d) = go d
457− go _ = internalError "deriveNewtype go: expected DataDeclaration"
458−
459− checkIsWildcard :: Type -> m ()
460+ checkIsWildcard :: Type -> m ()
460− checkIsWildcard (TypeWildcard _) =
461+ checkIsWildcard (TypeWildcard _) =
461− return ()
462+ return ()
462− checkIsWildcard _ =
463+ checkIsWildcard _ =
463− throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
464+ throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
464
465
465findTypeDecl
466findTypeDecl
466 :: (MonadError MultipleErrors m)
467 :: (MonadError MultipleErrors m)