Fix Trac #3012: allow more free-wheeling in standalone deriving
[ghc-hetmet.git] / compiler / typecheck / TcDeriv.lhs
index 54ffe6b..a24f147 100644 (file)
@@ -257,7 +257,12 @@ There may be a coercion needed which we get from the tycon for the newtype
 when the dict is constructed in TcInstDcls.tcInstDecl2
 
 
-
+Note [Unused constructors and deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #3221.  Consider
+   data T = T1 | T2 deriving( Show )
+Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
+both of them.  So we gather defs/uses from deriving just like anything else.
 
 %************************************************************************
 %*                                                                     *
@@ -270,10 +275,11 @@ tcDeriving  :: [LTyClDecl Name]  -- All type constructors
             -> [LInstDecl Name]  -- All instance declarations
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
            -> TcM ([InstInfo Name],    -- The generated "instance decls"
-                   HsValBinds Name)    -- Extra generated top-level bindings
+                   HsValBinds Name,    -- Extra generated top-level bindings
+                    DefUses)
 
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (return ([], emptyValBindsOut)) $
+  = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
     do {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
          is_boot <- tcIsHsBoot
@@ -282,22 +288,22 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
        ; overlap_flag <- getOverlapFlag
        ; let (infer_specs, given_specs) = splitEithers early_specs
-       ; insts1 <- mapM (genInst overlap_flag) given_specs
+       ; insts1 <- mapM (genInst True overlap_flag) given_specs
 
        ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
                         inferInstanceContexts overlap_flag infer_specs
 
-       ; insts2 <- mapM (genInst overlap_flag) final_specs
+       ; insts2 <- mapM (genInst False overlap_flag) final_specs
 
                 -- 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)
+       ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
 
        ; dflags <- getDOpts
        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
                 (ddump_deriving inst_info rn_binds))
 
-       ; return (inst_info, rn_binds) }
+       ; return (inst_info, rn_binds, rn_dus) }
   where
     ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
     ddump_deriving inst_infos extra_binds
@@ -305,13 +311,13 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 renameDeriv :: Bool -> LHsBinds RdrName
            -> [(InstInfo RdrName, DerivAuxBinds)]
-           -> TcM ([InstInfo Name], HsValBinds Name)
+           -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
 renameDeriv is_boot gen_binds insts
   | is_boot    -- If we are compiling a hs-boot file, don't generate any derived bindings
                -- The inst-info bindings will all be empty, but it's easier to
                -- just use rn_inst_info to change the type appropriately
-  = do { rn_inst_infos <- mapM rn_inst_info inst_infos 
-       ; return (rn_inst_infos, emptyValBindsOut) }
+  = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos  
+       ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
 
   | otherwise
   = discardWarnings $   -- Discard warnings about unused bindings etc
@@ -330,9 +336,10 @@ renameDeriv is_boot gen_binds insts
        ; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs)
 
        ; bindLocalNames aux_names $ 
-    do { (rn_aux, _dus) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
-       ; rn_inst_infos <- mapM rn_inst_info inst_infos
-       ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen) } }
+    do { (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
+       ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
+       ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
+                  dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
 
   where
     (inst_infos, deriv_aux_binds) = unzip insts
@@ -344,15 +351,16 @@ renameDeriv is_boot gen_binds insts
 
 
     rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
-       = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
+       = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs)
 
-    rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs })
+    rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
        =       -- Bring the right type variables into 
                -- scope (yuk), and rename the method binds
           ASSERT( null sigs )
           bindLocalNames (map Var.varName tyvars) $
-          do { (rn_binds, _fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
-             ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }) }
+          do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+             ; let binds' = VanillaInst rn_binds [] standalone_deriv
+             ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
        where
          (tyvars,_,clas,_) = instanceHead inst
          clas_nm           = className clas
@@ -644,12 +652,14 @@ mkDataTypeEqn :: InstOrigin
 
 mkDataTypeEqn orig dflags tvs cls cls_tys
               tycon tc_args rep_tc rep_tc_args mtheta
-  = case checkSideConditions dflags cls cls_tys rep_tc of
-       -- NB: pass the *representation* tycon to checkSideConditions
-       CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
-       NonDerivableClass       -> bale_out (nonStdErr cls)
-       DerivableClassError msg -> bale_out msg
+  | isJust mtheta = go_for_it  -- Do not test side conditions for standalone deriving
+  | otherwise     = case checkSideConditions dflags cls cls_tys rep_tc of
+                     -- NB: pass the *representation* tycon to checkSideConditions
+                     CanDerive               -> go_for_it
+                     NonDerivableClass       -> bale_out (nonStdErr cls)
+                     DerivableClassError msg -> bale_out msg
   where
+    go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
     bale_out msg = failWithTc (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) msg)
 
 mk_data_eqn, mk_typeable_eqn
@@ -794,11 +804,15 @@ sideConditions cls
   | cls_key == enumClassKey               = Just (cond_std `andCond` cond_isEnumeration)
   | cls_key == ixClassKey                 = Just (cond_std `andCond` cond_enumOrProduct)
   | cls_key == boundedClassKey            = Just (cond_std `andCond` cond_enumOrProduct)
-  | cls_key == dataClassKey               = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
-  | cls_key == functorClassKey            = Just (cond_functorOK True)  -- NB: no cond_std!
-  | cls_key == foldableClassKey           = Just (cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
-  | cls_key == traversableClassKey = Just (cond_functorOK False)
-  | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
+  | cls_key == dataClassKey               = Just (checkFlag Opt_DeriveDataTypeable `andCond` 
+                                           cond_std `andCond` cond_noUnliftedArgs)
+  | cls_key == functorClassKey            = Just (checkFlag Opt_DeriveFunctor `andCond`
+                                          cond_functorOK True)  -- NB: no cond_std!
+  | cls_key == foldableClassKey           = Just (checkFlag Opt_DeriveFoldable `andCond`
+                                          cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
+  | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
+                                          cond_functorOK False)
+  | getName cls `elem` typeableClassNames = Just (checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK)
   | otherwise = Nothing
   where
     cls_key = getUnique cls
@@ -929,12 +943,16 @@ cond_functorOK allowFunctions (dflags, rep_tc)
     functions  = ptext (sLit "contains function types")
     wrong_arg  = ptext (sLit "uses the type variable in an argument other than the last")
 
-cond_mayDeriveDataTypeable :: Condition
-cond_mayDeriveDataTypeable (dflags, _)
- | dopt Opt_DeriveDataTypeable dflags = Nothing
- | otherwise = Just why
+checkFlag :: DynFlag -> Condition
+checkFlag flag (dflags, _)
+  | dopt flag dflags = Nothing
+  | otherwise        = Just why
   where
-    why  = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
+    why = ptext (sLit "You need -X") <> text flag_str 
+          <+> ptext (sLit "to derive an instance for this class")
+    flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
+                 [s]   -> s
+                 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
@@ -1007,18 +1025,18 @@ mkNewTypeEqn orig dflags tvs
        ; return (if isJust mtheta then Right spec
                                   else Left spec) }
 
+  | isJust mtheta = go_for_it  -- Do not check side conditions for standalone deriving
   | otherwise
-  = case check_conditions of
-      CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
-                               -- Use the standard H98 method
-      DerivableClassError msg -> bale_out msg             -- Error with standard class
+  = case checkSideConditions dflags cls cls_tys rep_tycon of
+      CanDerive               -> go_for_it     -- Use the standard H98 method
+      DerivableClassError msg -> bale_out msg  -- Error with standard class
       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!
   where
         newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
-       check_conditions = checkSideConditions dflags cls cls_tys rep_tycon
-       bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
+        go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
+       bale_out msg     = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
 
        non_std_err = nonStdErr cls $$
                      ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
@@ -1332,26 +1350,25 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
-genInst oflag spec
+genInst :: Bool        -- True <=> standalone deriving
+       -> OverlapFlag
+        -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
+genInst standalone_deriv oflag spec
   | ds_newtype spec
   = return (InstInfo { iSpec  = mkInstance oflag (ds_theta spec) spec
                     , iBinds = NewTypeDerived co }, [])
 
   | otherwise
-  = do { let loc        = getSrcSpan (ds_name spec)
-             inst       = mkInstance oflag (ds_theta spec) spec
-             clas       = ds_cls spec
+  = do { let loc  = getSrcSpan (ds_name spec)
+             inst = mkInstance oflag (ds_theta spec) spec
+             clas = ds_cls spec
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)
        ; fix_env <- getFixityEnv
        ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
-
-       -- Build the InstInfo
-       ; return (InstInfo { iSpec = inst, 
-                            iBinds = VanillaInst meth_binds [] },
-                 aux_binds)
+             binds = VanillaInst meth_binds [] standalone_deriv
+       ; return (InstInfo { iSpec = inst, iBinds = binds }, aux_binds)
         }
   where
     rep_tycon   = ds_tc spec