X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=dbf83fb56a6689964692ffb80fdfdd8bdbada381;hb=ff8e1d01524b48e028b09e2b04b2e5303cb6d95f;hp=6788eee018ee58f40da5cb97e70ab21790ef0d4c;hpb=8406c69e81f9416bc4b93c4323bbd36b25655e65;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 6788eee..dbf83fb 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -252,7 +252,8 @@ tcFamInstDecl (L loc decl) tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error -tcFamInstDecl1 (decl@TySynonym {}) + -- "type instance" +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) $ @@ -266,10 +267,15 @@ tcFamInstDecl1 (decl@TySynonym {}) ; t_typats <- mappM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs - -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return Nothing -- !!!TODO: need TyThing for indexed synonym + -- (3) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) + ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (Just (family, t_typats)) + + ; return $ Just (ATyCon tycon) }} - + + -- "newtype instance" and "data instance" tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> @@ -300,10 +306,10 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt + -- (3) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon t_tvs)) + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) k_cons ; tc_rhs <- case new_or_data of @@ -588,12 +594,15 @@ tcSynDecls (decl : decls) ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) ; return (syn_tc : syn_tcs) } + -- "type" tcSynDecl (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing + ; return (ATyCon tycon) + } -------------------- tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] @@ -615,7 +624,8 @@ tcTyClDecl1 _calc_isrec -- Check that we don't use families without -findexed-types ; checkTc idx_tys $ badFamInstDecl tc_name - ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing)] + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; return [ATyCon tycon] } -- "newtype family" or "data family" declaration @@ -640,7 +650,7 @@ tcTyClDecl1 _calc_isrec ; return [ATyCon tycon] } - -- "newtype", "data", "newtype instance", "data instance" + -- "newtype" and "data" tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) @@ -672,8 +682,7 @@ tcTyClDecl1 calc_isrec (newtypeConError tc_name (length cons)) ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs)) + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon final_tvs)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -742,38 +751,11 @@ tcTyClDecl1 calc_isrec ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> NewOrData -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes - (ConDecl name _ tvs ex_ctxt details res_ty _) - = tcTyVarBndrs tvs $ \ tvs' -> do - do { (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty - - -- Check that a newtype has no existential stuff - ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) - - ; let tc_datacon field_lbls arg_ty - = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype - ; buildDataCon (unLoc name) False {- Prefix -} - [NotMarkedStrict] - (map unLoc field_lbls) - univ_tvs [] -- No existentials - [] [] -- No equalities, predicates - [arg_ty'] - data_tc } - - ; case details of - PrefixCon [arg_ty] -> tc_datacon [] arg_ty - RecCon [HsRecField field_lbl arg_ty _] -> tc_datacon [field_lbl] arg_ty - other -> - failWithTc (newtypeFieldErr name (length (hsConArgs details))) - -- Check that the constructor has exactly one field - } - -tcConDecl unbox_strict DataType tycon tc_tvs -- Data types +tcConDecl unbox_strict tycon tc_tvs -- Data types (ConDecl name _ tvs ctxt details res_ty _) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt @@ -989,23 +971,23 @@ checkValidTyCon tc -- NB: this check assumes that all the constructors of a given -- data type use the same type variables where - tvs1 = mkVarSet (dataConAllTyVars con1) - res1 = dataConResTys con1 + (tvs1, _, _, res1) = dataConSig con1 + ts1 = mkVarSet tvs1 fty1 = dataConFieldType con1 label checkOne (_, con2) -- Do it bothways to ensure they are structurally identical - = do { checkFieldCompat label con1 con2 tvs1 res1 res2 fty1 fty2 - ; checkFieldCompat label con2 con1 tvs2 res2 res1 fty2 fty1 } + = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2 + ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 } where - tvs2 = mkVarSet (dataConAllTyVars con2) - res2 = dataConResTys con2 + (tvs2, _, _, res2) = dataConSig con2 + ts2 = mkVarSet tvs2 fty2 = dataConFieldType con2 label checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } where - mb_subst1 = tcMatchTys tvs1 res1 res2 + mb_subst1 = tcMatchTy tvs1 res1 res2 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 ------------------------------- @@ -1014,11 +996,27 @@ checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) - ; checkValidType ctxt (dataConUserType con) } + ; checkValidType ctxt (dataConUserType con) + ; ifM (isNewTyCon tc) (checkNewDataCon con) + } where ctxt = ConArgCtxt (dataConName con) ------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Checks for the data constructor of a newtype +checkNewDataCon con + = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) + -- One argument + ; checkTc (null eq_spec) (newtypePredError con) + -- Return type is (T a b c) + ; checkTc (null ex_tvs && null theta) (newtypeExError con) + -- No existentials + } + where + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con + +------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls = do { -- CHECK ARITY 1 FOR HASKELL 1.4 @@ -1158,6 +1156,10 @@ newtypeExError con = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] +newtypePredError con + = sep [ptext SLIT("A newtype constructor must have a return type of form T a1 ... an"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does not")] + newtypeFieldErr con_name n_flds = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]