[project @ 2006-01-06 16:30:17 by simonmar]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 9785cdb..fcbcc78 100644 (file)
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -30,16 +30,16 @@ 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
@@ -54,7 +54,7 @@ import Maybe    ( catMaybes )
 import Unique    ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
 import BasicTypes ( isBoxed ) 
 import Outputable
-import Bag       ( bagToList )
+import Bag       ( bagToList, unionManyBags )
 import FastString ( unpackFS )
 import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
 
@@ -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 ; 
@@ -697,8 +697,8 @@ repBinds (HsValBinds decs)
 
 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 -- Assumes: all the binders of the binding are alrady in the meta-env
-rep_val_binds (ValBindsIn binds sigs)
- = do { core1 <- rep_binds' binds
+rep_val_binds (ValBindsOut binds sigs)
+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))
       ;        core2 <- rep_sigs' sigs
       ;        return (core1 ++ core2) }
 
@@ -875,7 +875,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 +911,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
@@ -963,7 +963,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 +1390,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