diff options
| author | Brandon Chinn <brandon@leapyear.io> | 2020-07-21 11:19:05 -0700 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-07-29 15:07:11 -0400 |
| commit | a61411cab31fcc08f1dcd629b85c736e2b5b6bc7 (patch) | |
| tree | b43b3b3b0fb715881b820ede5848890b4904dd3c | |
| parent | c59064b0c60d3d779f5fd067be4b6648d8de23cf (diff) | |
| download | haskell-a61411cab31fcc08f1dcd629b85c736e2b5b6bc7.tar.gz | |
Pass dit_rep_tc_args to dsm_stock_gen_fn
| -rw-r--r-- | compiler/GHC/Tc/Deriv.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Utils.hs | 17 |
2 files changed, 15 insertions, 9 deletions
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 5140f29d00..9fe439e42e 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -2038,9 +2038,12 @@ genDerivStuff mechanism loc clas inst_tys tyvars -> gen_newtype_or_via rhs_ty -- Try a stock deriver - DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc} + DerivSpecStock { dsm_stock_dit = DerivInstTys + { dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args + } , dsm_stock_gen_fn = gen_fn } - -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys + -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys pure (binds, [], faminsts, field_names) -- Try DeriveAnyClass diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index b17cbb14b9..2b28607ae3 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -218,8 +218,9 @@ data DerivSpecMechanism -- instance, including what type constructor the last argument is -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. , dsm_stock_gen_fn :: - SrcSpan -> TyCon - -> [Type] + SrcSpan -> TyCon -- dit_rep_tc + -> [Type] -- dit_rep_tc_args + -> [Type] -- inst_tys -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) -- ^ This function returns three things: -- @@ -424,7 +425,7 @@ instance Outputable DerivContext where -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". data OriginativeDerivStatus = CanDeriveStock -- Stock class, can derive - (SrcSpan -> TyCon -> [Type] + (SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) | StockClassError SDoc -- Stock class, but can't do it | CanDeriveAnyClass -- See Note [Deriving any class] @@ -563,6 +564,7 @@ hasStockDeriving :: Class -> Maybe (SrcSpan -> TyCon -> [Type] + -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) hasStockDeriving clas = assocMaybe gen_list (getUnique clas) @@ -571,6 +573,7 @@ hasStockDeriving clas :: [(Unique, SrcSpan -> TyCon -> [Type] + -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))] gen_list = [ (eqClassKey, simpleM gen_Eq_binds) , (ordClassKey, simpleM gen_Ord_binds) @@ -587,7 +590,7 @@ hasStockDeriving clas , (genClassKey, generic (gen_Generic_binds Gen0)) , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - simple gen_fn loc tc _ + simple gen_fn loc tc _ _ = let (binds, deriv_stuff) = gen_fn loc tc in return (binds, deriv_stuff, []) @@ -595,17 +598,17 @@ hasStockDeriving clas -- do is allocate new Uniques, which are used for generating the names of -- auxiliary bindings. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. - simpleM gen_fn loc tc _ + simpleM gen_fn loc tc _ _ = do { (binds, deriv_stuff) <- gen_fn loc tc ; return (binds, deriv_stuff, []) } - read_or_show gen_fn loc tc _ + read_or_show gen_fn loc tc _ _ = do { fix_env <- getDataConFixityFun tc ; let (binds, deriv_stuff) = gen_fn fix_env loc tc field_names = all_field_names tc ; return (binds, deriv_stuff, field_names) } - generic gen_fn _ tc inst_tys + generic gen_fn _ tc _ inst_tys = do { (binds, faminst) <- gen_fn tc inst_tys ; let field_names = all_field_names tc ; return (binds, unitBag (DerivFamInst faminst), field_names) } |