X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=bfecfd631fe71aa60edd37e99f780acf9eee9375;hp=5a071ee2e2112736121dbdfe55ae586c95a69ba1;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=685f631451c4e6d8ebb6e31decb935db675f338e diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 5a071ee..bfecfd6 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -16,22 +16,23 @@ import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn -import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) +import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields ) import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, lookupTopBndrRn, lookupLocatedTopBndrRn, - lookupOccRn, newLocalsRn, + lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalNames, checkDupRdrNames, mapFvRn, - checkM + bindLocalNames, checkDupRdrNames, mapFvRn ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) import HscTypes ( GenAvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad +import ForeignCall ( CCallTarget(..) ) +import Module import HscTypes ( Warnings(..), plusWarns ) import Class ( FunDep ) import Name ( Name, nameOccName ) @@ -40,15 +41,16 @@ import NameEnv import Outputable import Bag import FastString +import Util ( filterOut ) import SrcLoc -import DynFlags ( DynFlag(..) ) -import Maybe ( isNothing ) +import DynFlags ( DynFlag(..), DynFlags, thisPackage ) +import HscTypes ( HscEnv, hsc_dflags ) import BasicTypes ( Boxity(..) ) +import ListSetOps ( findDupsEq ) -import ListSetOps (findDupsEq) -import List import Control.Monad +import Data.Maybe \end{code} \begin{code} @@ -232,7 +234,7 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs %********************************************************* \begin{code} -rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name) +rnDocDecl :: DocDecl -> RnM DocDecl rnDocDecl (DocCommentNext doc) = do rn_doc <- rnHsDoc doc return (DocCommentNext rn_doc) @@ -301,9 +303,10 @@ rnSrcWarnDecls _bound_names [] rnSrcWarnDecls bound_names decls = do { -- check for duplicates - ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups - ; mapM (addLocM rn_deprec) decls `thenM` \ pairs_s -> - return (WarnSome ((concat pairs_s))) } + ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } where rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally @@ -369,9 +372,15 @@ rnDefaultDecl (DefaultDecl tys) \begin{code} rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty spec) - = lookupLocatedTopBndrRn name `thenM` \ name' -> + = getTopEnv `thenM` \ (topEnv :: HscEnv) -> + lookupLocatedTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - return (ForeignImport name' ty' spec, fvs) + + -- Mark any PackageTarget style imports as coming from the current package + let packageId = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport packageId spec + + in return (ForeignImport name' ty' spec', fvs) rnHsForeignDecl (ForeignExport name ty spec) = lookupLocatedOccRn name `thenM` \ name' -> @@ -383,6 +392,32 @@ rnHsForeignDecl (ForeignExport name ty spec) fo_decl_msg :: Located RdrName -> SDoc fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name + + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundry we'll still +-- know where they're from. +-- +patchForeignImport :: PackageId -> ForeignImport -> ForeignImport +patchForeignImport packageId (CImport cconv safety fs spec) + = CImport cconv safety fs (patchCImportSpec packageId spec) + +patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec +patchCImportSpec packageId spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget + _ -> spec + +patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget +patchCCallTarget packageId callTarget + = case callTarget of + StaticTarget label Nothing + -> StaticTarget label (Just packageId) + + _ -> callTarget + + \end{code} @@ -402,11 +437,10 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_doc = text "In the bindings in an instance declaration" meth_names = collectHsBindLocatedBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupRdrNames meth_doc meth_names `thenM_` + checkDupRdrNames meth_names `thenM_` -- Check that the same method is not given twice in the -- same instance decl instance C T where -- f x = ... @@ -426,10 +460,9 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the declarations are for the right class let - at_doc = text "In the associated types of an instance declaration" at_names = map (head . tyClDeclNames . unLoc) ats in - checkDupRdrNames at_doc at_names `thenM_` + checkDupRdrNames at_names `thenM_` -- See notes with checkDupRdrNames for methods, above rnATInsts ats `thenM` \ (ats', at_fvs) -> @@ -501,9 +534,16 @@ extendTyVarEnvForMethodBinds tyvars thing_inside \begin{code} rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) rnSrcDerivDecl (DerivDecl ty) - = do ty' <- rnLHsType (text "a deriving decl") ty - let fvs = extractHsTyNames ty' - return (DerivDecl ty', fvs) + = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving + ; unless standalone_deriv_ok (addErr standaloneDerivErr) + ; ty' <- rnLHsType (text "a deriving decl") ty + ; let fvs = extractHsTyNames ty' + ; return (DerivDecl ty', fvs) } + +standaloneDerivErr :: SDoc +standaloneDerivErr + = hang (ptext (sLit "Illegal standalone deriving declaration")) + 2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension")) \end{code} %********************************************************* @@ -516,7 +556,7 @@ rnSrcDerivDecl (DerivDecl ty) rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocatedLocalsFV doc (map get_var vars) $ \ ids -> + bindLocatedLocalsFV (map get_var vars) $ \ ids -> do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids) -- NB: The binders in a rule are always Ids -- We don't (yet) support type variables @@ -599,7 +639,6 @@ validRuleLhs foralls lhs check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 check_e (NegApp e _) = checkl_e e check_e (ExplicitList _ es) = checkl_es es - check_e (ExplicitTuple es _) = checkl_es es check_e other = Just other -- Fails checkl_es es = foldr (mplus . checkl_e) Nothing es @@ -636,9 +675,9 @@ However, we can also do some scoping checks at the same time. \begin{code} rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) -rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name}) +rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) = lookupLocatedTopBndrRn name `thenM` \ name' -> - return (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, + return (ForeignType {tcdLName = name', tcdExtName = ext_name}, emptyFVs) -- all flavours of type family declarations ("type family", "newtype fanily", @@ -647,71 +686,49 @@ rnTyClDecl (tydecl@TyFamily {}) = rnFamily tydecl bindTyVarsRn -- "data", "newtype", "data instance, and "newtype instance" declarations -rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, +rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, tcdTyPats = typatsMaybe, tcdCons = condecls, - tcdKindSig = sig, tcdDerivs = derivs}) - | is_vanilla -- Normal Haskell data type decl - = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the - -- data type is syntactically illegal - do { tyvars <- pruneTyVars tydecl - ; bindTyVarsRn data_doc tyvars $ \ tyvars' -> do - { tycon' <- if isFamInstDecl tydecl - then lookupLocatedOccRn tycon -- may be imported family - else lookupLocatedTopBndrRn tycon - ; context' <- rnContext data_doc context - ; typats' <- rnTyPats data_doc typatsMaybe - ; condecls' <- rnConDecls (unLoc tycon') condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - ; (derivs', deriv_fvs) <- rn_derivs derivs - ; return (TyData {tcdND = new_or_data, tcdCtxt = context', - tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = typats', tcdKindSig = Nothing, - tcdCons = condecls', tcdDerivs = derivs'}, - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context' `plusFV` - plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc tycon') -- type instance => use - else emptyFVs)) - } } - - | otherwise -- GADT + tcdKindSig = sig, tcdDerivs = derivs} = do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon - ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) - ; (tyvars', typats') - <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do + ; checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta tycon) + ; (tyvars', context', typats', derivs', deriv_fvs) + <- bindTyVarsRn tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars { typats' <- rnTyPats data_doc typatsMaybe - ; return (tyvars', typats') } + ; context' <- rnContext data_doc context + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; return (tyvars', context', typats', derivs', deriv_fvs) } -- For GADTs, the type variables in the declaration -- do not scope over the constructor signatures -- data T a where { T1 :: forall b. b-> b } - ; condecls' <- rnConDecls (unLoc tycon') condecls + -- For the constructor declarations, bring into scope the tyvars + -- bound by the header, but *only* in the H98 case + ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars' + | otherwise = [] + ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $ + rnConDecls condecls -- No need to check for duplicate constructor decls -- since that is done by RnNames.extendGlobalRdrEnvRn - ; (derivs', deriv_fvs) <- rn_derivs derivs - ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], + ; return (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, - plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs `plusFV` + con_fvs `plusFV` + deriv_fvs `plusFV` (if isFamInstDecl tydecl then unitFV (unLoc tycon') -- type instance => use else emptyFVs)) } where - is_vanilla = case condecls of -- Yuk - [] -> True + h98_style = case condecls of L _ (ConDecl { con_res = ResTyH98 }) : _ -> True - _ -> False - + _ -> False data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) rn_derivs Nothing = return (Nothing, emptyFVs) @@ -719,23 +736,23 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, return (Just ds', extractHsTyNames_s ds') -- "type" and "type instance" declarations -rnTyClDecl tydecl@(TySynonym {tcdLName = name, +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = do { tyvars <- pruneTyVars tydecl - ; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do - { name' <- if isFamInstDecl tydecl - then lookupLocatedOccRn name -- may be imported family - else lookupLocatedTopBndrRn name - ; typats' <- rnTyPats syn_doc typatsMaybe - ; (ty', fvs) <- rnHsTypeFVs syn_doc ty - ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars', - tcdTyPats = typats', tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') $ - fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc name') -- type instance => use - else emptyFVs)) - } } + = bindTyVarsRn tyvars $ \ tyvars' -> do + { -- Checks for distinct tyvars + name' <- if isFamInstDecl tydecl + then lookupLocatedOccRn name -- may be imported family + else lookupLocatedTopBndrRn name + ; typats' <- rnTyPats syn_doc typatsMaybe + ; (ty', fvs) <- rnHsTypeFVs syn_doc ty + ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdSynRhs = ty'}, + delFVs (map hsLTyVarName tyvars') $ + fvs `plusFV` + (if isFamInstDecl tydecl + then unitFV (unLoc name') -- type instance => use + else emptyFVs)) + } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -746,7 +763,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Tyvars scope over superclass context and method signatures ; (tyvars', context', fds', ats', ats_fvs, sigs') - <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do + <- bindTyVarsRn tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds ; (ats', ats_fvs) <- rnATs ats @@ -759,7 +777,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] - ; checkDupRdrNames sig_doc sig_rdr_names_w_locs + ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't @@ -781,7 +799,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope - ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs + ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } -- Haddock docs @@ -799,7 +817,6 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ats_fvs) } where cls_doc = text "In the declaration for class" <+> ppr cname - sig_doc = text "In the signatures for class" <+> ppr cname badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ @@ -815,76 +832,48 @@ badGadtStupidTheta _ %********************************************************* \begin{code} --- Remove any duplicate type variables in family instances may have non-linear --- left-hand sides. Complain if any, but the first occurence of a type --- variable has a user-supplied kind signature. --- -pruneTyVars :: TyClDecl RdrName -> RnM [LHsTyVarBndr RdrName] -pruneTyVars tydecl - | isFamInstDecl tydecl - = do { let pruned_tyvars = nubBy eqLTyVar tyvars - ; assertNoSigsInRepeats tyvars - ; return pruned_tyvars - } - | otherwise - = return tyvars - where - tyvars = tcdTyVars tydecl - - assertNoSigsInRepeats [] = return () - assertNoSigsInRepeats (tv:tvs) - = do { let offending_tvs = [ tv' | tv'@(L _ (KindedTyVar _ _)) <- tvs - , tv' `eqLTyVar` tv] - ; checkErr (null offending_tvs) $ - illegalKindSig (head offending_tvs) - ; assertNoSigsInRepeats tvs - } - - illegalKindSig tv - = hsep [ptext (sLit "Repeat variable occurrence may not have a"), - ptext (sLit "kind signature:"), quotes (ppr tv)] - - tv1 `eqLTyVar` tv2 = hsLTyVarLocName tv1 `eqLocated` hsLTyVarLocName tv2 - +rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name]) -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) --- -rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name]) rnTyPats _ Nothing = return Nothing rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats -rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] -rnConDecls _tycon condecls - = mapM (wrapLocM rnConDecl) condecls +rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) +rnConDecls condecls + = do { condecls' <- mapM (wrapLocM rnConDecl) condecls + ; return (condecls', plusFVs (map conDeclFVs condecls')) } rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) -rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) +rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs + , con_cxt = cxt, con_details = details + , con_res = res_ty, con_doc = mb_doc + , con_old_rec = old_rec, con_explicit = expl }) = do { addLocM checkConName name - + ; when old_rec (addWarn (deprecRecSyntax decl)) ; new_name <- lookupLocatedTopBndrRn name - ; name_env <- getLocalRdrEnv - - -- For H98 syntax, the tvs are the existential ones - -- For GADT syntax, the tvs are all the quantified tyvars - -- Hence the 'filter' in the ResTyH98 case only - ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc - arg_tys = hsConDeclArgTys details - implicit_tvs = case res_ty of - ResTyH98 -> filter not_in_scope $ - get_rdr_tvs arg_tys - ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) - tvs' = case expl of - Explicit -> tvs - Implicit -> userHsTyVarBndrs implicit_tvs - - ; mb_doc' <- rnMbLHsDoc mb_doc - - ; bindTyVarsRn doc tvs' $ \new_tyvars -> do + + -- For H98 syntax, the tvs are the existential ones + -- For GADT syntax, the tvs are all the quantified tyvars + -- Hence the 'filter' in the ResTyH98 case only + ; rdr_env <- getLocalRdrEnv + ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc + arg_tys = hsConDeclArgTys details + implicit_tvs = case res_ty of + ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys) + ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) + new_tvs = case expl of + Explicit -> tvs + Implicit -> userHsTyVarBndrs implicit_tvs + + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; bindTyVarsRn new_tvs $ \new_tyvars -> do { new_context <- rnContext doc cxt - ; new_details <- rnConDeclDetails doc details + ; new_details <- rnConDeclDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty - ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }} + ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context + , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} where doc = text "In the definition of data constructor" <+> quotes (ppr name) get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) @@ -895,15 +884,22 @@ rnConResult :: SDoc -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], ResType Name) rnConResult _ details ResTyH98 = return (details, ResTyH98) - -rnConResult doc details (ResTyGADT ty) = do - ty' <- rnHsSigType doc ty - let (arg_tys, res_ty) = splitHsFunType ty' - -- We can split it up, now the renamer has dealt with fixities - case details of - PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty) - RecCon _ -> return (details, ResTyGADT ty') - InfixCon {} -> panic "rnConResult" +rnConResult doc details (ResTyGADT ty) + = do { ty' <- rnLHsType doc ty + ; let (arg_tys, res_ty) = splitHsFunType ty' + -- We can finally split it up, + -- now the renamer has dealt with fixities + -- See Note [Sorting out the result type] in RdrHsSyn + + details' = case details of + RecCon {} -> details + PrefixCon {} -> PrefixCon arg_tys + InfixCon {} -> pprPanic "rnConResult" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn + + ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False }) + (addErr (badRecResTy doc)) + ; return (details', ResTyGADT res_ty) } rnConDeclDetails :: SDoc -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] @@ -918,18 +914,11 @@ rnConDeclDetails doc (InfixCon ty1 ty2) return (InfixCon new_ty1 new_ty2) rnConDeclDetails doc (RecCon fields) - = do { new_fields <- mapM (rnField doc) fields + = do { new_fields <- rnConDeclFields doc fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn ; return (RecCon new_fields) } -rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name) -rnField doc (ConDeclField name ty haddock_doc) - = lookupLocatedTopBndrRn name `thenM` \ new_name -> - rnLHsType doc ty `thenM` \ new_ty -> - rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> - return (ConDeclField new_name new_ty new_haddock_doc) - -- Rename family declarations -- -- * This function is parametrised by the routine handling the index @@ -937,7 +926,7 @@ rnField doc (ConDeclField name ty haddock_doc) -- are usage occurences for associated types. -- rnFamily :: TyClDecl RdrName - -> (SDoc -> [LHsTyVarBndr RdrName] -> + -> ([LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) -> RnM (TyClDecl Name, FreeVars)) -> RnM (TyClDecl Name, FreeVars) @@ -945,25 +934,14 @@ rnFamily :: TyClDecl RdrName rnFamily (tydecl@TyFamily {tcdFlavour = flavour, tcdLName = tycon, tcdTyVars = tyvars}) bindIdxVars = - do { checkM (isDataFlavour flavour -- for synonyms, - || not (null tyvars)) $ addErr needOneIdx -- no. of indexes >= 1 - ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { + do { bindIdxVars tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, emptyFVs) } } - where - isDataFlavour DataFamily = True - isDataFlavour _ = False rnFamily d _ = pprPanic "rnFamily" (ppr d) -family_doc :: Located RdrName -> SDoc -family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon) - -needOneIdx :: SDoc -needOneIdx = text "Type family declarations requires at least one type index" - -- Rename associated type declarations (in classes) -- -- * This can be family declarations and (default) type instances @@ -974,11 +952,11 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars rn_at (tydecl@TySynonym {}) = do - checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns + unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns rnTyClDecl tydecl rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" - lookupIdxVars _ tyvars cont = + lookupIdxVars tyvars cont = do { checkForDups tyvars; ; tyvars' <- mapM lookupIdxVar tyvars ; cont tyvars' @@ -1005,6 +983,16 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats | rdrName == hsTyVarName tv = True | otherwise = rdrName `ltvElem` ltvs +deprecRecSyntax :: ConDecl RdrName -> SDoc +deprecRecSyntax decl + = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl)) + <+> ptext (sLit "uses deprecated syntax") + , ptext (sLit "Instead, use the form") + , nest 2 (ppr decl) ] -- Pretty printer uses new form + +badRecResTy :: SDoc -> SDoc +badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc + noPatterns :: SDoc noPatterns = text "Default definition for an associated synonym cannot have" <+> text "type pattern"