X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=ae994d05d0031ad2ccf09fe094db1a221a6ecc7c;hb=9f8e195e69e54c733eb93b2e2e39c2ebe818ce62;hp=93014802fc77198f1e0915ec24ae806d7daa91f7;hpb=a883f6ba301651e1c8a1636f0ff74ad6c078fd12;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9301480..ae994d0 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -20,7 +20,7 @@ import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts, 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,7 +38,7 @@ 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 ) @@ -246,15 +246,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 @@ -286,7 +286,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, @@ -334,15 +335,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 +351,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 +396,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 +413,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} @@ -538,7 +552,7 @@ 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', @@ -592,18 +606,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 ->