Fix #3319, and do various tidyups at the same time

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

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5303f9d..2de2cae 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -23,7 +23,7 @@
 
 module DsMeta( dsBracket, 
               templateHaskellNames, qTyConName, nameTyConName,
-              liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
+              liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
               quoteExpName, quotePatName
                ) where
@@ -333,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
+repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
  = do MkC name' <- lookupLOcc name
       MkC typ' <- repLTy typ
       MkC cc' <- repCCallConv cc
@@ -341,7 +341,6 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
       cis' <- conv_cimportspec cis
       MkC str <- coreStringLit $ static
                               ++ unpackFS ch ++ " "
-                              ++ unpackFS cn ++ " "
                               ++ cis'
       dec <- rep2 forImpDName [cc', s', str, name', typ']
       return (loc, dec)
@@ -358,7 +357,7 @@ repForD decl = notHandled "Foreign declaration" (ppr decl)
 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
 repCCallConv CCallConv = rep2 cCallName []
 repCCallConv StdCallConv = rep2 stdCallName []
-repCCallConv CmmCallConv = notHandled "repCCallConv" (ppr CmmCallConv)
+repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
 
 repSafety :: Safety -> DsM (Core TH.Safety)
 repSafety PlayRisky = rep2 unsafeName []
@@ -1757,12 +1756,13 @@ predTyConName     = thTc (fsLit "Pred")         predTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
-    mkNameLName :: Name
-returnQName   = thFun (fsLit "returnQ")   returnQIdKey
-bindQName     = thFun (fsLit "bindQ")     bindQIdKey
-sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
+    mkNameLName, liftStringName :: Name
+returnQName    = thFun (fsLit "returnQ")   returnQIdKey
+bindQName      = thFun (fsLit "bindQ")     bindQIdKey
+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
 newNameName    = thFun (fsLit "newName")   newNameIdKey
-liftName      = thFun (fsLit "lift")      liftIdKey
+liftName       = thFun (fsLit "lift")      liftIdKey
+liftStringName = thFun (fsLit "liftString")  liftStringIdKey
 mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
 mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
 mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
@@ -2053,6 +2053,9 @@ floatPrimLIdKey   = mkPreludeMiscIdUnique 215
 doublePrimLIdKey  = mkPreludeMiscIdUnique 216
 rationalLIdKey    = mkPreludeMiscIdUnique 217
 
+liftStringIdKey :: Unique
+liftStringIdKey     = mkPreludeMiscIdUnique 218
+
 -- data Pat = ...
 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
     asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
@@ -2081,6 +2084,7 @@ matchIdKey          = mkPreludeMiscIdUnique 231
 clauseIdKey :: Unique
 clauseIdKey         = mkPreludeMiscIdUnique 232
 
+
 -- data Exp = ...
 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,