X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=126113168361bd1ab9de8ec9eebfaf2eef7c59d3;hb=60789c09584c8a12fa27289605221942fb05764d;hp=bc20d3d8d9bc90b6245ec89ac8498d2880e0bf9f;hpb=1e50fd4185479a62e02d987bdfcb1c62712859ca;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index bc20d3d..1261131 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -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]