From: simonpj <unknown>
Date: Tue, 21 May 2002 13:43:59 +0000 (+0000)
Subject: [project @ 2002-05-21 13:43:59 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~2024
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a7def5990194fa889349de4035b6cd4dfed1c57b;p=ghc-hetmet.git

[project @ 2002-05-21 13:43:59 by simonpj]
Parse External Core correctly

Amazingly, recursive bindings with only one binding in the
group were being parsed as non-recursive.
---

diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y
index bcedf8c..c18a15a 100644
--- a/ghc/compiler/parser/ParserCore.y
+++ b/ghc/compiler/parser/ParserCore.y
@@ -98,6 +98,11 @@ vdefg	:: { [RdrNameHsDecl] }
 	: '%rec' '{' vdefs1 '}' { $3   }
 	|  vdef                 { [$1] }
 
+let_bind :: { UfBinding RdrName }
+	: '%rec' '{' vdefs1 '}' { UfRec (map convBind $3)   }
+	|  vdef                 { let (b,r) = convBind $1
+				  in UfNonRec b r }
+
 vdefs1	:: { [RdrNameHsDecl] }
 	: vdef		        { [$1] }
 	| vdef ';' vdefs1       { $1:$3 }
@@ -176,7 +181,7 @@ fexp	:: { UfExpr RdrName }
 exp	:: { UfExpr RdrName }
 	: fexp		           { $1 }
 	| '\\' binds1 '->' exp 	   { foldr UfLam $4 $2 }
-	| '%let' vdefg '%in' exp   { UfLet (toUfBinder $2) $4 }
+	| '%let' let_bind '%in' exp   { UfLet $2 $4 }
 	| '%case' aexp '%of' vbind
 	  '{' alts1 '}'		   { UfCase $2 (fst $4) $6 }
 	| '%coerce' aty exp   	   { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
@@ -235,16 +240,10 @@ q_d_name	:: { RdrName }
 
 
 {
-toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
-toUfBinder xs  = 
- case xs of 
-   [x] -> uncurry UfNonRec (conv x)
-   _   -> UfRec (map conv xs)
- where
-  conv (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
+convBind :: RdrNameHsDecl -> (UfBinder RdrName, UfExpr RdrName)
+convBind (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
 
 happyError :: P a 
 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
-
 }