X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=ea38b34d04517c28bfc7c1907bdeb2fa2148cebc;hb=45b7ef25fe0bdab56b817d17f24db0e725cc7688;hp=e4d66a612aaf89de94dcdbb75eff324dddd2ae76;hpb=54ef1c3c9ef6cecd968d5c1ed6ded3a1a201a870;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index e4d66a6..ea38b34 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)
@@ -307,8 +308,8 @@ renameDeriv is_boot gen_binds insts
 
   | otherwise
   = discardWarnings $ 	 -- Discard warnings about unused bindings etc
-    do	{ (rn_gen, dus_gen) <- setOptM Opt_PatternSignatures $	-- Type signatures in patterns 
-								-- are used in the generic binds
+    do	{ (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $  -- Type signatures in patterns 
+								  -- are used in the generic binds
 			       rnTopBinds (ValBindsIn gen_binds [])
 	; keepAliveSetTc (duDefs dus_gen)	-- Mark these guys to be kept alive
 
@@ -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)
@@ -537,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}