X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FReadPrefix.lhs;h=733dd7f52dc4d934bb8fd540b63cbd4d81863595;hp=6043f72c10c05420bec2b70b51512734c4429c30;hb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;hpb=b8875f2f7f596482228645b9751f8f9c592a84c5

diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 6043f72..733dd7f 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -31,7 +31,7 @@ import MainMonad	( thenMn, MainIO(..) )
 import PprStyle		( PprStyle(..) )
 import Pretty
 import ProtoName	( isConopPN, ProtoName(..) )
-import Util		( nOfThem, panic )
+import Util		( nOfThem, pprError, panic )
 \end{code}
 
 %************************************************************************
@@ -327,7 +327,7 @@ wlkExpr expr
       U_record con rbinds -> -- record construction
 	wlkQid  con		`thenUgn` \ rcon     ->
 	wlkList rdRbind rbinds	`thenUgn` \ recbinds ->
-	returnUgn (RecordCon rcon recbinds)
+	returnUgn (RecordCon (HsVar rcon) recbinds)
 
       U_rupdate updexp updbinds -> -- record update
 	wlkExpr updexp		 `thenUgn` \ aexp ->
@@ -352,7 +352,11 @@ rdRbind pt
   = rdU_tree pt		`thenUgn` \ (U_rbind var exp) ->
     wlkQid   var	`thenUgn` \ rvar ->
     wlkMaybe rdExpr exp	`thenUgn` \ expr_maybe ->
-    returnUgn (rvar, expr_maybe)
+    returnUgn (
+      case expr_maybe of
+	Nothing -> (rvar, HsVar rvar, True{-pun-})
+	Just re -> (rvar, re,	      False)
+    )
 \end{code}
 
 Patterns: just bear in mind that lists of patterns are represented as
@@ -406,9 +410,8 @@ wlkPat pat
 		  ConPatIn x []     -> (x,  lpats)
 		  ConOpPatIn x op y -> (op, x:y:lpats)
 		  _ -> -- sorry about the weedy msg; the parser missed this one
-		       error (ppShow 100 (ppCat [
-			   ppStr "ERROR: an illegal `application' of a pattern to another one:",
-			   ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats))]))
+		       pprError "ERROR: an illegal `application' of a pattern to another one:"
+			  (ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats)))
 	in
 	returnUgn (ConPatIn n arg_pats)
 	where
@@ -444,7 +447,11 @@ wlkPat pat
 	    = rdU_tree pt	 `thenUgn` \ (U_rbind var pat) ->
     	      wlkQid   var	 `thenUgn` \ rvar ->
     	      wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
-    	      returnUgn (rvar, pat_maybe)
+	      returnUgn (
+		case pat_maybe of
+		  Nothing -> (rvar, VarPatIn rvar, True{-pun-})
+		  Just rp -> (rvar, rp,		   False)
+	      )
 \end{code}
 
 \begin{code}
@@ -748,7 +755,7 @@ mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
 
 mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
 mk_class_assertion other
-  = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
+  = pprError "ERROR: malformed type context: " (ppr PprForUser other)
     -- regrettably, the parser does let some junk past
     -- e.g., f :: Num {-nothing-} => a -> ...
 \end{code}
@@ -784,14 +791,14 @@ wlkConDecl (U_constrrec ccon cfields srcline)
   = mkSrcLocUgn srcline		`thenUgn` \ src_loc      ->
     wlkQid	ccon		`thenUgn` \ con		 ->
     wlkList rd_field cfields	`thenUgn` \ fields_lists ->
-    returnUgn (RecConDecl con (concat fields_lists) src_loc)
+    returnUgn (RecConDecl con fields_lists src_loc)
   where
-    rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)]
+    rd_field :: ParseTree -> UgnM ([ProtoName], BangType ProtoName)
     rd_field pt
       = rdU_constr pt		`thenUgn` \ (U_field fvars fty) ->
 	wlkList rdQid	fvars	`thenUgn` \ vars ->
 	wlkBangType fty		`thenUgn` \ ty ->
-	returnUgn [ (var, ty) | var <- vars ]
+	returnUgn (vars, ty)
 
 -----------------
 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty