X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=efc46cd34ff673d7609b0e2925825789d4921579;hb=27de38efce6d73d2a0209f803cfa98c82773e773;hp=7a2954a6d5a4307c9e459904c93667623ec928e4;hpb=9319fbaf14f420cbbd9e670093cc86c5f04b7800;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 7a2954a..efc46cd 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -269,7 +269,9 @@ tcDeriving tycl_decls inst_decls deriv_decls
   = recoverM (return ([], emptyValBindsOut)) $
     do	{   	-- Fish the "deriving"-related information out of the TcEnv
 		-- And make the necessary "equations".
-	; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
+	  is_boot <- tcIsHsBoot
+	; traceTc (text "tcDeriving" <+> ppr is_boot)
+	; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
 	; overlap_flag <- getOverlapFlag
 	; let (infer_specs, given_specs) = splitEithers early_specs
@@ -280,7 +282,6 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 	; insts2 <- mapM (genInst overlap_flag) final_specs
 
-	; is_boot <- tcIsHsBoot
 		 -- Generate the generic to/from functions from each type declaration
 	; gen_binds <- mkGenericBinds is_boot
 	; (inst_info, rn_binds) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
@@ -387,23 +388,37 @@ or} has just one data constructor (e.g., tuples).
 all those.
 
 \begin{code}
-makeDerivSpecs :: [LTyClDecl Name] 
+makeDerivSpecs :: Bool 
+	       -> [LTyClDecl Name] 
                -> [LInstDecl Name]
 	       -> [LDerivDecl Name] 
 	       -> TcM [EarlyDerivSpec]
 
-makeDerivSpecs tycl_decls inst_decls deriv_decls
-  = do	{ eqns1 <- mapAndRecoverM deriveTyData $
-                     extractTyDataPreds tycl_decls ++
-		     [ pd                        -- traverse assoc data families
-                     | L _ (InstDecl _ _ _ ats) <- inst_decls
-		     , pd <- extractTyDataPreds ats ]
+makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+  | is_boot 	-- No 'deriving' at all in hs-boot files
+  = do	{ mapM_ add_deriv_err deriv_locs 
+	; return [] }
+  | otherwise
+  = do	{ eqns1 <- mapAndRecoverM deriveTyData all_tydata
 	; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
 	; return (catMaybes (eqns1 ++ eqns2)) }
   where
-    extractTyDataPreds decls = 		   
-      [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
+    extractTyDataPreds decls
+      = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
+
+    all_tydata :: [(LHsType Name, LTyClDecl Name)]
+	-- Derived predicate paired with its data type declaration
+    all_tydata = extractTyDataPreds tycl_decls ++
+		 [ pd                -- Traverse assoc data families
+                 | L _ (InstDecl _ _ _ ats) <- inst_decls
+		 , pd <- extractTyDataPreds ats ]
+
+    deriv_locs = map (getLoc . snd) all_tydata
+		 ++ map getLoc deriv_decls
 
+    add_deriv_err loc = setSrcSpan loc $
+			addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
+				   2 (ptext (sLit "Use an instance declaration instead")))
 
 ------------------------------------------------------------------
 deriveStandalone :: LDerivDecl Name -> TcM (Maybe EarlyDerivSpec)
@@ -467,13 +482,17 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
 	          -- we want to check the instance tycon, not the family tycon
 
 	-- For standalone deriving (mtheta /= Nothing), 
-	-- check that all the data constructors are in scope
+	-- check that all the data constructors are in scope.
+	-- No need for this when deriving Typeable, becuase we don't need
+	-- the constructors for that.
 	-- By this time we know that the thing is algebraic
 	--	because we've called checkInstHead in derivingStandalone
 	; rdr_env <- getGlobalRdrEnv
 	; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc)
 	      not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
-	; checkTc (isNothing mtheta || not hidden_data_cons) 
+	; checkTc (isNothing mtheta || 
+	  	   not hidden_data_cons ||
+		   className cls `elem` typeableClassNames) 
 		  (derivingHiddenErr tycon)
 
 	; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
@@ -533,7 +552,7 @@ tcLookupFamInstExact tycon tys
 famInstNotFound :: TyCon -> [Type] -> TcM a
 famInstNotFound tycon tys 
   = failWithTc (ptext (sLit "No family instance for")
-			<+> quotes (pprTypeApp tycon (ppr tycon) tys))
+			<+> quotes (pprTypeApp tycon tys))
 \end{code}