Fix Trac #4534: renamer bug

[ghc-hetmet.git] / compiler / rename / RnExpr.lhs

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 620b1fe..310d075 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -21,7 +21,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
 #endif         /* GHCI */
 
 import RnSource  ( rnSrcDecls, findSplice )
-import RnBinds   ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
+import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
                    rnMatchGroup, makeMiniFixityEnv) 
 import HsSyn
 import TcRnMonad
@@ -30,7 +30,7 @@ import RnEnv
 import RnTypes         ( rnHsTypeFVs, rnSplice, checkTH,
                          mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
 import RnPat
-import DynFlags                ( DynFlag(..) )
+import DynFlags
 import BasicTypes      ( FixityDirection(..) )
 import PrelNames
 
@@ -110,7 +110,7 @@ rnExpr (HsIPVar v)
 
 rnExpr (HsLit lit@(HsString s))
   = do {
-         opt_OverloadedStrings <- doptM Opt_OverloadedStrings
+         opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
        ; if opt_OverloadedStrings then
             rnExpr (HsOverLit (mkHsIsString s placeHolderType))
         else -- Same as below
@@ -262,11 +262,15 @@ rnExpr (ExprWithTySig expr pty)
   where 
     doc = text "In an expression type signature"
 
-rnExpr (HsIf p b1 b2)
-  = rnLExpr p          `thenM` \ (p', fvP) ->
-    rnLExpr b1         `thenM` \ (b1', fvB1) ->
-    rnLExpr b2         `thenM` \ (b2', fvB2) ->
-    return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
+rnExpr (HsIf _ p b1 b2)
+  = do { (p', fvP) <- rnLExpr p
+    ; (b1', fvB1) <- rnLExpr b1
+    ; (b2', fvB2) <- rnLExpr b2
+    ; rebind <- xoptM Opt_RebindableSyntax
+    ; if not rebind
+       then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
+       else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse")))
+               ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
 
 rnExpr (HsType a)
   = rnHsTypeFVs doc a  `thenM` \ (t, fvT) -> 
@@ -320,7 +324,8 @@ rnExpr (HsArrApp arrow arg _ ho rtl)
 -- infix form
 rnExpr (HsArrForm op (Just _) [arg1, arg2])
   = escapeArrowScope (rnLExpr op)
-                       `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
+                       `thenM` \ (op',fv_op) ->
+    let L _ (HsVar op_name) = op' in
     rnCmdTop arg1      `thenM` \ (arg1',fv_arg1) ->
     rnCmdTop arg2      `thenM` \ (arg2',fv_arg2) ->
 
@@ -429,8 +434,8 @@ convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 convertOpFormsCmd (HsCase exp matches)
   = HsCase exp (convertOpFormsMatch matches)
 
-convertOpFormsCmd (HsIf exp c1 c2)
-  = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
+convertOpFormsCmd (HsIf f exp c1 c2)
+  = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
 
 convertOpFormsCmd (HsLet binds cmd)
   = HsLet binds (convertOpFormsLCmd cmd)
@@ -486,7 +491,7 @@ methodNamesCmd (HsArrForm {}) = emptyFVs
 
 methodNamesCmd (HsPar c) = methodNamesLCmd c
 
-methodNamesCmd (HsIf _ c1 c2)
+methodNamesCmd (HsIf _ _ c1 c2)
   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 
 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
@@ -754,7 +759,9 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
                                         Just e  -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
                    ; (thing, fvs_thing) <- thing_inside bndrs
                    ; let fvs        = fvs_by `plusFV` fvs_thing
-                         used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
+                         used_bndrs = filter (`elemNameSet` fvs) bndrs
+                         -- The paper (Fig 5) has a bug here; we must treat any free varaible of
+                         -- the "thing inside", **or of the by-expression**, as used
                    ; return ((by', used_bndrs, thing), fvs) }
 
        ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing), 
@@ -930,7 +937,7 @@ rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) 
-    = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
+    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
          return [(L loc (LetStmt (HsValBinds binds')),
                  -- Warning: this is bogus; see function invariant
                  emptyFVs
@@ -994,7 +1001,7 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do 
   (binds', du_binds) <- 
       -- fixities and unused are handled above in rn_rec_stmts_and_then
-      rnValBindsRHS (mkNameSet all_bndrs) binds'
+      rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
   return [(duDefs du_binds, allUses du_binds, 
           emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
 
@@ -1175,7 +1182,7 @@ checkRecStmt ctxt   = addErr msg
 ---------
 checkParStmt :: HsStmtContext Name -> RnM ()
 checkParStmt _
-  = do { parallel_list_comp <- doptM Opt_ParallelListComp
+  = do { parallel_list_comp <- xoptM Opt_ParallelListComp
        ; checkErr parallel_list_comp msg }
   where
     msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
@@ -1184,7 +1191,7 @@ checkParStmt _
 checkTransformStmt :: HsStmtContext Name -> RnM ()
 checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
                             -- desugarer will break when we come to operate on a parallel array
-  = do { transform_list_comp <- doptM Opt_TransformListComp
+  = do { transform_list_comp <- xoptM Opt_TransformListComp
        ; checkErr transform_list_comp msg }
   where
     msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
@@ -1197,7 +1204,7 @@ checkTransformStmt ctxt = addErr msg
 ---------
 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
 checkTupleSection args
-  = do { tuple_section <- doptM Opt_TupleSections
+  = do { tuple_section <- xoptM Opt_TupleSections
        ; checkErr (all tupArgPresent args || tuple_section) msg }
   where
     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")