diff options
Diffstat (limited to 'compiler/GHC/Tc/TyCl.hs')
| -rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 187 |
1 files changed, 125 insertions, 62 deletions
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 302f93e691..5f4312d093 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -99,6 +99,7 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import Control.Monad +import Data.Foldable import Data.Functor.Identity import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) @@ -1604,16 +1605,22 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc ------------------- --- Kind-check the types of the arguments to a data constructor. +-- Kind-check the type of an argument to a data constructor. -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need --- the first two arguments. +-- the first argument. +kcConArgTy :: ContextKind -> HsScaled GhcRn (LHsType GhcRn) -> TcM () +kcConArgTy exp_kind (HsScaled mult ty) = do + { _ <- tcCheckLHsType (getBangType ty) exp_kind + ; void $ tcMult mult + -- See Note [Implementation of UnliftedNewtypes], STEP 2 + } + +-- Kind-check the types of the arguments to a data constructor. kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do { let exp_kind = getArgExpKind new_or_data res_kind - ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind - tcMult mult) - -- See Note [Implementation of UnliftedNewtypes], STEP 2 + ; traverse_ (kcConArgTy exp_kind) arg_tys } -- Kind-check the types of arguments to a Haskell98 data constructor. @@ -1624,12 +1631,28 @@ kcConH98Args new_or_data res_kind con_args = case con_args of RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $ map (hsLinear . cd_fld_type . unLoc) flds --- Kind-check the types of arguments to a GADT data constructor. -kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM () -kcConGADTArgs new_or_data res_kind con_args = case con_args of - PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys - RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ - map (hsLinear . cd_fld_type . unLoc) flds +-- Kind-check the types of the arguments and result in a GADT data constructor. +kcConGadtSigBody :: NewOrData -> Kind -> ConGadtSigBody GhcRn -> TcM () +kcConGadtSigBody new_or_data res_kind body = case body of + PrefixConGADT prefix_body -> + kcPrefixConGadtSigBody new_or_data res_kind prefix_body + RecConGADT (L _ flds) _ res_ty -> do + _ <- tcCheckLHsType res_ty (TheKind res_kind) + kcConArgTys new_or_data res_kind $ map (hsLinear . cd_fld_type . unLoc) flds + +-- Kind-check the types of the arguments and result in a prefix GADT data constructor. +kcPrefixConGadtSigBody :: NewOrData -> Kind -> PrefixConGadtSigBody GhcRn -> TcM () +kcPrefixConGadtSigBody new_or_data res_kind = go + where + exp_kind :: ContextKind + exp_kind = getArgExpKind new_or_data res_kind + + go :: PrefixConGadtSigBody GhcRn -> TcM () + go (PCGSRes res_ty) = + void $ tcCheckLHsType res_ty (TheKind res_kind) + go (PCGSAnonArg arg_ty body) = do + go body + kcConArgTy exp_kind arg_ty kcConDecls :: NewOrData -> TcKind -- The result kind signature @@ -1668,7 +1691,7 @@ kcConDecl new_or_data _tc_res_kind -- Not used in GADT case (and doesn't make sense) (ConDeclGADT { con_names = names, con_bndrs = L _ outer_bndrs, con_mb_cxt = cxt - , con_g_args = args, con_res_ty = res_ty }) + , con_body = body }) = -- See Note [kcConDecls: kind-checking data type decls] addErrCtxt (dataConCtxt names) $ discardResult $ @@ -1676,10 +1699,9 @@ kcConDecl new_or_data bindOuterSigTKBndrs_Tv outer_bndrs $ -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] do { _ <- tcHsContext cxt - ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty) + ; traceTc "kcConDecl:GADT {" (ppr names) ; con_res_kind <- newOpenTypeKind - ; _ <- tcCheckLHsType res_ty (TheKind con_res_kind) - ; kcConGADTArgs new_or_data con_res_kind args + ; kcConGadtSigBody new_or_data con_res_kind body ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr con_res_kind) ; return () } @@ -2174,7 +2196,7 @@ newtype instance Foo 'Red = FooRedC Int# Note that, in the GADT case, we might have a kind signature with arrows (newtype XYZ a b :: Type -> Type where ...). We want only the final -component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon +component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon in kcTyClDecl. STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function @@ -3480,8 +3502,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map -- we get the res_kind by typechecking the result type. (ConDeclGADT { con_names = names , con_bndrs = L _ outer_hs_bndrs - , con_mb_cxt = cxt, con_g_args = hs_args - , con_res_ty = hs_res_ty }) + , con_mb_cxt = cxt, con_body = body }) = addErrCtxt (dataConCtxt names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) ; let (L _ name : _) = names @@ -3490,26 +3511,8 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ tcOuterTKBndrs skol_info outer_hs_bndrs $ do { ctxt <- tcHsContext cxt - ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty - -- See Note [GADT return kinds] - - -- For data instances (only), ensure that the return type, - -- res_ty, is a substitution instance of the header. - -- See Note [GADT return types] - ; case dd_info of - DDataType -> return () - DDataInstance hdr_ty -> - do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs) - ; let head_shape = substTy subst hdr_ty - ; discardResult $ - popErrCtxt $ -- Drop dataConCtxt - addErrCtxt (dataConResCtxt names) $ - unifyType Nothing res_ty head_shape } - - -- See Note [Datatype return kinds] - ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConGADTArgs exp_kind hs_args - + ; (btys, res_ty) <- + tcConGadtSigBody names new_or_data dd_info tc_bndrs body ; let (arg_tys, stricts) = unzip btys ; field_lbls <- lookupConstructorFields name ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) @@ -3550,7 +3553,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map ; dflags <- getDynFlags ; let buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_args + { is_infix <- tcConIsInfixGADT name body ; rep_nm <- newTyConRepName name ; let bang_opts = SrcBangOpts (initBangOpts dflags) @@ -3663,14 +3666,14 @@ tcConIsInfixH98 _ details PrefixCon{} -> return False tcConIsInfixGADT :: Name - -> HsConDeclGADTDetails GhcRn - -> TcM Bool -tcConIsInfixGADT con details - = case details of + -> ConGadtSigBody GhcRn + -> TcM Bool +tcConIsInfixGADT con body + = case body of RecConGADT{} -> return False - PrefixConGADT arg_tys -- See Note [Infix GADT constructors] + PrefixConGADT prefix_body -- See Note [Infix GADT constructors] | isSymOcc (getOccName con) - , [_ty1,_ty2] <- map hsScaledThing arg_tys + , [_ty1,_ty2] <- map hsScaledThing $ anonPrefixConGadtSigArgs prefix_body -> do { fix_env <- getFixityEnv ; return (con `elemNameEnv` fix_env) } | otherwise -> return False @@ -3689,15 +3692,68 @@ tcConH98Args exp_kind (InfixCon bty1 bty2) tcConH98Args exp_kind (RecCon fields) = tcRecConDeclFields exp_kind fields -tcConGADTArgs :: ContextKind -- expected kind of arguments - -- always OpenKind for datatypes, but unlifted newtypes - -- might have a specific kind - -> HsConDeclGADTDetails GhcRn - -> TcM [(Scaled TcType, HsSrcBang)] -tcConGADTArgs exp_kind (PrefixConGADT btys) - = mapM (tcConArg exp_kind) btys -tcConGADTArgs exp_kind (RecConGADT fields _) - = tcRecConDeclFields exp_kind fields +tcConGadtSigBody :: [LocatedN Name] + -> NewOrData + -> DataDeclInfo + -> [TcTyConBinder] + -> ConGadtSigBody GhcRn + -> TcM ([(Scaled TcType, HsSrcBang)], TcType) +tcConGadtSigBody names new_or_data dd_info tc_bndrs body = + case body of + PrefixConGADT btys -> + tcPrefixConGadtSigBody names new_or_data dd_info tc_bndrs btys + RecConGADT fields _ res_ty -> do + -- See Note [GADT return kinds] + (tc_res_ty, tc_res_kind) <- tcConGadtResTy names dd_info tc_bndrs res_ty + -- See Note [Datatype return kinds] + let exp_kind = getArgExpKind new_or_data tc_res_kind + tc_arg_tys <- tcRecConDeclFields exp_kind fields + pure (tc_arg_tys, tc_res_ty) + +tcPrefixConGadtSigBody :: [LocatedN Name] + -> NewOrData + -> DataDeclInfo + -> [TcTyConBinder] + -> PrefixConGadtSigBody GhcRn + -> TcM ([(Scaled TcType, HsSrcBang)], TcType) +tcPrefixConGadtSigBody names new_or_data dd_info tc_bndrs prefix_body = do + (tc_arg_tys, tc_res_ty, _) <- go prefix_body + pure (tc_arg_tys, tc_res_ty) + where + go :: PrefixConGadtSigBody GhcRn + -> TcM ([(Scaled TcType, HsSrcBang)], TcType, TcKind) + go (PCGSRes res_ty) = do + (tc_res_ty, tc_res_kind) <- tcConGadtResTy names dd_info tc_bndrs res_ty + pure ([], tc_res_ty, tc_res_kind) + go (PCGSAnonArg arg_ty body) = do + (tc_arg_tys, tc_res_ty, tc_res_kind) <- go body + -- See Note [Datatype return kinds] + let exp_kind = getArgExpKind new_or_data tc_res_kind + tc_arg_ty <- tcConArg exp_kind arg_ty + pure (tc_arg_ty:tc_arg_tys, tc_res_ty, tc_res_kind) + +tcConGadtResTy :: [LocatedN Name] + -> DataDeclInfo + -> [TcTyConBinder] + -> LHsType GhcRn -> TcM (TcType, TcKind) +tcConGadtResTy names dd_info tc_bndrs res_ty = do + -- See Note [GADT return kinds] + res@(tc_res_ty, _tc_res_kind) <- tcInferLHsTypeKind res_ty + + -- For data instances (only), ensure that the return type, + -- res_ty, is a substitution instance of the header. + -- See Note [GADT return types] + case dd_info of + DDataType -> return () + DDataInstance hdr_ty -> + do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs) + ; let head_shape = substTy subst hdr_ty + ; discardResult $ + popErrCtxt $ -- Drop dataConCtxt + addErrCtxt (dataConResCtxt names) $ + unifyType Nothing tc_res_ty head_shape } + + pure res tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, -- but might be an unlifted type with UnliftedNewtypes @@ -3712,15 +3768,22 @@ tcConArg exp_kind (HsScaled w bty) tcRecConDeclFields :: ContextKind -> LocatedL [LConDeclField GhcRn] -> TcM [(Scaled TcType, HsSrcBang)] -tcRecConDeclFields exp_kind fields - = mapM (tcConArg exp_kind) btys +tcRecConDeclFields exp_kind (L _ fields) + = concatMapM tc_field fields where - -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) - (unLoc fields) - explode (ns,ty) = zip ns (repeat ty) - exploded = concatMap explode combined - (_,btys) = unzip exploded + -- We need to ensure that each distinct field name gets its own type. + -- For example, if we have: + -- + -- data T = MkT { a,b,c :: Int } + -- + -- Then we should return /three/ Int types, not just one! At the same + -- time, we don't want to kind-check Int three separate times, as that + -- would be redundant. Therefore, we kind-check Int once and 'replicate' + -- it so that we return three occurrences of it. + tc_field :: LConDeclField GhcRn -> TcM [(Scaled TcType, HsSrcBang)] + tc_field (L _ f) = do + bty' <- tcConArg exp_kind $ hsLinear $ cd_fld_type f + pure $ replicate (length (cd_fld_names f)) bty' tcDataConMult :: HsArrow GhcRn -> TcM Mult tcDataConMult arr@(HsUnrestrictedArrow _) = do |