From 5568d10fa4d8a6e285249992a66426704dcec916 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 2 Jun 2004 08:23:46 +0000
Subject: [PATCH] [project @ 2004-06-02 08:23:43 by simonpj]
 ------------------------------- 	Fix a grevious bug
 in DsMeta 	which caused a seg fault 
 -------------------------------

The bug was an incorrectly declared type for one of the Template
Haskell construction functions in DsMeta (repRecCon, repRecUpd)
and some associated jiggery pokery.

-dcore-lint showed it up nicely, because the desugarer generated
ill-typed code.

DsMeta PrelNames TH.Lib
---
 ghc/compiler/deSugar/DsMeta.hs     |   21 +++++++++++++--------
 ghc/compiler/prelude/PrelNames.lhs |    2 +-
 2 files changed, 14 insertions(+), 9 deletions(-)

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 42e8604..0f1ee5e 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -582,12 +582,12 @@ repGuards other
                 g <- repPatGE (nonEmptyCoreList ss')
                 return (gs, g)
 
-repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp])
+repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
 repFields flds = do
         fnames <- mapM lookupLOcc (map fst flds)
         es <- mapM repLE (map snd flds)
-        fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
-        coreList fieldExpTyConName fs
+        fs <- zipWithM repFieldExp fnames es
+        coreList fieldExpQTyConName fs
 
 
 -----------------------------------------------------------------------------
@@ -1044,12 +1044,15 @@ repListExp (MkC es) = rep2 listEName [es]
 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
 
-repRecCon :: Core TH.Name -> Core [TH.FieldExp]-> DsM (Core TH.ExpQ)
-repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
 
-repRecUpd :: Core TH.ExpQ -> Core [TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
 
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 
@@ -1348,7 +1351,7 @@ templateHaskellNames = [
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
-    fieldPatQTyConName]
+    fieldPatQTyConName, fieldExpQTyConName]
 
 tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax"
 tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
@@ -1523,10 +1526,11 @@ conQTyConName           = libTc FSLIT("ConQ")          conQTyConKey
 strictTypeQTyConName    = libTc FSLIT("StrictTypeQ")    strictTypeQTyConKey
 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
 typeQTyConName          = libTc FSLIT("TypeQ")          typeQTyConKey
+fieldExpQTyConName      = libTc FSLIT("FieldExpQ")      fieldExpQTyConKey
 patQTyConName           = libTc FSLIT("PatQ")           patQTyConKey
 fieldPatQTyConName      = libTc FSLIT("FieldPatQ")      fieldPatQTyConKey
 
---	TyConUniques available: 100-119
+--	TyConUniques available: 100-129
 -- 	Check in PrelNames if you want to change this
 
 expTyConKey             = mkPreludeTyConUnique 100
@@ -1550,6 +1554,7 @@ fieldPatTyConKey        = mkPreludeTyConUnique 117
 nameTyConKey            = mkPreludeTyConUnique 118
 patQTyConKey            = mkPreludeTyConUnique 119
 fieldPatQTyConKey       = mkPreludeTyConUnique 120
+fieldExpQTyConKey       = mkPreludeTyConUnique 121
 
 -- 	IdUniques available: 200-399
 -- 	If you want to change this, make sure you check in PrelNames
diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 099dc5b..c1813e4 100644
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -823,7 +823,7 @@ objectTyConKey				= mkPreludeTyConUnique 83
 eitherTyConKey				= mkPreludeTyConUnique 84
 
 ---------------- Template Haskell -------------------
---	USES TyConUniques 100-119
+--	USES TyConUniques 100-129
 -----------------------------------------------------
 
 unitTyConKey = mkTupleTyConUnique Boxed 0
-- 
1.7.10.4