[project @ 2005-04-04 11:55:11 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 34eb1ae..6cfb807 100644 (file)
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -300,7 +300,7 @@ repC (L loc (ConDecl con tvs (L cloc ctxt) details))
 repC (L loc con_decl)
   = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
        ; return (panic "DsMeta:repC") }
-  where
+
 -- gaw 2004 FIX! Need a case for GadtDecl
 
 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
@@ -512,13 +512,17 @@ repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
                               ; z <- repLetE ds e2
                               ; wrapGenSyns ss z }
 -- FIXME: I haven't got the types here right yet
-repE (HsDo DoExpr sts _ ty) 
+repE (HsDo DoExpr sts body ty) 
  = do { (ss,zs) <- repLSts sts; 
-        e       <- repDoE (nonEmptyCoreList zs);
+       body'   <- repLE body;
+       ret     <- repNoBindSt body';   
+        e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
         wrapGenSyns ss e }
-repE (HsDo ListComp sts _ ty) 
+repE (HsDo ListComp sts body ty) 
  = do { (ss,zs) <- repLSts sts; 
-        e       <- repComp (nonEmptyCoreList zs);
+       body'   <- repLE body;
+       ret     <- repNoBindSt body';   
+        e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
         wrapGenSyns ss e }
 repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
 repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } 
@@ -527,11 +531,11 @@ repE (ExplicitPArr ty es) =
 repE (ExplicitTuple es boxed) 
   | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
   | otherwise            = panic "DsMeta.repE: Can't represent unboxed tuples"
-repE (RecordCon c flds)
+repE (RecordCon c _ flds)
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
         repRecCon x fs }
-repE (RecordUpd e flds)
+repE (RecordUpd e flds _ _)
  = do { x <- repLE e;
         fs <- repFields flds;
         repRecUpd x fs }
@@ -592,7 +596,7 @@ repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
      ; wrapGenSyns (ss1++ss2) clause }}}
 
 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
-repGuards [L _ (GRHS [L _ (ResultStmt e)])]
+repGuards [L _ (GRHS [] e)]
   = do {a <- repLE e; repNormal a }
 repGuards other 
   = do { zs <- mapM process other;
@@ -601,14 +605,13 @@ repGuards other
      wrapGenSyns (concat xs) gd }
   where 
     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-    process (L _ (GRHS [])) = panic "No guards in guarded body"
-    process (L _ (GRHS [L _ (ExprStmt e1 ty),
-                       L _ (ResultStmt e2)]))
+    process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
            = do { x <- repLNormalGE e1 e2;
                   return ([], x) }
-    process (L _ (GRHS ss))
+    process (L _ (GRHS ss rhs))
            = do (gs, ss') <- repLSts ss
-                g <- repPatGE (nonEmptyCoreList ss')
+               rhs' <- repLE rhs
+                g <- repPatGE (nonEmptyCoreList ss') rhs'
                 return (gs, g)
 
 repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
@@ -648,11 +651,7 @@ repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 repLSts stmts = repSts (map unLoc stmts)
 
 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
-repSts [ResultStmt e] = 
-   do { a <- repLE e
-      ; e1 <- repNoBindSt a
-      ; return ([], [e1]) }
-repSts (BindStmt p e : ss) =
+repSts (BindStmt p e _ _ : ss) =
    do { e2 <- repLE e 
       ; ss1 <- mkGenSyms (collectPatBinders p) 
       ; addBinds ss1 $ do {
@@ -665,7 +664,7 @@ repSts (LetStmt bs : ss) =
       ; z <- repLetSt ds
       ; (ss2,zs) <- addBinds ss1 (repSts ss)
       ; return (ss1++ss2, z : zs) } 
-repSts (ExprStmt e ty : ss) =       
+repSts (ExprStmt e _ _ : ss) =       
    do { e2 <- repLE e
       ; z <- repNoBindSt e2 
       ; (ss2,zs) <- repSts ss
@@ -774,7 +773,7 @@ rep_bind (L loc (VarBind v e))
 -- (\ p1 .. pn -> exp) by causing an error.  
 
 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [])))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [])] [])))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
       ; lam <- addBinds ss (
@@ -821,8 +820,8 @@ repP (ConPatIn dc details)
                                 p2' <- repLP p2;
                                 repPinfix p1' con_str p2' }
    }
-repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
-repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
+repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
 repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
 repP other = panic "Exotic pattern inside meta brackets"
 
@@ -881,7 +880,7 @@ lookupBinder n
 
 -- Look up a name that is either locally bound or a global name
 --
--- * If it is a global name, generate the "original name" representation (ie,
+--  * If it is a global name, generate the "original name" representation (ie,
 --   the <module>:<name> form) for the associated entity
 --
 lookupLOcc :: Located Name -> DsM (Core TH.Name)
@@ -911,7 +910,7 @@ globalVar name
   | otherwise
   = do         { MkC occ <- occNameLit name
        ; MkC uni <- coreIntLit (getKey (getUnique name))
-       ; rep2 mkNameUName [occ,uni] }
+       ; rep2 mkNameLName [occ,uni] }
   where
       name_mod = moduleUserString (nameModule name)
       name_occ = nameOccName name
@@ -1107,8 +1106,8 @@ repLNormalGE g e = do g' <- repLE g
 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
 
-repPatGE :: Core [TH.StmtQ] -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
-repPatGE (MkC ss) = rep2 patGEName [ss]
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) = rep2 patGName [ss]
 
 ------------- Stmts -------------------
 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
@@ -1255,7 +1254,7 @@ mk_integer  i = do integer_ty <- lookupType integerTyConName
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
 
-repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit)
+repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
 repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
        -- The type Rational will be in the environment, becuase 
@@ -1326,7 +1325,7 @@ templateHaskellNames :: [Name]
 
 templateHaskellNames = [
     returnQName, bindQName, sequenceQName, newNameName, liftName,
-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName, 
+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, 
 
     -- Lit
     charLName, stringLName, integerLName, intPrimLName,
@@ -1422,7 +1421,7 @@ mkNameName     = thFun FSLIT("mkName")     mkNameIdKey
 mkNameG_vName  = thFun FSLIT("mkNameG_v")  mkNameG_vIdKey
 mkNameG_dName  = thFun FSLIT("mkNameG_d")  mkNameG_dIdKey
 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
-mkNameUName    = thFun FSLIT("mkNameU")    mkNameUIdKey
+mkNameLName    = thFun FSLIT("mkNameL")    mkNameLIdKey
 
 
 -------------------- TH.Lib -----------------------
@@ -1604,7 +1603,7 @@ mkNameIdKey          = mkPreludeMiscIdUnique 205
 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
-mkNameUIdKey         = mkPreludeMiscIdUnique 209
+mkNameLIdKey         = mkPreludeMiscIdUnique 209
 
 
 -- data Lit = ...