e177fb3 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Fix #1632, instantiate type variables in anyProxy calls in generic instances.

commite177fb39a0c3cdcfae436833aab2b3b8641c3528 authorPhil Freeman <paf31@cantab.net> dateSat 14 Nov 2015, 20:20 (11 years ago) parentcf0d9d3

2 files changed+21−14

compare with golang

unifiedsplit

core-tests/tests/generic-deriving/Main.purs+5−1 src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+16−13

core-tests/tests/generic-deriving/Main.purs+5−1

@@ -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

2226main :: forall eff. Eff (console :: CONSOLE | eff) Unit

2327main = 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

5252deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

5353deriveInstance 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

5858deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

5959 = throwError . errorMessage $ CannotDerive className tys

6060deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

6161deriveInstance _ _ 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)

6668unwrapTypeConstructor _ = Nothing

6769

6870dataGeneric :: ModuleName

@@ -71,12 +73,12 @@ dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

7173dataMaybe :: ModuleName

7274dataMaybe = 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

118120mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

119121mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"

120122

121−mkSignatureFunction :: ModuleName -> Declaration -> Expr

122−mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args

123+mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr

124+mkSignatureFunction _ (DataDeclaration _ _ tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

123125 where

124126 mkSigProd :: [Expr] -> Expr

125127 mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral

@@ -132,7 +134,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m

132134

133135 mkProdClause :: (ProperName, [Type]) -> Expr

134136 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))

135− , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)

137+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

136138 ]

137139

138140 mkProductSignature :: Type -> Expr

@@ -144,8 +146,9 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m

144146 ]

145147 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

146148 (TypedValue False (mkGenVar "anyProxy") (proxy typ))

147−mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d

148−mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

149+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

150+mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs

151+mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

149152

150153mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

151154mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)