[commit: ghc] ghc-7.6: Merge fix for #5252. (8b4fee3)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.6

http://hackage.haskell.org/trac/ghc/changeset/8b4fee353aa6bfcd08d7ea5ab8b8cc2b526e26f3

>---------------------------------------------------------------

commit 8b4fee353aa6bfcd08d7ea5ab8b8cc2b526e26f3
Author: Paolo Capriotti <[email protected]>
Date:   Tue Nov 6 14:14:06 2012 +0000

    Merge fix for #5252.
    
    Based on:
    
      commit 5bae803a18b17bdb158a7780e6b6ac3c520e5b39
      Author: Simon Peyton Jones <[email protected]>
      Date:   Sat Sep 15 23:09:25 2012 +0100
    
          Fix UNPACK with -fomit-interface-pragmas.
    
          We were missing a case, so that you could expose a constructor
          with UNPACKed fields, but the field tpye was trimmed, and hence
          can't be expanded.
    
          Fixes Trac #5252 (revived)

>---------------------------------------------------------------

 compiler/typecheck/TcTyClsDecls.lhs |   44 +++++++++++++++++++---------------
 1 files changed, 25 insertions(+), 19 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 9e1ced2..2d105d8 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1182,26 +1182,32 @@ conRepresentibleWithH98Syntax
 -- and reboxing more complicated
 chooseBoxingStrategy :: DynFlags -> TcType -> HsBang -> HsBang
 chooseBoxingStrategy dflags arg_ty bang
-  = case bang of
-	HsNoBang -> HsNoBang
-	HsStrict -> let unbox_strict = dopt Opt_UnboxStrictFields dflags
-                    in if unbox_strict then (can_unbox HsStrict arg_ty)
-                                       else HsStrict
-	HsNoUnpack -> HsStrict
-	HsUnpack -> let omit_prags = dopt Opt_OmitInterfacePragmas dflags
-                        bang = can_unbox HsUnpackFailed arg_ty
-                    in if omit_prags && bang == HsUnpack
-                       then HsStrict
-                       else bang
-            -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
-	    -- See Trac #5252: unpacking means we must not conceal the
-	    --                 representation of the argument type
-            -- However: even when OmitInterfacePragmas is on, we still want
-            -- to know if we have HsUnpackFailed, because we omit a
-            -- warning in that case (#3966)
-        HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
-		       	  -- Source code never has shtes
+  = case choice of
+      HsUnpack | dopt Opt_OmitInterfacePragmas dflags
+               -> return HsStrict
+      _other   -> return choice
   where
+    choice :: HsBang
+    choice = case bang of
+      HsNoBang -> HsNoBang
+      HsStrict -> let unbox_strict = dopt Opt_UnboxStrictFields dflags
+                  in if unbox_strict then (can_unbox HsStrict arg_ty)
+                                     else HsStrict
+      HsNoUnpack -> HsStrict
+      HsUnpack -> let omit_prags = dopt Opt_OmitInterfacePragmas dflags
+                      bang = can_unbox HsUnpackFailed arg_ty
+                  in if omit_prags && bang == HsUnpack
+                     then HsStrict
+                     else bang
+          -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
+          -- See Trac #5252: unpacking means we must not conceal the
+          --                 representation of the argument type
+          -- However: even when OmitInterfacePragmas is on, we still want
+          -- to know if we have HsUnpackFailed, because we omit a
+          -- warning in that case (#3966)
+      HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
+                        -- Source code never has shtes
+
     can_unbox :: HsBang -> TcType -> HsBang
     -- Returns   HsUnpack  if we can unpack arg_ty
     -- 		 fail_bang if we know what arg_ty is but we can't unpack it