X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=ae994d05d0031ad2ccf09fe094db1a221a6ecc7c;hp=79721cfdacdb2e911177a0cb0f5f3684c1a3f6bb;hb=8dabe4de7f321fb25899356a9198ac7aff57a9e9;hpb=5edf58c10a0144fa8b328e18d0b7fffec2319424

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 79721cf..ae994d0 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -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
@@ -335,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
@@ -357,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
@@ -381,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
@@ -396,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}