- -- tc_inst_head expects HsPredTy, which isn't usually even allowed
- tc_inst_head (HsPredTy pred)
- = do { pred' <- kcHsPred pred
- ; pred'' <- dsHsPred pred'
- ; return ([], [], mkPredTy pred'') }
-
- tc_inst_head (HsForAllTy _ tvs ctxt (L _ (HsPredTy pred)))
- = kcHsTyVars tvs $ \ tvs' ->
- do { ctxt' <- kcHsContext ctxt
- ; pred' <- kcHsPred pred
- ; tcTyVarBndrs tvs' $ \ tvs'' ->
- do { ctxt'' <- mapM dsHsLPred (unLoc ctxt')
- ; pred'' <- dsHsPred pred'
- ; return (tvs'', ctxt'', mkPredTy pred'') } }
-
- tc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type"))
+ kc_inst_head ty@(HsPredTy pred@(HsClassP {}))
+ = do { (pred', kind) <- kc_pred pred
+ ; checkExpectedKind ty kind ekLifted
+ ; return (HsPredTy pred') }
+ kc_inst_head (HsForAllTy exp tv_names context (L loc ty))
+ = kcHsTyVars tv_names $ \ tv_names' ->
+ do { ctxt' <- kcHsContext context
+ ; ty' <- kc_inst_head ty
+ ; return (HsForAllTy exp tv_names' ctxt' (L loc ty')) }
+ kc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type"))
+
+ ds_inst_head (HsPredTy (HsClassP cls_name tys))
+ = do { clas <- tcLookupClass cls_name
+ ; arg_tys <- dsHsTypes tys
+ ; return ([], [], clas, arg_tys) }
+ ds_inst_head (HsForAllTy _ tvs ctxt (L _ tau))
+ = tcTyVarBndrs tvs $ \ tvs' ->
+ do { ctxt' <- mapM dsHsLPred (unLoc ctxt)
+ ; (tvs_r, ctxt_r, cls, tys) <- ds_inst_head tau
+ ; return (tvs' ++ tvs_r, ctxt' ++ ctxt_r , cls, tys) }
+ ds_inst_head _ = panic "ds_inst_head"