X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=d2f53dec1d4a9e415215f586f521f1d88e59e063;hb=21044c2db566270297baef26c0a8d9228e66af7c;hp=a300469ce820b01ad92443a075aa3ddd160a4186;hpb=491c85e7478f46d92166b938b4833504a28ff9d4;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index a300469..d2f53de 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -30,30 +30,33 @@ import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, kcHsSigType, tcHsBangType, tcLHsConResTy, tcDataKindSig ) -import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, +import TcMType ( newKindVar, checkValidTheta, checkValidType, + -- checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) import TcType ( TcKind, TcType, tyVarsOfType, mkPhiTy, mkArrowKind, liftedTypeKind, mkTyVarTys, tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe ) -import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType ) +import Type ( splitTyConApp_maybe, + -- pprParendType, pprThetaArrow + ) import Kind ( mkArrowKinds, splitKindFunTys ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ), tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, - tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName ) -import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, + tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName ) +import DataCon ( DataCon, dataConWrapId, dataConName, dataConFieldLabels, dataConTyCon, dataConTyVars, dataConFieldType, dataConResTys ) import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet, mkVarSet ) -import Name ( Name ) +import Name ( Name, getSrcLoc ) import Outputable import Maybe ( isJust, fromJust ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) import List ( partition ) -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) import ListSetOps ( equivClasses ) import List ( delete ) import Digraph ( SCC(..) ) @@ -400,6 +403,7 @@ tcTyClDecl1 calc_vrcs calc_isrec ; checkTc (not (null cons) || gla_exts || 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)) @@ -463,18 +467,21 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) - = ASSERT( null ex_tvs && null (unLoc ex_ctxt) ) - do { let tc_datacon field_lbls arg_ty + = do { let tc_datacon field_lbls arg_ty = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype ; buildDataCon (unLoc name) False {- Prefix -} True {- Vanilla -} [NotMarkedStrict] (map unLoc field_lbls) tc_tvs [] [arg_ty'] tycon (mkTyVarTys tc_tvs) } + + -- Check that a newtype has no existential stuff + ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) + ; case details of PrefixCon [arg_ty] -> tc_datacon [] arg_ty RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty - other -> failWithTc (newTypeFieldErr name (length (hsConArgs details))) + other -> failWithTc (newtypeFieldErr name (length (hsConArgs details))) -- Check that the constructor has exactly one field } @@ -613,10 +620,10 @@ checkValidTyCon tc mappM_ check_fields groups where - syn_ctxt = TySynCtxt name - name = tyConName tc - (_, syn_rhs) = getSynTyConDefn tc - data_cons = tyConDataCons tc + syn_ctxt = TySynCtxt name + name = tyConName tc + syn_rhs = synTyConRhs tc + data_cons = tyConDataCons tc groups = equivClasses cmp_fld (concatMap get_fields data_cons) cmp_fld (f1,_) (f2,_) = f1 `compare` f2 @@ -661,7 +668,8 @@ checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 ------------------------------- checkValidDataCon :: TyCon -> DataCon -> TcM () checkValidDataCon tc con - = addErrCtxt (dataConCtxt con) $ + = setSrcSpan (srcLocSpan (getSrcLoc con)) $ + addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) ; checkValidType ctxt (idType (dataConWrapId con)) } @@ -744,21 +752,7 @@ fieldTypeMisMatch field_name con1 con2 = sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2, ptext SLIT("give different types for field"), quotes (ppr field_name)] -dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"), - nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)] - where - (ex_tvs, ex_theta, arg_tys, _, _) = dataConSig con - ex_part | null ex_tvs = empty - | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot - -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote - -- data T a = Eq a => T a a - -- So we make sure to print it - - fields = dataConFieldLabels con - arg_part | null fields = sep (map pprParendType arg_tys) - | otherwise = braces (sep (punctuate comma - [ ppr n <+> dcolon <+> ppr ty - | (n,ty) <- fields `zip` arg_tys])) +dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con) classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"), nest 2 (ppr sel_id <+> dcolon <+> ppr tau)] @@ -815,10 +809,14 @@ badGadtDecl tc_name , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ] newtypeConError tycon n - = sep [ptext SLIT("A newtype must have exactly one constructor"), + = sep [ptext SLIT("A newtype must have exactly one constructor,"), nest 2 $ ptext SLIT("but") <+> quotes (ppr tycon) <+> ptext SLIT("has") <+> speakN n ] -newTypeFieldErr con_name n_flds +newtypeExError con + = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + +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]