git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge master
9aa0928Phil 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 mn (DataDeclaration _ name _ args) = lamNull . mkSigProd $ map mkProdClause args
124+mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
123 where
125 where
124 mkSigProd :: [Expr] -> Expr
126 mkSigProd :: [Expr] -> Expr
125 mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
127 mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
@@ -134,7 +136,7 @@ mkSignatureFunction mn (DataDeclaration _ name _ args) = lamNull . mkSigProd $ m
134
136
135 mkProdClause :: (ProperName, [Type]) -> Expr
137 mkProdClause :: (ProperName, [Type]) -> Expr
136 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
138 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)
138 ]
140 ]
139
141
140 mkProductSignature :: Type -> Expr
142 mkProductSignature :: Type -> Expr
@@ -146,8 +148,9 @@ mkSignatureFunction mn (DataDeclaration _ name _ args) = lamNull . mkSigProd $ m
146 ]
148 ]
147 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
149 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
148 (TypedValue False (mkGenVar "anyProxy") (proxy typ))
150 (TypedValue False (mkGenVar "anyProxy") (proxy typ))
151+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
149−mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
152+mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs
150−mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
153+mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
151
154
152mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
155mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
153mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
156mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)