From c92ad29760f7e307bade71ff51ca10563fd6d474 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 19 Jul 2004 11:29:39 +0000
Subject: [PATCH] [project @ 2004-07-19 11:29:34 by simonpj] Template Haskell
improvements
a) Make '() and '[] work.
b) Add tupleTypeName, tupleDataName
b) Try to improve error message for (lack of) existential data constructors in TH
---
ghc/compiler/deSugar/DsMeta.hs | 15 +++++++++++----
ghc/compiler/parser/Parser.y.pp | 2 +-
2 files changed, 12 insertions(+), 5 deletions(-)
diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 0f1ee5e9a452..23117b08412c 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -211,11 +211,10 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
return $ Just (loc, dec) }
-- Un-handled cases
-repTyClD (L loc d) = do { dsWarn (loc, hang msg 4 (ppr d)) ;
+repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ;
return Nothing
}
- where
- msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+
repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
= do { i <- addTyVarBinds tvs $ \tv_bndrs ->
@@ -266,15 +265,23 @@ repSafety PlayRisky = rep2 unsafeName []
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []
+ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+
-------------------------------------------------------
-- Constructors
-------------------------------------------------------
repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L loc (ConDecl con [] (L _ []) details))
- = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
+ = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
+repC (L loc con_decl)
+ = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
+ ; return (panic "DsMeta:repC") }
+ where
+
+
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy (L _ (BangType str ty)) = do
MkC s <- rep2 strName []
diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index 4f7890de998c..a5e5da4a4c92 100644
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -1076,7 +1076,7 @@ aexp2 :: { LHsExpr RdrName }
| '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp )
| TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) }
- | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) }
+ | TH_VAR_QUOTE gcon { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr (unLoc $2)) }
| '[|' exp '|]' { LL $ HsBracket (ExpBr $2) }
--
GitLab