X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=d2bae387f905f91c22f9f0e194a20094eb79a267;hb=7299e42cc5214458ba16034dbfbf58de55f7121b;hp=c86b626495dd9913deaab43730cc46259bfecc30;hpb=432b38b66700d243369df5b76e5c5c01b5e197ff;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index c86b626..d2bae38 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -43,12 +43,13 @@ import OccName import Outputable import Bag import FastString -import SrcLoc ( Located(..), unLoc, noLoc ) +import SrcLoc import DynFlags ( DynFlag(..) ) import Maybe ( isNothing ) import BasicTypes ( Boxity(..) ) import ListSetOps (findDupsEq) +import List import Control.Monad \end{code} @@ -93,13 +94,8 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} -- Brings the binders of the group into scope in the appropriate places; -- does NOT assume that anything is in scope already --- --- The Bool determines whether (True) names in the group shadow existing --- Unquals in the global environment (used in Template Haskell) or --- (False) whether duplicates are reported as an error -rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) - -rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) +rnSrcDecls group@(HsGroup {hs_valds = val_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_derivds = deriv_decls, @@ -118,7 +114,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- (B) Bring top level binders (and their fixities) into scope, -- *except* for the value bindings, which get brought in below. avails <- getLocalNonValBinders group ; - tc_envs <- extendGlobalRdrEnvRn shadowP avails local_fix_env ; + tc_envs <- extendGlobalRdrEnvRn avails local_fix_env ; setEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -138,7 +134,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, let { lhs_binders = map unLoc $ collectHsValBinders new_lhs; lhs_avails = map Avail lhs_binders } ; - (tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_avails local_fix_env ; + (tcg_env, tcl_env) <- extendGlobalRdrEnvRn lhs_avails local_fix_env ; setEnvs (tcg_env, tcl_env) $ do { -- Now everything is in scope, as the remaining renaming assumes. @@ -174,7 +170,9 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- (H) Rename Everything else (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; - (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ; + (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $ + rnList rnHsRuleDecl rule_decls ; + -- Inside RULES, scoped type variables are on (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; @@ -500,17 +498,18 @@ 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 -> - mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) -> + 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 - rnLExpr lhs `thenM` \ (lhs', fv_lhs') -> - rnLExpr rhs `thenM` \ (rhs', fv_rhs') -> + ; (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs - checkValidRule rule_name ids lhs' fv_lhs' `thenM_` + ; checkValidRule rule_name ids lhs' fv_lhs' - returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') + ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') } where doc = text "In the transformation rule" <+> ftext rule_name @@ -637,8 +636,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, | is_vanilla -- Normal Haskell data type decl = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the -- data type is syntactically illegal - bindTyVarsRn data_doc tyvars $ \ tyvars' -> - do { tycon' <- if isFamInstDecl tydecl + 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 @@ -658,26 +658,29 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, (if isFamInstDecl tydecl then unitFV (unLoc tycon') -- type instance => use else emptyFVs)) - } + } } | otherwise -- GADT - = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now - do { tycon' <- if isFamInstDecl tydecl + = do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) - ; tyvars' <- bindTyVarsRn data_doc tyvars - (\ tyvars' -> return tyvars') + ; (tyvars', typats') + <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do + { typats' <- rnTyPats data_doc typatsMaybe + ; return (tyvars', typats') } -- For GADTs, the type variables in the declaration -- do not scope over the constructor signatures -- data T a where { T1 :: forall b. b-> b } + ; (derivs', deriv_fvs) <- rn_derivs derivs ; condecls' <- rnConDecls (unLoc tycon') condecls -- No need to check for duplicate constructor decls -- since that is done by RnNames.extendGlobalRdrEnvRn + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = Nothing, tcdKindSig = sig, + tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs `plusFV` @@ -691,10 +694,6 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, L _ (ConDecl { con_res = ResTyH98 }) : _ -> True _ -> False - none Nothing = True - none (Just []) = True - none _ = False - data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) rn_derivs Nothing = returnM (Nothing, emptyFVs) @@ -702,10 +701,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, returnM (Just ds', extractHsTyNames_s ds') -- "type" and "type instance" declarations -rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - do { name' <- if isFamInstDecl tydecl + = 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 @@ -717,7 +717,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, (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) @@ -796,6 +796,37 @@ 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 + -- 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)