git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1634 from purescript/1632
68c7290Phil Freeman
core-tests/tests/generic-deriving/Main.purs+5−1
compare with golang
unifiedsplit
@@ -17,7 +17,11 @@ data A a
17 | D { a :: a }
17 | D { a :: a }
18 | E Void
18 | E Void
19
19
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)
21
25
22main :: forall eff. Eff (console :: CONSOLE | eff) Unit
26main :: forall eff. Eff (console :: CONSOLE | eff) Unit
23main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] }))
27main = 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+16−13
@@ -52,17 +52,19 @@ deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (derive
52deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
52deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
53deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
53deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
54 | className == Qualified (Just dataGeneric) (ProperName C.generic)
54 | className == Qualified (Just dataGeneric) (ProperName C.generic)
55− , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
55+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
56 , mn == fromMaybe mn mn'
56 , 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
58deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
58deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
59 = throwError . errorMessage $ CannotDerive className tys
59 = throwError . errorMessage $ CannotDerive className tys
60deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
60deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
61deriveInstance _ _ e = return e
61deriveInstance _ _ e = return e
62
62
63−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)
63+unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])
64−unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon
64+unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])
65−unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty
65+unwrapTypeConstructor (TypeApp ty arg) = do
66+ (tyCon, args) <- unwrapTypeConstructor ty
67+ return (tyCon, arg : args)
66unwrapTypeConstructor _ = Nothing
68unwrapTypeConstructor _ = Nothing
67
69
68dataGeneric :: ModuleName
70dataGeneric :: ModuleName
@@ -71,12 +73,12 @@ dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
71dataMaybe :: ModuleName
73dataMaybe :: ModuleName
72dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
74dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
73
75
74−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]
76+deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]
75−deriveGeneric mn ds tyConNm = do
77+deriveGeneric mn ds tyConNm args = do
76 tyCon <- findTypeDecl tyConNm ds
78 tyCon <- findTypeDecl tyConNm ds
77 toSpine <- mkSpineFunction mn tyCon
79 toSpine <- mkSpineFunction mn tyCon
78 fromSpine <- mkFromSpineFunction mn tyCon
80 fromSpine <- mkFromSpineFunction mn tyCon
79− let toSignature = mkSignatureFunction mn tyCon
81+ let toSignature = mkSignatureFunction mn tyCon args
80 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
82 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
81 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
83 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
82 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
84 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
@@ -118,8 +120,8 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl
118mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
120mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
119mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
121mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
120
122
121−mkSignatureFunction :: ModuleName -> Declaration -> Expr
123+mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr
122−mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
124+mkSignatureFunction _ (DataDeclaration _ _ tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
123 where
125 where
124 mkSigProd :: [Expr] -> Expr
126 mkSigProd :: [Expr] -> Expr
125 mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
127 mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
@@ -132,7 +134,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m
132
134
133 mkProdClause :: (ProperName, [Type]) -> Expr
135 mkProdClause :: (ProperName, [Type]) -> Expr
134 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
136 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
135− , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
137+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
136 ]
138 ]
137
139
138 mkProductSignature :: Type -> Expr
140 mkProductSignature :: Type -> Expr
@@ -144,8 +146,9 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m
144 ]
146 ]
145 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
147 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
146 (TypedValue False (mkGenVar "anyProxy") (proxy typ))
148 (TypedValue False (mkGenVar "anyProxy") (proxy typ))
149+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
147−mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
150+mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs
148−mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
151+mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
149
152
150mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
153mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
151mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
154mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)