Fix Trac #3831: blowup in SpecConstr

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

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d0d3f4c..902eeb8 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -338,10 +338,10 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
  where
     conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
-    conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
     conv_cimportspec CWrapper = return "wrapper"
     static = case cis of
-                 CFunction (StaticTarget _) -> "static "
+                 CFunction (StaticTarget _ _) -> "static "
                  _ -> ""
 repForD decl = notHandled "Foreign declaration" (ppr decl)
 
@@ -714,20 +714,26 @@ repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
                               ; e2 <- addBinds ss (repLE e)
                               ; z <- repLetE ds e2
                               ; wrapGenSyns ss z }
+
 -- FIXME: I haven't got the types here right yet
-repE (HsDo DoExpr sts body _) 
+repE e@(HsDo ctxt sts body _) 
+ | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
  = do { (ss,zs) <- repLSts sts; 
        body'   <- addBinds ss $ repLE body;
        ret     <- repNoBindSt body';   
-        e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
-        wrapGenSyns ss e }
-repE (HsDo ListComp sts body _)
+        e'      <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+        wrapGenSyns ss e' }
+
+ | ListComp <- ctxt
  = do { (ss,zs) <- repLSts sts; 
        body'   <- addBinds ss $ repLE body;
        ret     <- repNoBindSt body';   
-        e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
-        wrapGenSyns ss e }
-repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
+        e'      <- repComp (nonEmptyCoreList (zs ++ [ret]));
+        wrapGenSyns ss e' }
+
+  | otherwise
+  = 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) 
@@ -1013,7 +1019,9 @@ repP (BangPat p)       = do { p1 <- repLP p; repPbang 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 p@(TuplePat ps boxed _) 
+  | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
+  | otherwise           = do { qs <- repLPs ps; repPtup qs }
 repP (ConPatIn dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of