Fix Trac #3966: warn about unused UNPACK pragmas

[ghc-hetmet.git] / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 049276d..1261131 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -37,7 +37,6 @@ import VarSet
 import Name
 import Outputable
 import Maybes
-import Monad
 import Unify
 import Util
 import SrcLoc
@@ -49,6 +48,7 @@ import Unique         ( mkBuiltinUnique )
 import BasicTypes
 
 import Bag
+import Control.Monad
 import Data.List
 \end{code}
 
@@ -249,8 +249,8 @@ tcFamInstDecl (L loc decl)
   =    -- Prime error recovery, set source location
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $
-    do { -- type families require -XTypeFamilies and can't be in an
-        -- hs-boot file
+    do { -- type family instances require -XTypeFamilies
+        -- and can't (currently) be in an hs-boot file
        ; type_families <- doptM Opt_TypeFamilies
        ; is_boot  <- tcIsHsBoot          -- Are we compiling an hs-boot file?
        ; checkTc type_families $ badFamInstDecl (tcdLName decl)
@@ -481,7 +481,7 @@ getInitialKind decl
        ; res_kind  <- mk_res_kind decl
        ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
   where
-    mk_arg_kind (UserTyVar _)        = newKindVar
+    mk_arg_kind (UserTyVar _ _)      = newKindVar
     mk_arg_kind (KindedTyVar _ kind) = return kind
 
     mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
@@ -513,7 +513,7 @@ kcSynDecl (AcyclicSCC (L loc decl))
                        <+> brackets (ppr k_tvs))
        ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
        ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
-       ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
+       ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
                 (unLoc (tcdLName decl), tc_kind)) })
 
@@ -521,10 +521,6 @@ kcSynDecl (CyclicSCC decls)
   = do { recSynErr decls; failM }      -- Fail here to avoid error cascade
                                        -- of out-of-scope tycons
 
-kindedTyVarKind :: LHsTyVarBndr Name -> Kind
-kindedTyVarKind (L _ (KindedTyVar _ k)) = k
-kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x)
-
 ------------------------------------------------------------------------
 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
        -- Not used for type synonyms (see kcSynDecl)
@@ -566,14 +562,16 @@ kcTyClDeclBody decl thing_inside
   = tcAddDeclCtxt decl         $
     do         { tc_ty_thing <- tcLookupLocated (tcdLName decl)
        ; let tc_kind    = case tc_ty_thing of
-                           AThing k -> k
-                           _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
+                             AThing k -> k
+                             _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
              (kinds, _) = splitKindFunTys tc_kind
              hs_tvs     = tcdTyVars decl
              kinded_tvs = ASSERT( length kinds >= length hs_tvs )
-                          [ L loc (KindedTyVar (hsTyVarName tv) k)
-                          | (L loc tv, k) <- zip hs_tvs kinds]
-       ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
+                          zipWith add_kind hs_tvs kinds
+       ; tcExtendKindEnvTvs kinded_tvs thing_inside }
+  where
+    add_kind (L loc (UserTyVar n _))   k = L loc (UserTyVar n k)
+    add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
 
 -- Kind check a data declaration, assuming that we already extended the
 -- kind environment with the type variables of the left-hand side (these
@@ -633,11 +631,13 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
                       -- default result kind is '*'
        }
   where
-    unifyClassParmKinds (L _ (KindedTyVar n k))
-      | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind
-      | otherwise                                   = return ()
-    unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x)
-    classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs]
+    unifyClassParmKinds (L _ tv) 
+      | (n,k) <- hsTyVarNameKind tv
+      , Just classParmKind <- lookup n classTyKinds 
+      = unifyKind k classParmKind
+      | otherwise = return ()
+    classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
+
 kcFamilyDecl _ (TySynonym {})              -- type family defaults
   = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
@@ -929,7 +929,8 @@ tcConArg :: Bool            -- True <=> -funbox-strict_fields
 tcConArg unbox_strict bty
   = do  { arg_ty <- tcHsBangType bty
        ; let bang = getBangStrictness bty
-       ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) }
+        ; strict_mark <- chooseBoxingStrategy unbox_strict arg_ty bang
+       ; return (arg_ty, strict_mark) }
 
 -- We attempt to unbox/unpack a strict field when either:
 --   (i)  The field is marked '!!', or
@@ -937,14 +938,16 @@ tcConArg unbox_strict bty
 --
 -- We have turned off unboxing of newtypes because coercions make unboxing 
 -- and reboxing more complicated
-chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark
+chooseBoxingStrategy :: Bool -> TcType -> HsBang -> TcM StrictnessMark
 chooseBoxingStrategy unbox_strict_fields arg_ty bang
   = case bang of
-       HsNoBang                                    -> NotMarkedStrict
+       HsNoBang                        -> return NotMarkedStrict
+       HsUnbox  | can_unbox arg_ty     -> return MarkedUnboxed
+                 | otherwise            -> do { addWarnTc cant_unbox_msg
+                                              ; return MarkedStrict }
        HsStrict | unbox_strict_fields 
-                   && can_unbox arg_ty                     -> MarkedUnboxed
-       HsUnbox  | can_unbox arg_ty                 -> MarkedUnboxed
-       _                                           -> MarkedStrict
+                 , can_unbox arg_ty    -> return MarkedUnboxed
+       _                               -> return MarkedStrict
   where
     -- we can unbox if the type is a chain of newtypes with a product tycon
     -- at the end
@@ -956,6 +959,8 @@ chooseBoxingStrategy unbox_strict_fields arg_ty bang
                        (if isNewTyCon arg_tycon then 
                             can_unbox (newTyConInstRhs arg_tycon tycon_args)
                         else True)
+
+    cant_unbox_msg = ptext (sLit "Ignoring unusable UNPACK pragma")
 \end{code}
 
 Note [Recursive unboxing]
@@ -1269,7 +1274,7 @@ mkRecSelBind (tycon, sel_name)
                         || dataConCannotMatch inst_tys con)
     inst_tys = tyConAppArgs data_ty
 
-    unit_rhs = L loc $ ExplicitTuple [] Boxed
+    unit_rhs = mkLHsTupleExpr []
     msg_lit = HsStringPrim $ mkFastString $ 
               occNameString (getOccName sel_name)