Skip to content

Commit 9aa0928

Browse files
paf31paf31
committed
Merge master
2 parents 759b3c6 + 68c7290 commit 9aa0928

File tree

2 files changed

+21
-14
lines changed

2 files changed

+21
-14
lines changed

‎core-tests/tests/generic-deriving/Main.purs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,11 @@ data A a
1717
| D { a :: a }
1818
| E Void
1919

20-
derive instance genericA :: (Generic a) => Generic (A a)
20+
derive instance genericA :: (Generic b) => Generic (A b)
21+
22+
newtype X b = X b
23+
24+
derive instance genericX :: Generic (X String)
2125

2226
main :: forall eff. Eff (console :: CONSOLE | eff) Unit
2327
main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] }))

‎src/Language/PureScript/Sugar/TypeClasses/Deriving.hs‎

Lines changed: 16 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -52,17 +52,19 @@ deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (derive
5252
deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
5353
deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
5454
| className == Qualified (Just dataGeneric) (ProperName C.generic)
55-
, Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
55+
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
5656
, mn == fromMaybe mn mn'
57-
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
57+
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
5858
deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
5959
= throwError . errorMessage $ CannotDerive className tys
6060
deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
6161
deriveInstance _ _ e = return e
6262

63-
unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)
64-
unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon
65-
unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty
63+
unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])
64+
unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])
65+
unwrapTypeConstructor (TypeApp ty arg) = do
66+
(tyCon, args) <- unwrapTypeConstructor ty
67+
return (tyCon, arg : args)
6668
unwrapTypeConstructor _ = Nothing
6769

6870
dataGeneric :: ModuleName
@@ -71,12 +73,12 @@ dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
7173
dataMaybe :: ModuleName
7274
dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
7375

74-
deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]
75-
deriveGeneric mn ds tyConNm = do
76+
deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]
77+
deriveGeneric mn ds tyConNm args = do
7678
tyCon <- findTypeDecl tyConNm ds
7779
toSpine <- mkSpineFunction mn tyCon
7880
fromSpine <- mkFromSpineFunction mn tyCon
79-
let toSignature = mkSignatureFunction mn tyCon
81+
let toSignature = mkSignatureFunction mn tyCon args
8082
return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
8183
, ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
8284
, ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
@@ -118,8 +120,8 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl
118120
mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
119121
mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
120122

121-
mkSignatureFunction :: ModuleName -> Declaration -> Expr
122-
mkSignatureFunction mn (DataDeclaration _ name _ args) = lamNull . mkSigProd $ map mkProdClause args
123+
mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr
124+
mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
123125
where
124126
mkSigProd :: [Expr] -> Expr
125127
mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
@@ -134,7 +136,7 @@ mkSignatureFunction mn (DataDeclaration _ name _ args) = lamNull . mkSigProd $ m
134136

135137
mkProdClause :: (ProperName, [Type]) -> Expr
136138
mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
137-
, ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
139+
, ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
138140
]
139141

140142
mkProductSignature :: Type -> Expr
@@ -146,8 +148,9 @@ mkSignatureFunction mn (DataDeclaration _ name _ args) = lamNull . mkSigProd $ m
146148
]
147149
mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
148150
(TypedValue False (mkGenVar "anyProxy") (proxy typ))
149-
mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
150-
mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
151+
instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
152+
mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs
153+
mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
151154

152155
mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
153156
mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)

0 commit comments

Comments
 (0)