X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=88b0ba9c8e1b1df2e666a111da7782c7814e51cc;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=e13b06237021feb63aec4fc20fbd0c1199dd18c5;hpb=ea5ae017de01553bc808c2fa216218b9a13b51ef;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index e13b062..88b0ba9 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -30,20 +30,20 @@ import qualified Language.Haskell.TH as TH
 import HsSyn
 import Class (FunDep)
 import PrelNames  ( rationalTyConName, integerTyConName, negateName )
-import OccName	  ( isDataOcc, isTvOcc, occNameUserString )
+import OccName	  ( isDataOcc, isTvOcc, occNameString )
 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
 -- we do this by removing varName from the import of OccName above, making
 -- a qualified instance of OccName and using OccNameAlias.varName where varName
 -- ws previously used in this file.
 import qualified OccName
 
-import Module	  ( Module, mkModule, moduleUserString )
+import Module	  ( Module, mkModule, moduleString )
 import Id         ( Id, mkLocalId )
-import OccName	  ( mkOccFS )
+import OccName	  ( mkOccNameFS )
 import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule, 
 		    isExternalName, getSrcLoc )
 import NameEnv
-import Type       ( Type, mkGenTyConApp )
+import Type       ( Type, mkTyConApp )
 import TcType	  ( tcTyConAppArgs )
 import TyCon	  ( tyConName )
 import TysWiredIn ( parrTyCon )
@@ -285,18 +285,18 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L loc (ConDecl con [] (L _ []) details))
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
   = do { con1 <- lookupLOcc con ;		-- See note [Binders and occurrences] 
 	 repConstr con1 details }
-repC (L loc (ConDecl con tvs (L cloc ctxt) details))
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
   = do { addTyVarBinds tvs $ \bndrs -> do {
-             c' <- repC (L loc (ConDecl con [] (L cloc []) details));
+             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
              ctxt' <- repContext ctxt;
              bndrs' <- coreList nameTyConName bndrs;
              rep2 forallCName [unC bndrs', unC ctxt', unC c']
          }
        }
-repC (L loc con_decl)
+repC (L loc con_decl)		-- GADTs
   = putSrcSpanDs loc $ 
     do	{ dsWarn (hang ds_msg 4 (ppr con_decl))
 	; return (panic "DsMeta:repC") }
@@ -343,8 +343,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 	-- Singleton => Ok
 	-- Empty     => Too hard, signature ignored
-rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
-rep_sig other		    = return []
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other		        = return []
 
 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; 
@@ -715,7 +715,8 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- Note GHC treats declarations of a variable (not a pattern) 
 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match 
 -- with an empty list of patterns
-rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _) _))
+rep_bind (L loc (FunBind { fun_id = fn, 
+			   fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
  = do { (ss,wherecore) <- repBinds wheres
 	; guardcore <- addBinds ss (repGuards guards)
 	; fn'  <- lookupLBinder fn
@@ -724,13 +725,13 @@ rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards whe
 	; ans' <- wrapGenSyns ss ans
 	; return (loc, ans') }
 
-rep_bind (L loc (FunBind fn infx (MatchGroup ms _) _))
+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
  =   do { ms1 <- mapM repClauseTup ms
 	; fn' <- lookupLBinder fn
         ; ans <- repFun fn' (nonEmptyCoreList ms1)
         ; return (loc, ans) }
 
-rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2 _))
+rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
  =   do { patcore <- repLP pat 
         ; (ss,wherecore) <- repBinds wheres
 	; guardcore <- addBinds ss (repGuards guards)
@@ -738,7 +739,7 @@ rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2 _))
 	; ans' <- wrapGenSyns ss ans
         ; return (loc, ans') }
 
-rep_bind (L loc (VarBind v e))
+rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
  =   do { v' <- lookupBinder v 
 	; e2 <- repLE e
         ; x <- repNormal e2
@@ -798,14 +799,14 @@ repLP :: LPat Name -> DsM (Core TH.PatQ)
 repLP (L _ p) = repP p
 
 repP :: Pat Name -> DsM (Core TH.PatQ)
-repP (WildPat _)     = repPwild 
-repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
-repP (LazyPat p)     = do { p1 <- repLP p; repPtilde p1 }
-repP (AsPat x p)     = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
-repP (ParPat p)      = repLP p 
-repP (ListPat ps _)  = do { qs <- repLPs ps; repPlist qs }
-repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs }
+repP (WildPat _)       = repPwild 
+repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
+repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
+repP (ParPat p)        = repLP p 
+repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
+repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
 repP (ConPatIn dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of
@@ -875,7 +876,7 @@ lookupBinder n
   = do { mb_val <- dsLookupMetaEnv n;
 	 case mb_val of
 	    Just (Bound x) -> return (coreVar x)
-	    other	   -> pprPanic "Failed binder lookup:" (ppr n) }
+	    other	   -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
 
 -- Look up a name that is either locally bound or a global name
 --
@@ -911,7 +912,7 @@ globalVar name
 	; MkC uni <- coreIntLit (getKey (getUnique name))
 	; rep2 mkNameLName [occ,uni] }
   where
-      name_mod = moduleUserString (nameModule name)
+      name_mod = moduleString (nameModule name)
       name_occ = nameOccName name
       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
 	      | OccName.isVarOcc  name_occ = mkNameG_vName
@@ -921,7 +922,7 @@ globalVar name
 lookupType :: Name 	-- Name of type constructor (e.g. TH.ExpQ)
 	   -> DsM Type	-- The type
 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
-		          return (mkGenTyConApp tc []) }
+		          return (mkTyConApp tc []) }
 
 wrapGenSyns :: [GenSymBind] 
 	    -> Core (TH.Q a) -> DsM (Core (TH.Q a))
@@ -963,7 +964,7 @@ wrapNongenSyms binds (MkC body)
 	     ; return (NonRec id var) }
 
 occNameLit :: Name -> DsM (Core String)
-occNameLit n = coreStringLit (occNameUserString (nameOccName n))
+occNameLit n = coreStringLit (occNameString (nameOccName n))
 
 
 -- %*********************************************************************
@@ -1390,7 +1391,7 @@ thSyn = mkModule "Language.Haskell.TH.Syntax"
 thLib = mkModule "Language.Haskell.TH.Lib"
 
 mk_known_key_name mod space str uniq 
-  = mkExternalName uniq mod (mkOccFS space str) 
+  = mkExternalName uniq mod (mkOccNameFS space str) 
 	           Nothing noSrcLoc
 
 libFun = mk_known_key_name thLib OccName.varName