@@ -55,10 +55,10 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
5555 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
5656deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
5757 | className == Qualified (Just dataNewtype) (ProperName "Newtype")
58− , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy
58+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
5959 , mn == fromMaybe mn mn'
6060 = do
61− (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy
61+ (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
6262 return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
6363deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
6464 = throwError . errorMessage $ CannotDerive className tys
@@ -427,40 +427,41 @@ deriveNewtype
427427 => ModuleName
428428 -> [Declaration]
429429 -> ProperName 'TypeName
430+ -> [Type]
430431 -> Type
431432 -> m ([Declaration], Type)
432−deriveNewtype mn ds tyConNm unwrappedTy = do
433− checkIsWildcard unwrappedTy
434− go =<< findTypeDecl tyConNm ds
433+deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
434+ checkIsWildcard unwrappedTy
435+ go =<< findTypeDecl tyConNm ds
435436 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"
436459
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 (TypeWildcard _) =
461− return ()
462− checkIsWildcard _ =
463− throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
460+ checkIsWildcard :: Type -> m ()
461+ checkIsWildcard (TypeWildcard _) =
462+ return ()
463+ checkIsWildcard _ =
464+ throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
464465
465466findTypeDecl
466467 :: (MonadError MultipleErrors m)