[project @ 2004-09-30 10:35:15 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 fb32abe..9329f6a 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -11,13 +11,13 @@ free variables.
 
 \begin{code}
 module RnExpr (
-       rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
-       checkPrecMatch
+       rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
+       checkPrecMatch, checkTH
    ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} RnSource  ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups ) 
+import {-# SOURCE #-} RnSource  ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups, rnSplice ) 
 
 --     RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
 --     RnBinds  imports RnExpr.rnMatch, etc
@@ -29,7 +29,7 @@ import TcRnMonad
 import RnEnv
 import OccName         ( plusOccEnv )
 import RnNames         ( importsFromLocalDecls )
-import RnTypes         ( rnHsTypeFVs, rnLPat, litFVs, rnOverLit, rnPatsAndThen,
+import RnTypes         ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
                          dupFieldErr, precParseErr, sectionPrecErr, patSigErr,
                          checkTupSize )
 import CmdLineOpts     ( DynFlag(..) )
@@ -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)
@@ -177,17 +183,13 @@ rnExpr (HsIPVar v)
     returnM (HsIPVar name, emptyFVs)
 
 rnExpr (HsLit lit) 
-  = litFVs lit         `thenM` \ fvs -> 
-    returnM (HsLit lit, fvs)
+  = rnLit lit          `thenM_`
+    returnM (HsLit lit, emptyFVs)
 
 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) ->
@@ -227,12 +229,9 @@ rnExpr e@(HsBracket br_body)
     rnBracket br_body          `thenM` \ (body', fvs_e) ->
     returnM (HsBracket body', fvs_e)
 
-rnExpr e@(HsSplice n splice)
-  = checkTH e "splice"         `thenM_`
-    getSrcSpanM                `thenM` \ loc ->
-    newLocalsRn [L loc n]      `thenM` \ [n'] ->
-    rnLExpr splice             `thenM` \ (splice', fvs_e) ->
-    returnM (HsSplice n' splice', fvs_e)
+rnExpr e@(HsSpliceE splice)
+  = rnSplice splice            `thenM` \ (splice', fvs) ->
+    returnM (HsSpliceE splice', fvs)
 
 rnExpr section@(SectionL expr op)
   = rnLExpr expr               `thenM` \ (expr', fvs_expr) ->
@@ -254,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' ->
@@ -458,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 []
@@ -470,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)
@@ -497,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)
@@ -541,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 
@@ -549,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)
@@ -955,7 +962,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
@@ -1057,18 +1065,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) ->