Commit a2d3594c authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

Refactor some cruft in TcDerivInfer.inferConstraints

The latest installment in my quest to clean up the code in
`TcDeriv*`. This time, my sights are set on
`TcDerivInfer.inferConstraints`, which infers the context for derived
instances. This function is a wee bit awkward at the moment:

* It's not terribly obvious from a quick glance, but
  `inferConstraints` is only ever invoked when using the `stock` or
  `anyclass` deriving strategies, as the code for inferring the
  context for `newtype`- or `via`-derived instances is located
  separately in `mk_coerce_based_eqn`. But there's no good reason
  for things to be this way, so I moved this code from
  `mk_coerce_based_eqn` to `inferConstraints` so that everything
  related to inferring instance contexts is located in one place.
* In this process, I discovered that the Haddocks for the auxiliary
  function `inferConstraintsDataConArgs` are completely wrong. It
  claims that it handles both `stock` and `newtype` deriving, but
  this is completely wrong, as discussed above—it only handles
  `stock`. To rectify this, I renamed this function to
  `inferConstraintsStock` to reflect its actual purpose and created
  a new `inferConstraintsCoerceBased` function to specifically
  handle `newtype` (and `via`) deriving.

Doing this revealed some opportunities for further simplification:

* Removing the context-inference–related code from
  `mk_coerce_based_eqn` made me realize that the overall structure
  of the function is basically identical to `mk_originative_eqn`.
  In fact, I was easily able to combine the two functions into a
  single `mk_eqn_from_mechanism` function.

  As part of this merger, I now invoke
  `atf_coerce_based_error_checks` from `doDerivInstErrorChecks1`.
* I discovered that GHC defined this function:

  ```hs
  typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
  ```

  No fewer than four times in different modules. I consolidated all
  of these definitions in a single location in `TysWiredIn`.
parent 0ca044fd
Pipeline #11373 passed with stages
in 360 minutes and 43 seconds
......@@ -92,7 +92,8 @@ module TysWiredIn (
-- * Kinds
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
isLiftedTypeKindTyConName, liftedTypeKind,
typeToTypeKind, constraintKind,
liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName,
liftedTypeKindTyConName,
......@@ -612,8 +613,9 @@ typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
liftedTypeKind, constraintKind :: Kind
liftedTypeKind, typeToTypeKind, constraintKind :: Kind
liftedTypeKind = tYPE liftedRepTy
typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
{-
......
This diff is collapsed.
This diff is collapsed.
......@@ -1441,7 +1441,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
kind1, kind2 :: Kind
kind1 = liftedTypeKind `mkVisFunTy` liftedTypeKind
kind1 = typeToTypeKind
kind2 = liftedTypeKind `mkVisFunTy` kind1
gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
......
......@@ -616,16 +616,15 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
, trS_by = by, trS_using = using, trS_form = form
, trS_ret = return_op, trS_bind = bind_op
, trS_fmap = fmap_op }) res_ty thing_inside
= do { let star_star_kind = liftedTypeKind `mkVisFunTy` liftedTypeKind
; m1_ty <- newFlexiTyVarTy star_star_kind
; m2_ty <- newFlexiTyVarTy star_star_kind
= do { m1_ty <- newFlexiTyVarTy typeToTypeKind
; m2_ty <- newFlexiTyVarTy typeToTypeKind
; tup_ty <- newFlexiTyVarTy liftedTypeKind
; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
-- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
; n_app <- case form of
ThenForm -> return (\ty -> ty)
_ -> do { n_ty <- newFlexiTyVarTy star_star_kind
_ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind
; return (n_ty `mkAppTy`) }
; let by_arrow :: Type -> Type
-- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
......@@ -741,8 +740,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
-- -> m (st1, (st2, st3))
--
tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
= do { let star_star_kind = liftedTypeKind `mkVisFunTy` liftedTypeKind
; m_ty <- newFlexiTyVarTy star_star_kind
= do { m_ty <- newFlexiTyVarTy typeToTypeKind
; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $
(m_ty `mkAppTy` alphaTy)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment