X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=278ffe8b5d3f25e44d26e2f85ac4ed6fe89beb65;hb=d5c4754dcb857be7b9f4dbf6482e6050a9cd0991;hp=c2054e3962376a64244b2eff13c03d34a4828e9b;hpb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c2054e3..278ffe8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -17,7 +17,7 @@ import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), hsTyVarName, LHsTyVarBndr, LHsType, HsType(..), mkHsAppTy ) -import HsTypes ( HsBang(..), getBangStrictness ) +import HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings, ModDetails ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, @@ -51,7 +51,8 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon, tyConKind ) + isNewTyCon, isDataTyCon, tyConKind, + setTyConArgPoss ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) @@ -59,14 +60,14 @@ import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet, mkVarSet ) import Name ( Name, getSrcLoc ) import Outputable -import Maybe ( isJust, fromJust, isNothing ) +import Maybe ( isJust, fromJust, isNothing, catMaybes ) import Maybes ( expectJust ) +import Monad ( unless ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) -import List ( partition ) +import List ( partition, elemIndex ) import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) import ListSetOps ( equivClasses, minusList ) -import List ( delete ) import Digraph ( SCC(..) ) import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) @@ -270,8 +271,12 @@ tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind _ -> - do { -- (1) kind check the right hand side of the type equation + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for a synonym + unless (isSynTyCon family) $ + addErr (wrongKindOfFamily family) + + ; -- (1) kind check the right hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind -- (2) type check type equation @@ -287,7 +292,12 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> - do { -- (1) kind check the data declaration as usual + do { -- check that the family declaration is for the right kind + unless (new_or_data == NewType && isNewTyCon family || + new_or_data == DataType && isDataTyCon family) $ + addErr (wrongKindOfFamily family) + + ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs ; let k_ctxt = tcdCtxt k_decl k_cons = tcdCons k_decl @@ -306,13 +316,12 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; checkTc (new_or_data == DataType || isSingleton k_cons) $ newtypeConError tc_name (length k_cons) - ; final_tvs <- tcDataKindSig (Just $ tyConKind family) ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs (Just t_typats))) + tycon t_tvs)) k_cons ; tc_rhs <- case new_or_data of @@ -321,7 +330,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ASSERT( isSingleton data_cons ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax (Just family) + False h98_syntax (Just (family, t_typats)) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive @@ -330,7 +339,6 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, }) -- construct result - -- !!!TODO: missing eq axiom ; return (Nothing, Just (ATyCon tycon)) }} where @@ -616,20 +624,22 @@ tcTyClDecl calc_isrec decl tcTyClDecl1 _calc_isrec (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) = tcTyVarBndrs tvs $ \ tvs' -> do - { gla_exts <- doptM Opt_GlasgowExts + { traceTc (text "type family: " <+> ppr tc_name) + ; gla_exts <- doptM Opt_GlasgowExts -- Check that we don't use kind signatures without Glasgow extensions ; checkTc gla_exts $ badSigTyDecl tc_name - ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))] + ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)] } -- kind signature for an indexed data type tcTyClDecl1 _calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []}) + tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []}) = tcTyVarBndrs tvs $ \ tvs' -> do - { extra_tvs <- tcDataKindSig mb_ksig + { traceTc (text "data/newtype family: " <+> ppr tc_name) + ; extra_tvs <- tcDataKindSig (Just ksig) ; let final_tvs = tvs' ++ extra_tvs -- we may not need these ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name @@ -678,7 +688,7 @@ tcTyClDecl1 calc_isrec ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs Nothing)) + tycon final_tvs)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -707,7 +717,7 @@ tcTyClDecl1 calc_isrec { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats - ; let ats' = concat atss + ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -727,6 +737,17 @@ tcTyClDecl1 calc_isrec ; tvs2' <- mappM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } + setTyThingPoss [ATyCon tycon] atTyVars = + let classTyVars = hsLTyVarNames tvs + poss = catMaybes + . map (`elemIndex` classTyVars) + . hsLTyVarNames + $ atTyVars + -- There will be no Nothing, as we already passed renaming + in + ATyCon (setTyConArgPoss tycon poss) + setTyThingPoss _ _ = panic "setTyThingPoss" + tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) @@ -736,11 +757,10 @@ tcTyClDecl1 calc_isrec tcConDecl :: Bool -- True <=> -funbox-strict_fields -> NewOrData -> TyCon -> [TyVar] - -> Maybe [Type] -- Just ts <=> type patterns of instance type -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict NewType tycon tc_tvs mb_typats -- Newtypes +tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) = do { let tc_datacon field_lbls arg_ty = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype @@ -750,8 +770,7 @@ tcConDecl unbox_strict NewType tycon tc_tvs mb_typats -- Newtypes tc_tvs [] -- No existentials [] [] -- No equalities, predicates [arg_ty'] - tycon - mb_typats} + tycon } -- Check that a newtype has no existential stuff ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) @@ -764,7 +783,7 @@ tcConDecl unbox_strict NewType tycon tc_tvs mb_typats -- Newtypes -- Check that the constructor has exactly one field } -tcConDecl unbox_strict DataType tycon tc_tvs mb_typats -- Data types +tcConDecl unbox_strict DataType tycon tc_tvs -- Data types (ConDecl name _ tvs ctxt details res_ty) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt @@ -777,8 +796,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs mb_typats -- Data types (argStrictness unbox_strict tycon bangs arg_tys) (map unLoc field_lbls) univ_tvs ex_tvs eq_preds ctxt' arg_tys - data_tc - mb_typats} + data_tc } -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. @@ -1156,7 +1174,16 @@ tooFewParmsErr tc_name = ptext SLIT("Indexed type instance has too few parameters:") <+> quotes (ppr tc_name) -badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file") +badBootTyIdxDeclErr = + ptext SLIT("Illegal indexed type instance in hs-boot file") + +wrongKindOfFamily family = + ptext SLIT("Wrong category of type instance; declaration was for a") <+> + kindOfFamily + where + kindOfFamily | isSynTyCon family = ptext SLIT("type synonym") + | isDataTyCon family = ptext SLIT("data type") + | isNewTyCon family = ptext SLIT("newtype") emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),