[project @ 2005-01-27 10:44:00 by simonpj]

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

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 59d0dd1..2281f3e 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -11,7 +11,7 @@ free variables.
 
 \begin{code}
 module RnExpr (
-       rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
+       rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
        checkPrecMatch, checkTH
    ) where
 
@@ -60,6 +60,11 @@ import List          ( unzip4 )
 ************************************************************************
 
 \begin{code}
+rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
+rnMatchGroup ctxt (MatchGroup ms _)
+  = mapFvRn (rnMatch ctxt) ms  `thenM` \ (new_ms, ms_fvs) ->
+    returnM (MatchGroup new_ms placeHolderType, ms_fvs)
+
 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
 rnMatch ctxt  = wrapLocFstM (rnMatch' ctxt)
 
@@ -99,10 +104,11 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
 \begin{code}
 rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
 
-rnGRHSs ctxt (GRHSs grhss binds _)
+-- gaw 2004
+rnGRHSs ctxt (GRHSs grhss binds)
   = rnBindGroupsAndThen binds  $ \ binds' ->
     mapFvRn (rnGRHS ctxt) grhss        `thenM` \ (grhss', fvGRHSs) ->
-    returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
+    returnM (GRHSs grhss' binds', fvGRHSs)
 
 rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
 rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
@@ -184,10 +190,6 @@ rnExpr (HsOverLit lit)
   = rnOverLit lit              `thenM` \ (lit', fvs) ->
     returnM (HsOverLit lit', fvs)
 
-rnExpr (HsLam match)
-  = rnMatch LambdaExpr match   `thenM` \ (match', fvMatch) ->
-    returnM (HsLam match', fvMatch)
-
 rnExpr (HsApp fun arg)
   = rnLExpr fun                `thenM` \ (fun',fvFun) ->
     rnLExpr arg                `thenM` \ (arg',fvArg) ->
@@ -251,10 +253,14 @@ rnExpr (HsSCC lbl expr)
   = rnLExpr expr               `thenM` \ (expr', fvs_expr) ->
     returnM (HsSCC lbl expr', fvs_expr)
 
-rnExpr (HsCase expr ms)
+rnExpr (HsLam matches)
+  = rnMatchGroup LambdaExpr matches    `thenM` \ (matches', fvMatch) ->
+    returnM (HsLam matches', fvMatch)
+
+rnExpr (HsCase expr matches)
   = rnLExpr expr                       `thenM` \ (new_expr, e_fvs) ->
-    mapFvRn (rnMatch CaseAlt) ms       `thenM` \ (new_ms, ms_fvs) ->
-    returnM (HsCase new_expr new_ms, e_fvs `plusFV` ms_fvs)
+    rnMatchGroup CaseAlt matches       `thenM` \ (new_matches, ms_fvs) ->
+    returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
 
 rnExpr (HsLet binds expr)
   = rnBindGroupsAndThen binds          $ \ binds' ->
@@ -302,12 +308,12 @@ rnExpr (RecordCon con_id rbinds)
     returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname)
 
 rnExpr (RecordUpd expr rbinds)
-  = rnLExpr expr                       `thenM` \ (expr', fvExpr) ->
+  = rnLExpr expr               `thenM` \ (expr', fvExpr) ->
     rnRbinds "update" rbinds   `thenM` \ (rbinds', fvRbinds) ->
     returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 
 rnExpr (ExprWithTySig expr pty)
-  = rnLExpr expr                       `thenM` \ (expr', fvExpr) ->
+  = rnLExpr expr               `thenM` \ (expr', fvExpr) ->
     rnHsTypeFVs doc pty                `thenM` \ (pty', fvTy) ->
     returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
   where 
@@ -455,9 +461,7 @@ convertOpFormsLCmd = fmap convertOpFormsCmd
 convertOpFormsCmd :: HsCmd id -> HsCmd id
 
 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
-
 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
-
 convertOpFormsCmd (OpApp c1 op fixity c2)
   = let
        arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
@@ -467,8 +471,9 @@ convertOpFormsCmd (OpApp c1 op fixity c2)
 
 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 
+-- gaw 2004
 convertOpFormsCmd (HsCase exp matches)
-  = HsCase exp (map convertOpFormsMatch matches)
+  = HsCase exp (convertOpFormsMatch matches)
 
 convertOpFormsCmd (HsIf exp c1 c2)
   = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
@@ -494,12 +499,13 @@ convertOpFormsStmt (RecStmt stmts lvs rvs es)
   = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es
 convertOpFormsStmt stmt = stmt
 
-convertOpFormsMatch = fmap convert
+convertOpFormsMatch (MatchGroup ms ty)
+  = MatchGroup (map (fmap convert) ms) ty
  where convert (Match pat mty grhss)
          = Match pat mty (convertOpFormsGRHSs grhss)
 
-convertOpFormsGRHSs (GRHSs grhss binds ty)
-  = GRHSs (map convertOpFormsGRHS grhss) binds ty
+convertOpFormsGRHSs (GRHSs grhss binds)
+  = GRHSs (map convertOpFormsGRHS grhss) binds
 
 convertOpFormsGRHS = fmap convert
  where convert (GRHS stmts)
@@ -538,7 +544,7 @@ methodNamesCmd (HsApp c e) = methodNamesLCmd c
 methodNamesCmd (HsLam match) = methodNamesMatch match
 
 methodNamesCmd (HsCase scrut matches)
-  = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
+  = methodNamesMatch matches `addOneFV` choiceAName
 
 methodNamesCmd other = emptyFVs
    -- Other forms can't occur in commands, but it's not convenient 
@@ -546,10 +552,14 @@ methodNamesCmd other = emptyFVs
    -- The type checker will complain later
 
 ---------------------------------------------------
-methodNamesMatch (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
+methodNamesMatch (MatchGroup ms ty)
+  = plusFVs (map do_one ms)
+ where 
+    do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
 
 -------------------------------------------------
-methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
+-- gaw 2004
+methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
 
 -------------------------------------------------
 methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts)
@@ -821,7 +831,8 @@ rnMDoStmts stmts
     in
     returnM stmts_w_fvs
   where
-    doc = text "In a mdo-expression"
+
+    doc = text "In a recursive mdo-expression"
 
 
 ----------------------------------------------------
@@ -952,7 +963,8 @@ segsToStmts :: [Segment [LStmt Name]] -> ([LStmt Name], FreeVars)
 
 segsToStmts [] = ([], emptyFVs)
 segsToStmts ((defs, uses, fwds, ss) : segs)
-  = (new_stmt : later_stmts, later_uses `plusFV` uses)
+  = ASSERT( not (null ss) )
+    (new_stmt : later_stmts, later_uses `plusFV` uses)
   where
     (later_stmts, later_uses) = segsToStmts segs
     new_stmt | non_rec  = head ss
@@ -1054,18 +1066,20 @@ not_op_app other           = True
 \end{code}
 
 \begin{code}
-checkPrecMatch :: Bool -> Name -> LMatch Name -> RnM ()
+checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
+       -- True indicates an infix lhs
+       -- See comments with rnExpr (OpApp ...) about "deriving"
 
-checkPrecMatch False fn match
+checkPrecMatch False fn match 
   = returnM ()
+checkPrecMatch True op (MatchGroup ms _)       
+  = mapM_ check ms                             
+  where
+    check (L _ (Match (p1:p2:_) _ _))
+      = checkPrec op (unLoc p1) False  `thenM_`
+        checkPrec op (unLoc p2) True
 
-checkPrecMatch True op (L _ (Match (p1:p2:_) _ _))
-       -- True indicates an infix lhs
-  =    -- See comments with rnExpr (OpApp ...) about "deriving"
-    checkPrec op (unLoc p1) False      `thenM_`
-    checkPrec op (unLoc p2) True
-
-checkPrecMatch True op _ = panic "checkPrecMatch"
+    check _ = panic "checkPrecMatch"
 
 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
   = lookupFixityRn op          `thenM` \  op_fix@(Fixity op_prec  op_dir) ->