X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=191e546eeb01b14d01ac5bb74299e16ed0a07bd9;hb=68f606a04198beb15b577ebc951d34a313710cdc;hp=76b9a9ee40e41a92538b31b5f5d556f04bca0348;hpb=a1632b0af860d28589b444d8e28896bee8bced38;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 76b9a9e..191e546 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -133,7 +133,7 @@ tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons tcTyAndClassDecls boot_details allDecls - = do { -- Omit instances of indexed types; they are handled together + = do { -- Omit instances of type families; they are handled together -- with the *heads* of class instances ; let decls = filter (not . isFamInstDecl . unLoc) allDecls @@ -239,9 +239,9 @@ tcFamInstDecl (L loc decl) recoverM (returnM Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- type families require -findexed-types and can't be in an + do { -- type families require -ftype-families and can't be in an -- hs-boot file - ; gla_exts <- doptM Opt_IndexedTypes + ; gla_exts <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc gla_exts $ badFamInstDecl (tcdLName decl) ; checkTc (not is_boot) $ badBootFamInstDeclErr @@ -268,7 +268,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; t_rhs <- tcHsKindedType k_rhs -- (3) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) + ; rep_tc_name <- newFamInstTyConName tc_name loc ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) (Just (family, t_typats)) @@ -280,8 +280,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for the right kind - unless (new_or_data == NewType && isNewTyCon family || - new_or_data == DataType && isDataTyCon family) $ + unless (isAlgTyCon family) $ addErr (wrongKindOfFamily family) ; -- (1) kind check the data declaration as usual @@ -307,7 +306,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; stupid_theta <- tcHsKindedContext k_ctxt -- (3) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) + ; rep_tc_name <- newFamInstTyConName tc_name loc ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) k_cons @@ -315,7 +314,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( isSingleton data_cons ) - mkNewTyConRhs tc_name tycon (head data_cons) + mkNewTyConRhs rep_tc_name tycon (head data_cons) ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive False h98_syntax (Just (family, t_typats)) -- We always assume that indexed types are recursive. Why? @@ -393,7 +392,7 @@ So we must infer their kinds from their right-hand sides *first* and then use them, whereas for the mutually recursive data types D we bring into scope kind bindings D -> k, where k is a kind variable, and do inference. -Indexed Types +Type families ~~~~~~~~~~~~~ This treatment of type synonyms only applies to Haskell 98-style synonyms. General type functions can be recursive, and hence, appear in `alg_decls'. @@ -569,7 +568,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) kc_con_details (RecCon fields) = do { fields' <- mappM kc_field fields; return (RecCon fields') } - kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) } + kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty + ; return (ConDeclField fld bty' d) } kc_larg_ty bty = case new_or_data of DataType -> kcHsSigType bty @@ -619,9 +619,9 @@ tcTyClDecl1 _calc_isrec -- kind checking = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "type family: " <+> ppr tc_name) - ; idx_tys <- doptM Opt_IndexedTypes + ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -findexed-types + -- Check that we don't use families without -ftype-families ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing @@ -630,23 +630,20 @@ tcTyClDecl1 _calc_isrec -- "newtype family" or "data family" declaration tcTyClDecl1 _calc_isrec - (TyFamily {tcdFlavour = DataFamily new_or_data, + (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc (text "data/newtype family: " <+> ppr tc_name) + { traceTc (text "data family: " <+> ppr tc_name) ; extra_tvs <- tcDataKindSig mb_kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; idx_tys <- doptM Opt_IndexedTypes + ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -findexed-types + -- Check that we don't use families without -ftype-families ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] - (case new_or_data of - DataType -> mkOpenDataTyConRhs - NewType -> mkOpenNewTyConRhs) - Recursive False True Nothing + mkOpenDataTyConRhs Recursive False True Nothing ; return [ATyCon tycon] } @@ -661,10 +658,11 @@ tcTyClDecl1 calc_isrec ; want_generic <- doptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields ; gla_exts <- doptM Opt_GlasgowExts + ; gadt_ok <- doptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? -- Check that we don't use GADT syntax in H98 world - ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) + ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) -- Check that we don't use kind signatures without Glasgow extensions ; checkTc (gla_exts || isNothing mb_ksig) (badSigTyDecl tc_name) @@ -779,8 +777,8 @@ tcConDecl unbox_strict tycon tc_tvs -- Data types InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] RecCon fields -> tc_datacon False field_names btys where - (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] - + field_names = map cd_fld_name fields + btys = map cd_fld_type fields } tcResultType :: TyCon @@ -1012,6 +1010,9 @@ checkNewDataCon con -- Return type is (T a b c) ; checkTc (null ex_tvs && null theta) (newtypeExError con) -- No existentials + ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) + (newtypeStrictError con) + -- No strictness } where (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con @@ -1143,7 +1144,7 @@ badDataConTyCon data_con badGadtDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ] + , nest 2 (parens $ ptext SLIT("Use -X=GADT to allow GADTs")) ] badStupidTheta tc_name = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) @@ -1156,6 +1157,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")] +newtypeStrictError con + = sep [ptext SLIT("A newtype constructor cannot have a strictness annotation,"), + 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")] @@ -1172,7 +1177,7 @@ badSigTyDecl tc_name badFamInstDecl tc_name = vcat [ ptext SLIT("Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed type families")) ] + , nest 2 (parens $ ptext SLIT("Use -X=TypeFamilies to allow indexed type families")) ] badGadtIdxTyDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> @@ -1194,9 +1199,8 @@ wrongKindOfFamily family = ptext SLIT("Wrong category of family 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") + kindOfFamily | isSynTyCon family = ptext SLIT("type synonym") + | isAlgTyCon family = ptext SLIT("data type") | otherwise = pprPanic "wrongKindOfFamily" (ppr family) emptyConDeclsErr tycon