X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=12fb28d7aecd70ca0dfdde36cf238fc24aa6d173;hp=f4d0e86f7c75cea38837ce7cc68142dcc7e252b3;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hpb=ad94d40948668032189ad22a0ad741ac1f645f50 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f4d0e86..12fb28d 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -10,7 +10,7 @@ TcTyClsDecls: Typecheck type and class declarations -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module TcTyClsDecls ( @@ -51,6 +51,7 @@ import SrcLoc import ListSetOps import Digraph import DynFlags +import FastString import Data.List import Control.Monad ( mplus ) @@ -140,8 +141,12 @@ indeed type families). I think. tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons +-- Fails if there are any errors + tcTyAndClassDecls boot_details allDecls - = do { -- Omit instances of type families; they are handled together + = checkNoErrs $ -- The code recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + do { -- Omit instances of type families; they are handled together -- with the *heads* of class instances ; let decls = filter (not . isFamInstDecl . unLoc) allDecls @@ -182,7 +187,7 @@ tcTyAndClassDecls boot_details allDecls ; tcExtendGlobalEnv syn_tycons $ do -- Type-check the data types and classes - { alg_tyclss <- mappM tc_decl kc_alg_decls + { alg_tyclss <- mapM tc_decl kc_alg_decls ; return (syn_tycons, concat alg_tyclss) }}}) -- Finished with knot-tying now @@ -191,7 +196,7 @@ tcTyAndClassDecls boot_details allDecls -- Perform the validity check { traceTc (text "ready for validity check") - ; mappM_ (addLocM checkValidTyCl) decls + ; mapM_ (addLocM checkValidTyCl) decls ; traceTc (text "done") -- Add the implicit things; @@ -244,10 +249,10 @@ GADTs). tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM Nothing) $ + recoverM (return Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- type families require -ftype-families and can't be in an + do { -- type families require -XTypeFamilies and can't be in an -- hs-boot file ; type_families <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? @@ -278,7 +283,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) -- (2) type check type equation ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; t_typats <- mappM tcHsKindedType k_typats + ; t_typats <- mapM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs -- (3) check that @@ -314,14 +319,14 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; unbox_strict <- doptM Opt_UnboxStrictFields -- kind check the type indexes and the context - ; t_typats <- mappM tcHsKindedType k_typats + ; t_typats <- mapM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt -- (3) Check that -- - left-hand side contains no type family applications -- (vanilla synonyms are fine, though, and we checked for -- foralls earlier) - ; mappM_ checkTyFamFreeness t_typats + ; mapM_ checkTyFamFreeness t_typats -- - we don't use GADT syntax for indexed types ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) @@ -332,8 +337,9 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name loc + ; let ex_ok = True -- Existentials ok for type families! ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) + { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon t_tvs)) k_cons ; tc_rhs <- case new_or_data of @@ -382,7 +388,7 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- TcRnMonad.zipWithM kcCheckHsType hs_typats kinds + ; typats <- zipWithM kcCheckHsType hs_typats kinds ; thing_inside tvs typats resultKind family } where @@ -434,7 +440,7 @@ kcTyClDecls syn_decls alg_decls = do { -- First extend the kind env with each data type, class, and -- indexed type, mapping them to a type variable let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls] - ; alg_kinds <- mappM getInitialKind initialKindDecls + ; alg_kinds <- mapM getInitialKind initialKindDecls ; tcExtendKindEnv alg_kinds $ do -- Now kind-check the type synonyms, in dependency order @@ -450,7 +456,7 @@ kcTyClDecls syn_decls alg_decls -- returning kind-annotated decls; we don't kind-check -- instances of indexed types yet, but leave this to -- `tcInstDecls1' - { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) + { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) (filter (not . isFamInstDecl . unLoc) alg_decls) ; return (kc_syn_decls, kc_alg_decls) }}} @@ -531,8 +537,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> do { is_boot <- tcIsHsBoot ; ctxt' <- kcHsContext ctxt - ; ats' <- mappM (wrapLocM (kcFamilyDecl tvs')) ats - ; sigs' <- mappM (wrapLocM kc_sig) sigs + ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats + ; sigs' <- mapM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', tcdATs = ats'}) } where @@ -570,7 +576,7 @@ kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name) kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) tvs = do { ctxt' <- kcHsContext ctxt - ; cons' <- mappM (wrapLocM kc_con_decl) cons + ; cons' <- mapM (wrapLocM kc_con_decl) cons ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where -- doc comments are typechecked to Nothing here @@ -584,14 +590,14 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) kc_con_details (PrefixCon btys) - = do { btys' <- mappM kc_larg_ty btys + = do { btys' <- mapM kc_larg_ty btys ; return (PrefixCon btys') } kc_con_details (InfixCon bty1 bty2) = do { bty1' <- kc_larg_ty bty1 ; bty2' <- kc_larg_ty bty2 ; return (InfixCon bty1' bty2') } kc_con_details (RecCon fields) - = do { fields' <- mappM kc_field fields + = do { fields' <- mapM kc_field fields ; return (RecCon fields') } kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty @@ -666,14 +672,14 @@ tcTyClDecl1 _calc_isrec { traceTc (text "type family: " <+> ppr tc_name) ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -ftype-families + -- Check that we don't use families without -XTypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing ; return [ATyCon tycon] } - -- "newtype family" or "data family" declaration + -- "data family" declaration tcTyClDecl1 _calc_isrec (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) @@ -684,7 +690,7 @@ tcTyClDecl1 _calc_isrec ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -ftype-families + -- Check that we don't use families without -XTypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] @@ -693,6 +699,7 @@ tcTyClDecl1 _calc_isrec } -- "newtype" and "data" + -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) @@ -704,8 +711,10 @@ tcTyClDecl1 calc_isrec ; unbox_strict <- doptM Opt_UnboxStrictFields ; empty_data_decls <- doptM Opt_EmptyDataDecls ; kind_signatures <- doptM Opt_KindSignatures + ; existential_ok <- doptM Opt_ExistentialQuantification ; gadt_ok <- doptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context -- Check that we don't use GADT syntax in H98 world ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) @@ -716,17 +725,19 @@ tcTyClDecl1 calc_isrec -- Check that the stupid theta is empty for a GADT-style declaration ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + -- Check that there's at least one condecl, -- or else we're reading an hs-boot file, or -XEmptyDataDecls ; checkTc (not (null cons) || empty_data_decls || is_boot) (emptyConDeclsErr tc_name) - -- Check that a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon final_tvs)) + { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon final_tvs)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -753,8 +764,10 @@ tcTyClDecl1 calc_isrec tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt - ; fds' <- mappM (addLocM tc_fundep) fundeps - ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats + ; fds' <- mapM (addLocM tc_fundep) fundeps + ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats + -- NB: 'ats' only contains "type family" and "data family" + -- declarations as well as type family defaults ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> @@ -764,15 +777,16 @@ tcTyClDecl1 calc_isrec tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name in - buildClass class_name tvs' ctxt' fds' ats' + buildClass False {- Must include unfoldings for selectors -} + class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) ; return (AClass clas : ats') -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } where - tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; - ; tvs2' <- mappM tcLookupTyVar tvs2 ; + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ; + ; tvs2' <- mapM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } -- For each AT argument compute the position of the corresponding class @@ -791,24 +805,28 @@ tcTyClDecl1 calc_isrec tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] + = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields + -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict tycon tc_tvs -- Data types +tcConDecl unbox_strict existential_ok tycon tc_tvs -- Data types (ConDecl name _ tvs ctxt details res_ty _) - = tcTyVarBndrs tvs $ \ tvs' -> do + = addErrCtxt (dataConCtxt name) $ + tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt + ; checkTc (existential_ok || (null tvs && null (unLoc ctxt))) + (badExistential name) ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty ; let -- Tiresome: tidy the tyvar binders, since tc_tvs and tvs' may have the same OccNames tc_datacon is_infix field_lbls btys = do { let bangs = map getBangStrictness btys - ; arg_tys <- mappM tcHsBangType btys + ; arg_tys <- mapM tcHsBangType btys ; buildDataCon (unLoc name) is_infix (argStrictness unbox_strict bangs arg_tys) (map unLoc field_lbls) @@ -940,7 +958,7 @@ checkCycleErrs tyclss | null cls_cycles = return () | otherwise - = do { mappM_ recClsErr cls_cycles + = do { mapM_ recClsErr cls_cycles ; failM } -- Give up now, because later checkValidTyCl -- will loop if the synonym is recursive where @@ -974,14 +992,14 @@ checkValidTyCon tc OpenSynTyCon _ _ -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise - = -- Check the context on the data decl - checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` + = do -- Check the context on the data decl + checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) -- Check arg types of data constructors - mappM_ (checkValidDataCon tc) data_cons `thenM_` + mapM_ (checkValidDataCon tc) data_cons -- Check that fields with the same name share a type - mappM_ check_fields groups + mapM_ check_fields groups where syn_ctxt = TySynCtxt name @@ -1041,7 +1059,10 @@ checkValidDataCon tc con addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) ; checkValidType ctxt (dataConUserType con) - ; ifM (isNewTyCon tc) (checkNewDataCon con) + ; checkValidMonoType (dataConOrigResTy con) + -- Disallow MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; when (isNewTyCon tc) (checkNewDataCon con) } where ctxt = ConArgCtxt (dataConName con) @@ -1079,7 +1100,7 @@ checkValidClass cls ; checkValidTheta (ClassSCCtxt (className cls)) theta -- Check the class operations - ; mappM_ (check_op constrained_class_methods) op_stuff + ; mapM_ (check_op constrained_class_methods) op_stuff -- Check that if the class has generic methods, then the -- class has only one parameter. We can't do generic @@ -1199,6 +1220,11 @@ badGadtDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) , nest 2 (parens $ ptext SLIT("Use -XGADTs to allow GADTs")) ] +badExistential con_name + = hang (ptext SLIT("Data constructor") <+> quotes (ppr con_name) <+> + ptext SLIT("has existential type variables, or a context")) + 2 (parens $ ptext SLIT("Use -XExistentialQuantification or -XGADTs to allow this")) + badStupidTheta tc_name = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)