Refactor part of the renamer to fix Trac #3901

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

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 5d2b829..3bf030d 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -337,7 +337,7 @@ renameDeriv is_boot gen_binds insts
        ; let aux_binds = listToBag $ map (genAuxBind loc) $ 
                          rm_dups [] $ concat deriv_aux_binds
        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds [])
-       ; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs)
+       ; let aux_names = collectHsValBinders rn_aux_lhs
 
        ; bindLocalNames aux_names $ 
     do { (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
@@ -965,13 +965,25 @@ checkFlag flag (dflags, _)
                  other -> pprPanic "checkFlag" (ppr other)
 
 std_class_via_iso :: Class -> Bool
-std_class_via_iso clas -- These standard classes can be derived for a newtype
-                       -- using the isomorphism trick *even if no -fglasgow-exts*
+-- These standard classes can be derived for a newtype
+-- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
+-- because giving so gives the same results as generating the boilerplate
+std_class_via_iso clas 
   = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
        -- Not Read/Show because they respect the type
        -- Not Enum, because newtypes are never in Enum
 
 
+non_iso_class :: Class -> Bool
+-- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- even with -XGeneralizedNewtypeDeriving
+non_iso_class cls 
+  = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
+                        typeableClassKeys)
+
+typeableClassKeys :: [Unique]
+typeableClassKeys = map getUnique typeableClassNames
+
 new_dfun_name :: Class -> TyCon -> TcM Name
 new_dfun_name clas tycon       -- Just a simple wrapper
   = do { loc <- getSrcSpanM    -- The location of the instance decl, not of the tycon
@@ -1037,18 +1049,21 @@ mkNewTypeEqn orig dflags tvs
 
   | otherwise
   = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
-      CanDerive               -> go_for_it     -- Use the standard H98 method
-      DerivableClassError msg -> bale_out msg  -- Error with standard class
+      CanDerive -> go_for_it   -- Use the standard H98 method
+      DerivableClassError msg  -- Error with standard class
+        | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
+        | otherwise                  -> bale_out msg
       NonDerivableClass        -- Must use newtype deriving
-       | newtype_deriving    -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
-       | otherwise           -> bale_out non_std_err      -- Try newtype deriving!
+       | newtype_deriving           -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
+        | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
+       | otherwise                  -> bale_out non_std
   where
         newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
         go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
        bale_out msg     = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
 
-       non_std_err = nonStdErr cls $$
-                     ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
+       non_std    = nonStdErr cls
+        suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
 
        -- Here is the plan for newtype derivings.  We see
        --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
@@ -1132,10 +1147,6 @@ mkNewTypeEqn orig dflags tvs
           && ats_ok
 --        && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
 
-               -- Never derive Read,Show,Typeable,Data by isomorphism
-       non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
-                                                 typeableClassNames)
-
        arity_ok = length cls_tys + 1 == classArity cls
                -- Well kinded; eg not: newtype T ... deriving( ST )
                --                      because ST needs *2* type params