X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=477307e563b1f3e5c3d9fefd78b774bd4fd9d8fc;hp=93014802fc77198f1e0915ec24ae806d7daa91f7;hb=afef39736dcde6f4947a6f362f9e6b3586933db4;hpb=a883f6ba301651e1c8a1636f0ff74ad6c078fd12 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9301480..477307e 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -15,12 +15,12 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn -import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts, - GlobalRdrElt(..), isLocalGRE ) +import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, elemLocalRdrEnv, + globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, lookupOccRn, newLocalsRn, @@ -38,10 +38,11 @@ import NameSet import NameEnv import OccName ( occEnvElts ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) +import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) import Maybe ( isNothing ) +import Monad ( liftM ) import BasicTypes ( Boxity(..) ) \end{code} @@ -109,8 +110,10 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; let { + rn_at_decls = concat + [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ; rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls, + hs_tyclds = rn_tycl_decls ++ rn_at_decls, hs_instds = rn_inst_decls, hs_fixds = rn_fix_decls, hs_depds = [], @@ -246,15 +249,15 @@ rnDefaultDecl (DefaultDecl tys) %********************************************************* \begin{code} -rnHsForeignDecl (ForeignImport name ty spec isDeprec) +rnHsForeignDecl (ForeignImport name ty spec) = lookupLocatedTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignImport name' ty' spec isDeprec, fvs) + returnM (ForeignImport name' ty' spec, fvs) -rnHsForeignDecl (ForeignExport name ty spec isDeprec) +rnHsForeignDecl (ForeignExport name ty spec) = lookupLocatedOccRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignExport name' ty' spec isDeprec, fvs ) + returnM (ForeignExport name' ty' spec, fvs ) -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module @@ -270,10 +273,21 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name %********************************************************* \begin{code} -rnSrcInstDecl (InstDecl inst_ty mbinds uprags) +rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> + -- Rename the associated types + -- The typechecker (not the renamer) checks that all + -- the declarations are for the right class + let + at_doc = text "In the associated types in an instance declaration" + at_names = map (head . tyClDeclNames . unLoc) ats + (_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty) + in + checkDupNames at_doc at_names `thenM_` + rnATDefs rdrCtxt ats `thenM` \ (ats', at_fvs) -> + -- Rename the bindings -- The typechecker (not the renamer) checks that all -- the bindings are for the right class @@ -286,7 +300,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags) extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too - rnMethodBinds cls [] mbinds + rnMethodBinds cls (\n->[]) -- No scoped tyvars + [] mbinds ) `thenM` \ (mbinds', meth_fvs) -> -- Rename the prags and signatures. -- Note that the type variables are not in scope here, @@ -301,9 +316,36 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags) in bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' -> - returnM (InstDecl inst_ty' mbinds' uprags', - meth_fvs `plusFV` hsSigsFVs uprags' + returnM (InstDecl inst_ty' mbinds' uprags' ats', + meth_fvs `plusFV` at_fvs + `plusFV` hsSigsFVs uprags' `plusFV` extractHsTyNames inst_ty') + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). +\end{code} + +Renaming of the associated data definitions requires adding the instance +context, as the rhs of an AT declaration may use ATs from classes in the +context. + +\begin{code} +rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] + -> RnM ([LTyClDecl Name], FreeVars) +rnATDefs ctxt atDecls = + mapFvRn (wrapLocFstM addCtxtAndRename) atDecls + where + -- The parser won't accept anything, but a data declaration + addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} = + rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)}) + -- The source loc is somewhat half hearted... -=chak \end{code} For the method bindings in class and instance decls, we extend the @@ -334,15 +376,9 @@ rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs) rnLExpr lhs `thenM` \ (lhs', fv_lhs') -> rnLExpr rhs `thenM` \ (rhs', fv_rhs') -> - let - mb_bad = validRuleLhs ids lhs' - in - checkErr (isNothing mb_bad) - (badRuleLhsErr rule_name lhs' mb_bad) `thenM_` - let - bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - in - mappM (addErr . badRuleVar rule_name) bad_vars `thenM_` + + checkValidRule rule_name ids lhs' fv_lhs' `thenM_` + returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') where @@ -356,17 +392,38 @@ rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs) rn_var (RuleBndrSig (L loc v) t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> returnM (RuleBndrSig (L loc id) t', fvs) + +badRuleVar name var + = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, + ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> + ptext SLIT("does not appear on left hand side")] \end{code} -Check the shape of a transformation rule LHS. Currently -we only allow LHSs of the form @(f e1 .. en)@, where @f@ is -not one of the @forall@'d variables. We also restrict the form of the LHS so -that it may be plausibly matched. Basically you only get to write ordinary -applications. (E.g. a case expression is not allowed: too elaborate.) +Note [Rule LHS validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check the shape of a transformation rule LHS. Currently we only allow +LHSs of the form @(f e1 .. en)@, where @f@ is not one of the +@forall@'d variables. -NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs +We used restrict the form of the 'ei' to prevent you writing rules +with LHSs with a complicated desugaring (and hence unlikely to match); +(e.g. a case expression is not allowed: too elaborate.) +But there are legitimate non-trivial args ei, like sections and +lambdas. So it seems simmpler not to check at all, and that is why +check_e is commented out. + \begin{code} +checkValidRule rule_name ids lhs' fv_lhs' + = do { -- Check for the form of the LHS + case (validRuleLhs ids lhs') of + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + + -- Check that LHS vars are all bound + ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + ; mappM (addErr . badRuleVar rule_name) bad_vars } + validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) -- Nothing => OK -- Just e => Not ok, and e is the offending expression @@ -380,8 +437,10 @@ validRuleLhs foralls lhs check (HsVar v) | v `notElem` foralls = Nothing check other = Just other -- Failure - checkl_e (L loc e) = check_e e + -- Check an argument + checkl_e (L loc e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] +{- Commented out; see Note [Rule LHS validity checking] above check_e (HsVar v) = Nothing check_e (HsPar e) = checkl_e e check_e (HsLit e) = Nothing @@ -395,18 +454,14 @@ validRuleLhs foralls lhs check_e other = Just other -- Fails checkl_es es = foldr (seqMaybe . checkl_e) Nothing es +-} -badRuleLhsErr name lhs (Just bad_e) +badRuleLhsErr name lhs bad_e = sep [ptext SLIT("Rule") <+> ftext name <> colon, nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, ptext SLIT("in left-hand side:") <+> ppr lhs])] $$ ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") - -badRuleVar name var - = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, - ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> - ptext SLIT("does not appear on left hand side")] \end{code} @@ -436,27 +491,30 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ emptyFVs) rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, - tcdTyVars = tyvars, tcdCons = condecls, - tcdKindSig = sig, tcdDerivs = derivs}) + 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 bindTyVarsRn data_doc tyvars $ \ tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context + ; typats' <- rnTyPats data_doc typatsMaybe ; (derivs', deriv_fvs) <- rn_derivs derivs ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls - ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', - tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', - tcdDerivs = derivs'}, + ; returnM (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` + plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } | otherwise -- GADT - = do { tycon' <- lookupLocatedTopBndrRn tycon + = ASSERT( null typats ) -- GADTs cannot have type patterns for now + do { tycon' <- lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) ; tyvars' <- bindTyVarsRn data_doc tyvars (\ tyvars' -> return tyvars') @@ -466,9 +524,10 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, ; (derivs', deriv_fvs) <- rn_derivs derivs ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls - ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig, - tcdDerivs = derivs'}, + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], + tcdLName = tycon', tcdTyVars = tyvars', + tcdTyPats = Nothing, tcdKindSig = sig, + tcdCons = condecls', tcdDerivs = derivs'}, plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } where @@ -498,16 +557,23 @@ rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds}) + tcdMeths = mbinds, tcdATs = ats}) = lookupLocatedTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures bindTyVarsRn cls_doc tyvars ( \ tyvars' -> rnContext cls_doc context `thenM` \ context' -> rnFds cls_doc fds `thenM` \ fds' -> + rnATs tyvars' ats `thenM` \ (ats', ats_fvs) -> renameSigs okClsDclSig sigs `thenM` \ sigs' -> - returnM (tyvars', context', fds', sigs') - ) `thenM` \ (tyvars', context', fds', sigs') -> + returnM (tyvars', context', fds', (ats', ats_fvs), sigs') + ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') -> + + -- Check for duplicates among the associated types + let + at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats] + in + checkDupNames at_doc at_rdr_names_w_locs `thenM_` -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). @@ -538,20 +604,23 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, in checkDupNames meth_doc meth_rdr_names_w_locs `thenM_` newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> - rnMethodBinds (unLoc cname') gen_tyvars mbinds + rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds ) `thenM` \ (mbinds', meth_fvs) -> - returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', - tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'}, + returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', + tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats'}, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` hsSigsFVs sigs' `plusFV` - meth_fvs) + meth_fvs `plusFV` + ats_fvs) where meth_doc = text "In the default-methods for class" <+> ppr cname cls_doc = text "In the declaration for class" <+> ppr cname sig_doc = text "In the signatures for class" <+> ppr cname + at_doc = text "In the associated types for class" <+> ppr cname badGadtStupidTheta tycon = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"), @@ -565,6 +634,14 @@ badGadtStupidTheta tycon %********************************************************* \begin{code} +-- Although, we are processing type patterns here, all type variables should +-- 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 = mappM (wrapLocM rnConDecl) condecls @@ -592,18 +669,22 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty) ; bindTyVarsRn doc tvs' $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDetails doc details - ; new_res_ty <- rnConResult doc res_ty - ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty - ; traceRn (text "****** - autrijus" <> ppr rv) - ; return rv } } + ; (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) }} where doc = text "In the definition of data constructor" <+> quotes (ppr name) get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) -rnConResult _ ResTyH98 = return ResTyH98 -rnConResult doc (ResTyGADT ty) = do +rnConResult _ details ResTyH98 = return (details, ResTyH98) + +rnConResult doc details (ResTyGADT ty) = do ty' <- rnHsSigType doc ty - return $ ResTyGADT 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 fields -> return (details, ResTyGADT ty') + InfixCon {} -> panic "rnConResult" rnConDetails doc (PrefixCon tys) = mappM (rnLHsType doc) tys `thenM` \ new_tys -> @@ -662,6 +743,77 @@ rnFds doc fds rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs rnHsTyvar doc tyvar = lookupOccRn tyvar + +-- Rename associated data type declarations +-- +rnATs :: [LHsTyVarBndr Name] -> [LTyClDecl RdrName] + -> RnM ([LTyClDecl Name], FreeVars) +rnATs classLTyVars ats + = mapFvRn (wrapLocFstM rn_at) ats + where + -- The parser won't accept anything, but a data declarations + rn_at (tydecl@TyData {tcdCtxt = L ctxtL ctxt, tcdLName = tycon, + tcdTyPats = Just typats, tcdCons = condecls, + tcdDerivs = derivs}) = + do { checkM (null ctxt ) $ addErr atNoCtxt -- no context + ; checkM (null condecls) $ addErr atNoCons -- no constructors + -- check and collect type parameters + ; let (idxParms, excessParms) = splitAt (length classLTyVars) typats + ; zipWithM_ cmpTyVar idxParms classLTyVars + ; excessTyVars <- liftM catMaybes $ mappM chkTyVar excessParms + -- bind excess parameters + ; bindTyVarsRn data_doc excessTyVars $ \ excessTyVars' -> do { + ; tycon' <- lookupLocatedTopBndrRn tycon + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = L ctxtL [], + tcdLName = tycon', + tcdTyVars = classLTyVars ++ excessTyVars', + tcdTyPats = Nothing, tcdKindSig = Nothing, + tcdCons = [], tcdDerivs = derivs'}, + delFVs (map hsLTyVarName (classLTyVars ++ excessTyVars')) $ + deriv_fvs) } } + where + -- Check that the name space is correct! + cmpTyVar (L l ty@(HsTyVar tv)) classTV = -- just a type variable + checkM (rdrNameOcc tv == nameOccName classTVName) $ + mustMatchErr l ty classTVName + where + classTVName = hsLTyVarName classTV + cmpTyVar (L l ty@(HsKindSig (L _ (HsTyVar tv)) k)) _ | isRdrTyVar tv = + noKindSigErr l tv -- additional kind sig not allowed at class parms + cmpTyVar (L l otherTy) _ = + tyVarExpectedErr l -- parameter must be a type variable + + -- Check that the name space is correct! + chkTyVar (L l (HsKindSig (L _ (HsTyVar tv)) k)) + | isRdrTyVar tv = return $ Just (L l (KindedTyVar tv k)) + chkTyVar (L l (HsTyVar tv)) + | isRdrTyVar tv = return $ Just (L l (UserTyVar tv)) + chkTyVar (L l otherTy) = tyVarExpectedErr l >> return Nothing + -- drop parameter; we stop after renaming anyways + + rn_derivs Nothing = returnM (Nothing, emptyFVs) + rn_derivs (Just ds) = do + ds' <- rnLHsTypes data_doc ds + returnM (Just ds', extractHsTyNames_s ds') + + atNoCtxt = text "Associated data type declarations cannot have a context" + atNoCons = text "Associated data type declarations cannot have any constructors" + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) + +noKindSigErr l ty = + addErrAt l $ + sep [ptext SLIT("No kind signature allowed at copies of class parameters:"), + nest 2 $ ppr ty] + +mustMatchErr l ty classTV = + addErrAt l $ + sep [ptext SLIT("Type variable"), quotes (ppr ty), + ptext SLIT("must match corresponding class parameter"), + quotes (ppr classTV)] + +tyVarExpectedErr l = + addErrAt l (ptext SLIT("Type found where type variable expected")) \end{code}