X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=71e8659b15d906080ab8f97897dfd9fc947f42c5;hp=9bfba3f0ff42da9e77050a89621667e65c6da20d;hb=9a4ef343a46e823bcf949af8501c13cc8ca98fb1;hpb=bf7f8200224b99c770f81d85f728db41b2d024bc diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 9bfba3f..71e8659 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -25,7 +25,6 @@ import TcHsType import TcMType import TcType import TysWiredIn ( unitTy ) -import FunDeps import Type import Generics import Class @@ -272,11 +271,12 @@ tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for a synonym - unless (isSynTyCon family) $ - addErr (wrongKindOfFamily family) + checkTc (isOpenTyCon family) (notFamily family) + ; checkTc (isSynTyCon family) (wrongKindOfFamily family) ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better -- we need the exact same number of type parameters as the family -- declaration @@ -303,8 +303,8 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> do { -- check that the family declaration is for the right kind - unless (isAlgTyCon fam_tycon) $ - addErr (wrongKindOfFamily fam_tycon) + checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon) + ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs @@ -328,6 +328,10 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- foralls earlier) ; mapM_ checkTyFamFreeness t_typats + -- Check that we don't use GADT syntax in H98 world + ; gadt_ok <- doptM Opt_GADTs + ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name) + -- (b) a newtype has exactly one constructor ; checkTc (new_or_data == DataType || isSingleton k_cons) $ newtypeConError tc_name (length k_cons) @@ -375,7 +379,8 @@ kcIdxTyPats :: TyClDecl Name -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl) + do { let tc_name = tcdLName decl + ; fam_tycon <- tcLookupLocatedTyCon tc_name ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) ; hs_typats = fromJust $ tcdTyPats decl } @@ -385,10 +390,11 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckHsType hs_typats kinds + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) + | (kind,n) <- kinds `zip` [1..]] ; thing_inside tvs typats resultKind fam_tycon } - where \end{code} @@ -508,7 +514,7 @@ kcSynDecl (AcyclicSCC (L loc decl)) kcHsTyVars (tcdTyVars decl) (\ k_tvs -> do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) <+> brackets (ppr k_tvs)) - ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl) + ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), @@ -584,14 +590,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where -- doc comments are typechecked to Nothing here - kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do - kcHsTyVars ex_tvs $ \ex_tvs' -> do - ex_ctxt' <- kcHsContext ex_ctxt - details' <- kc_con_details details - res' <- case res of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) + kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) + = addErrCtxt (dataConCtxt name) $ + kcHsTyVars ex_tvs $ \ex_tvs' -> do + do { ex_ctxt' <- kcHsContext ex_ctxt + ; details' <- kc_con_details details + ; res' <- case res of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } + ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) } kc_con_details (PrefixCon btys) = do { btys' <- mapM kc_larg_ty btys @@ -769,9 +776,7 @@ tcTyClDecl1 calc_isrec } where is_rec = calc_isrec tc_name - h98_syntax = case cons of -- All constructors have same shape - L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - _ -> True + h98_syntax = consUseH98Syntax cons tcTyClDecl1 calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, @@ -918,6 +923,11 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) name = tyVarName tv (env', occ') = tidyOccName env (getOccName name) +consUseH98Syntax :: [LConDecl a] -> Bool +consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False +consUseH98Syntax _ = True + -- All constructors have same shape + ------------------- tcConArg :: Bool -- True <=> -funbox-strict_fields -> LHsType Name @@ -1088,7 +1098,8 @@ checkValidDataCon :: TyCon -> DataCon -> TcM () checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ - do { let tc_tvs = tyConTyVars tc + do { traceTc (ptext (sLit "Validity of data con") <+> ppr con) + ; let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) actual_res_ty = dataConOrigResTy con ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) @@ -1164,7 +1175,7 @@ checkValidClass cls -- class Error e => Game b mv e | b -> mv e where -- newBoard :: MonadState b m => m () -- Here, MonadState has a fundep m->b, so newBoard is fine - ; let grown_tyvars = grow theta (mkVarSet tyvars) + ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars) ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) @@ -1197,6 +1208,9 @@ checkValidClass cls \begin{code} mkAuxBinds :: [TyThing] -> HsValBinds Name +-- NB We produce *un-typechecked* bindings, rather like 'deriving' +-- This makes life easier, because the later type checking will add +-- all necessary type abstractions and applications mkAuxBinds ty_things = ValBindsOut [(NonRecursive, b) | b <- binds] sigs where @@ -1205,47 +1219,44 @@ mkAuxBinds ty_things | ATyCon tc <- ty_things , fld <- tyConFields tc ] - mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) mkRecSelBind (tycon, sel_name) = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) where - loc = getSrcSpan tycon - sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo + loc = getSrcSpan tycon + sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } -- Find a representative constructor, con1 - all_cons = tyConDataCons tycon + all_cons = tyConDataCons tycon cons_w_field = [ con | con <- all_cons , sel_name `elem` dataConFieldLabels con ] con1 = ASSERT( not (null cons_w_field) ) head cons_w_field -- Selector type; Note [Polymorphic selectors] - field_ty = dataConFieldType con1 sel_name - (field_tvs, field_theta, field_tau) - | is_naughty = ([], [], unitTy) - | otherwise = tcSplitSigmaTy field_ty + field_ty = dataConFieldType con1 sel_name data_ty = dataConOrigResTy con1 data_tvs = tyVarsOfType data_ty is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) - sel_ty = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ - mkPhiTy (dataConStupidTheta con1) $ -- Urgh! - mkPhiTy field_theta $ -- Urgh! - mkFunTy data_ty field_tau + (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty + sel_ty | is_naughty = unitTy + | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ + mkPhiTy (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy field_theta $ -- Urgh! + mkFunTy data_ty field_tau -- Make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) + sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs] + | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] - (L loc match_body) + (L loc (HsVar field_var)) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = HsRecField { hsRecFieldId = sel_lname , hsRecFieldArg = nlVarPat field_var , hsRecPun = False } - match_body | is_naughty = ExplicitTuple [] Boxed - | otherwise = HsVar field_var sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc @@ -1256,6 +1267,8 @@ mkRecSelBind (tycon, sel_name) | otherwise = [mkSimpleMatch [nlWildPat] (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID)) (nlHsLit msg_lit))] + + unit_rhs = L loc $ ExplicitTuple [] Boxed msg_lit = HsStringPrim $ mkFastString $ occNameString (getOccName sel_name) @@ -1292,8 +1305,11 @@ Hence the sel_naughty flag, to identify record selectors that don't really exist In general, a field is naughty if its type mentions a type variable that isn't in the result type of the constructor. -We make a dummy binding for naughty selectors, so that they can be treated -uniformly, apart from their sel_naughty field. The function is never called. +We make a dummy binding + sel = () +for naughty selectors, so that the later type-check will add them to the +environment, and they'll be exported. The function is never called, because +the tyepchecker spots the sel_naughty field. Note [GADT record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1506,13 +1522,18 @@ wrongNumberOfParmsErr exp_arity <+> ppr exp_arity badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr = - ptext (sLit "Illegal family instance in hs-boot file") - +badBootFamInstDeclErr + = ptext (sLit "Illegal family instance in hs-boot file") + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family = - ptext (sLit "Wrong category of family instance; declaration was for a") <+> - kindOfFamily +wrongKindOfFamily family + = ptext (sLit "Wrong category of family instance; declaration was for a") + <+> kindOfFamily where kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") | isAlgTyCon family = ptext (sLit "data type")