X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FdeSugar%2FDsMeta.hs;h=411da4074c79e0f552beeecddb6ddb3f1312e81d;hb=58521c72cec262496dabf5fffb057d25ab17a0f7;hp=5303f9d75319c66884262b74290924d37ba86f19;hpb=9f55c592f7283e5d16dd406c767af352adf30bfc;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5303f9d..411da40 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -13,17 +13,9 @@
 -- a Royal Pain (triggers other recompilation).
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fno-warn-unused-imports #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
--- The kludge is only needed in this module because of trac #2267.
-
 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
@@ -33,7 +25,6 @@ module DsMeta( dsBracket,
 import {-# SOURCE #-}	DsExpr ( dsExpr )
 
 import MatchLit
-import DsUtils
 import DsMonad
 
 import qualified Language.Haskell.TH as TH
@@ -333,7 +324,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 +332,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 +348,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 []
@@ -373,14 +363,14 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L _ (ConDecl con _ [] (L _ []) details ResTyH98 _))
+repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
+     	           , con_details = details, con_res = ResTyH98 }))
   = do { con1 <- lookupLOcc con 	-- See note [Binders and occurrences] 
        ; repConstr con1 details 
        }
-repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
+repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
   = addTyVarBinds tvs $ \bndrs -> 
-      do { c' <- repC (L loc (ConDecl con expl [] (L cloc []) details 
-                                      ResTyH98 doc))
+      do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
          ; ctxt' <- repContext ctxt
          ; bndrs' <- coreList tyVarBndrTyConName bndrs
          ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
@@ -722,8 +712,10 @@ repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
 repE e@(ExplicitTuple es boxed) 
-  | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
-  | otherwise		  = notHandled "Unboxed tuples" (ppr e)
+  | not (isBoxed boxed)        = notHandled "Unboxed tuples" (ppr e)
+  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
+  | otherwise                  = do { xs <- repLEs [e | Present e <- es]; repTup xs }
+
 repE (RecordCon c _ flds)
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
@@ -1757,12 +1749,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 +2046,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 +2077,7 @@ matchIdKey          = mkPreludeMiscIdUnique 231
 clauseIdKey :: Unique
 clauseIdKey         = mkPreludeMiscIdUnique 232
 
+
 -- data Exp = ...
 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,