diff options
| author | Richard Eisenberg <rae@cs.brynmawr.edu> | 2018-05-30 21:49:41 -0400 |
|---|---|---|
| committer | Richard Eisenberg <rae@cs.brynmawr.edu> | 2018-05-30 21:49:41 -0400 |
| commit | 16944e6c462d782671d719ace1b8430070e9b2bd (patch) | |
| tree | e901bb9aa4787816bbb52a5418a5d80219665c41 | |
| parent | 6d4cb46331bac13a8b56cf636534257c39cb8532 (diff) | |
| download | haskell-16944e6c462d782671d719ace1b8430070e9b2bd.tar.gz | |
Fix newtype instance GADTs
| -rw-r--r-- | compiler/basicTypes/MkId.hs | 11 |
1 files changed, 9 insertions, 2 deletions
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 7e555200e6..15ce5c28c2 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -569,10 +569,17 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con -- Passing Nothing here allows the wrapper to inline when -- unsaturated. wrap_unf = mkInlineUnfolding wrap_rhs + + -- Newtype "workers" already have any family coercion applied + -- (see the definition of newtype_unf in mkDataConWorkId), so + -- we don't want to apply the coercion again. + casted_body | isNewTyCon tycon = wrap_body + | otherwise = wrapFamInstBody tycon res_ty_args $ + wrap_body + wrap_rhs = mkLams wrap_tvs $ mkLams wrap_args $ - wrapFamInstBody tycon res_ty_args $ - wrap_body + casted_body ; return (DCR { dcr_wrap_id = wrap_id , dcr_boxer = mk_boxer boxers |