[project @ 2003-07-29 10:14:57 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcDeriv.lhs
index 6221930..60b7b2f 100644 (file)
@@ -10,10 +10,10 @@ module TcDeriv ( tcDeriving ) where
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsBinds(..), MonoBinds(..), TyClDecl(..),
-                         collectMonoBinders )
+import HsSyn           ( HsBinds(..), TyClDecl(..), MonoBinds(..),
+                         andMonoBindList, collectMonoBinders )
 import RdrHsSyn                ( RdrNameMonoBinds )
-import RnHsSyn         ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred )
+import RnHsSyn         ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred )
 import CmdLineOpts     ( DynFlag(..) )
 
 import TcRnMonad
@@ -27,7 +27,7 @@ import TcMonoType     ( tcHsPred )
 import TcSimplify      ( tcSimplifyDeriv )
 
 import RnBinds         ( rnMethodBinds, rnTopMonoBinds )
-import RnEnv           ( bindLocalsFV )
+import RnEnv           ( bindLocalsFV, extendTyVarEnvFVRn )
 import TcRnMonad       ( thenM, returnM, mapAndUnzipM )
 import HscTypes                ( DFunId )
 
@@ -36,20 +36,22 @@ import Class                ( className, classArity, classKey, classTyVars, classSCTheta, Clas
 import Subst           ( mkTyVarSubst, substTheta )
 import ErrUtils                ( dumpIfSet_dyn )
 import MkId            ( mkDictFunId )
-import DataCon         ( dataConRepArgTys, dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon )
+import DataCon         ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon )
 import Maybes          ( maybeToBool, catMaybes )
-import Name            ( Name, getSrcLoc, nameUnique )
+import Name            ( Name, getSrcLoc )
+import Unique          ( Unique, getUnique )
 import NameSet
 import RdrName         ( RdrName )
 
 import TyCon           ( tyConTyVars, tyConDataCons, tyConArity, 
-                         tyConTheta, maybeTyConSingleCon, isDataTyCon,
+                         tyConTheta, isProductTyCon, isDataTyCon,
                          isEnumerationTyCon, isRecursiveTyCon, TyCon
                        )
-import TcType          ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
-                         isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, 
-                         tcEqTypes, tcSplitAppTys, mkAppTys )
-import Var             ( TyVar, tyVarKind )
+import TcType          ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp, 
+                         getClassPredTys_maybe,
+                         isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, isTypeKind,
+                         tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy )
+import Var             ( TyVar, tyVarKind, idType, varName )
 import VarSet          ( mkVarSet, subVarSet )
 import PrelNames
 import Util            ( zipWithEqual, sortLt, notNull )
@@ -245,35 +247,47 @@ deriveOrdinaryStuff eqns
 
     let
        extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
-       extra_mbinds     = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
+       extra_mbinds     = andMonoBindList extra_mbind_list
        mbinders         = collectMonoBinders extra_mbinds
     in
-    mappM gen_bind new_dfuns           `thenM` \ method_binds_s ->
+    mappM gen_bind new_dfuns           `thenM` \ rdr_name_inst_infos ->
        
-    traceTc (text "tcDeriv" <+> ppr method_binds_s)    `thenM_`
-    getModule                                          `thenM` \ this_mod ->
+    traceTc (text "tcDeriv" <+> vcat (map ppr rdr_name_inst_infos))    `thenM_`
+    getModule                          `thenM` \ this_mod ->
     initRn (InterfaceMode this_mod) (
        -- Rename to get RenamedBinds.
        -- The only tricky bit is that the extra_binds must scope 
        -- over the method bindings for the instances.
        bindLocalsFV (ptext (SLIT("deriving"))) mbinders        $ \ _ ->
        rnTopMonoBinds extra_mbinds []                  `thenM` \ (rn_extra_binds, dus) ->
-       mapAndUnzipM rn_meths method_binds_s            `thenM` \ (rn_method_binds_s, fvs_s) ->
-       returnM ((rn_method_binds_s, rn_extra_binds), 
-                 duUses dus `plusFV` plusFVs fvs_s)
-    )                          `thenM` \ ((rn_method_binds_s, rn_extra_binds), fvs) ->
-    let
-       new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s
-    in
-    returnM (new_inst_infos, rn_extra_binds, fvs)
 
-  where
-       -- Make a Real dfun instead of the dummy one we have so far
-    gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
-    gen_inst_info dfun binds
-      = InstInfo { iDFunId = dfun, iBinds = VanillaInst binds [] }
+       mapAndUnzipM rn_inst_info rdr_name_inst_infos   `thenM` \ (pairs, fvs_s) ->
 
-    rn_meths (cls, meths) = rnMethodBinds cls [] meths
+       let
+          (rn_inst_infos, aux_binds_s) = unzip pairs
+          all_binds = rn_extra_binds `ThenBinds` foldr ThenBinds EmptyBinds aux_binds_s
+       in
+       returnM ((rn_inst_infos, all_binds),
+                duUses dus `plusFV` plusFVs fvs_s)
+    )                          `thenM` \ ((rn_inst_infos, rn_extra_binds), fvs) ->
+   returnM (rn_inst_infos, rn_extra_binds, fvs)
+
+  where
+    rn_inst_info (dfun, (meth_binds, aux_binds)) 
+       =       -- Rename the auxiliary bindings
+         bindLocalsFV (ptext (SLIT("deriving"))) mbinders      $ \ _ ->
+         rnTopMonoBinds aux_binds []                   `thenM` \ (rn_aux_binds, dus) ->
+
+               -- Bring the right type variables into scope
+         extendTyVarEnvFVRn (map varName tyvars)       $
+         rnMethodBinds (className cls) [] meth_binds   `thenM` \ (rn_meth_binds, fvs) ->
+
+         return ((InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, 
+                  rn_aux_binds), 
+                 duUses dus `plusFV` fvs)
+       where
+         mbinders = collectMonoBinders aux_binds
+         (tyvars, _, cls, _) = tcSplitDFunTy (idType dfun)
 \end{code}
 
 
@@ -329,11 +343,12 @@ makeDerivEqns tycl_decls
         tcHsPred pred                          `thenM` \ pred' ->
        case getClassPredTys_maybe pred' of
           Nothing          -> bale_out (malformedPredErr tycon pred)
-          Just (clas, tys) -> mk_eqn_help new_or_data tycon clas tys
+          Just (clas, tys) -> doptM Opt_GlasgowExts                    `thenM` \ gla_exts ->
+                              mk_eqn_help gla_exts new_or_data tycon clas tys
 
     ------------------------------------------------------------------
-    mk_eqn_help DataType tycon clas tys
-      | Just err <- chk_out clas tycon tys
+    mk_eqn_help gla_exts DataType tycon clas tys
+      | Just err <- checkSideConditions gla_exts clas tycon tys
       = bale_out (derivingThingErr clas tys tycon tyvars err)
       | otherwise 
       = new_dfun_name clas tycon        `thenM` \ dfun_name ->
@@ -341,38 +356,44 @@ makeDerivEqns tycl_decls
       where
        tyvars    = tyConTyVars tycon
        data_cons = tyConDataCons tycon
-       constraints = extra_constraints ++ 
-                     [ mkClassPred clas [arg_ty] 
-                     | data_con <- tyConDataCons tycon,
-                       arg_ty   <- dataConRepArgTys data_con,          -- dataConOrigArgTys???
-                               -- Use the same type variables
-                               -- as the type constructor,
-                               -- hence no need to instantiate
-                       not (isUnLiftedType arg_ty)     -- No constraints for unlifted types?
-                     ]
-
-        -- "extra_constraints": see note [Data decl contexts] above
+       constraints = extra_constraints ++ ordinary_constraints
+                -- "extra_constraints": see note [Data decl contexts] above
        extra_constraints = tyConTheta tycon
 
-    mk_eqn_help NewType tycon clas tys
-      =        doptM Opt_GlasgowExts                   `thenM` \ gla_exts ->
-        if can_derive_via_isomorphism && (gla_exts || standard_instance) then
-               -- Go ahead and use the isomorphism
+       ordinary_constraints
+         | clas `hasKey` typeableClassKey      -- For the Typeable class, the constraints
+                                               -- don't involve the constructor ags, only 
+                                               -- the tycon tyvars
+                                               -- e.g.   data T a b = ...
+                                               -- we want
+                                               --      instance (Typeable a, Typable b)
+                                               --               => Typeable (T a b) where
+         = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
+         | otherwise
+         = [ mkClassPred clas [arg_ty] 
+           | data_con <- tyConDataCons tycon,
+             arg_ty   <- dataConOrigArgTys data_con,
+                       -- Use the same type variables
+                       -- as the type constructor,
+                       -- hence no need to instantiate
+             not (isUnLiftedType arg_ty)       -- No constraints for unlifted types?
+           ]
+
+    mk_eqn_help gla_exts NewType tycon clas tys
+      | can_derive_via_isomorphism && (gla_exts || standard_class gla_exts clas)
+      =                -- Go ahead and use the isomorphism
           traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)     `thenM_`
                   new_dfun_name clas tycon             `thenM` \ dfun_name ->
           returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name,
                                              iBinds = NewTypeDerived rep_tys }))
-       else
-       if standard_instance then
-               mk_eqn_help DataType tycon clas []      -- Go via bale-out route
-       else
-       -- Non-standard instance
-       if gla_exts then
-               -- Too hard
-               bale_out cant_derive_err
-       else
-               -- Just complain about being a non-std instance
-               bale_out non_std_err
+      | standard_class gla_exts clas
+      = mk_eqn_help gla_exts DataType tycon clas tys   -- Go via bale-out route
+
+      | otherwise                              -- Non-standard instance
+      = bale_out (if gla_exts then     
+                       cant_derive_err -- Too hard
+                 else
+                       non_std_err)    -- Just complain about being a non-std instance
       where
        -- Here is the plan for newtype derivings.  We see
        --        newtype T a1...an = T (t ak...an) deriving (.., C s1 .. sm, ...)
@@ -457,17 +478,18 @@ makeDerivEqns tycl_decls
        -------------------------------------------------------------------
        --  Figuring out whether we can only do this newtype-deriving thing
 
-       standard_instance = null tys && classKey clas `elem` derivableClassKeys
+       right_arity = length tys + 1 == classArity clas
 
+               -- Never derive Read,Show,Typeable,Data this way 
+       non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
        can_derive_via_isomorphism
-          =  not (clas `hasKey` readClassKey)  -- Never derive Read,Show this way
-          && not (clas `hasKey` showClassKey)
-          && length tys + 1 == classArity clas -- Well kinded;
+          =  not (getUnique clas `elem` non_iso_classes)
+          && right_arity                       -- Well kinded;
                                                -- eg not: newtype T ... deriving( ST )
                                                --      because ST needs *2* type params
-          && n_tyvars_to_keep >= 0             -- Well kinded; 
+          && n_tyvars_to_keep >= 0             -- Type constructor has right kind:
                                                -- eg not: newtype T = T Int deriving( Monad )
-          && n_args_to_keep   >= 0             -- Well kinded: 
+          && n_args_to_keep   >= 0             -- Rep type has right kind: 
                                                -- eg not: newtype T a = T Int deriving( Monad )
           && eta_ok                            -- Eta reduction works
           && not (isRecursiveTyCon tycon)      -- Does not work for recursive tycons:
@@ -475,6 +497,11 @@ makeDerivEqns tycl_decls
                                                -- Don't want
                                                --      instance Eq [A] => Eq A !!
 
+                       -- Here's a recursive newtype that's actually OK
+                       --      newtype S1 = S1 [T1 ()]
+                       --      newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
+                       -- It's currently rejected.  Oh well.
+
        -- Check that eta reduction is OK
        --      (a) the dropped-off args are identical
        --      (b) the remaining type args mention 
@@ -483,10 +510,20 @@ makeDerivEqns tycl_decls
              && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) 
 
        cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
-                               (vcat [ptext SLIT("too hard for cunning newtype deriving"),
-                                      ptext SLIT("debug info:") <+> ppr n_tyvars_to_keep <+>
-                                       ppr n_args_to_keep <+> ppr eta_ok <+>
-                                       ppr (isRecursiveTyCon tycon)
+                               (vcat [ptext SLIT("even with cunning newtype deriving:"),
+                                       if isRecursiveTyCon tycon then
+                                         ptext SLIT("the newtype is recursive")
+                                       else empty,
+                                       if not right_arity then 
+                                         quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("does not have arity 1")
+                                       else empty,
+                                       if not (n_tyvars_to_keep >= 0) then 
+                                         ptext SLIT("the type constructor has wrong kind")
+                                       else if not (n_args_to_keep >= 0) then
+                                         ptext SLIT("the representation type has wrong kind")
+                                       else if not eta_ok then 
+                                         ptext SLIT("the eta-reduction property does not hold")
+                                       else empty
                                      ])
 
        non_std_err = derivingThingErr clas tys tycon tyvars_to_keep
@@ -494,38 +531,102 @@ makeDerivEqns tycl_decls
                                       ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")])
 
     bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing) 
-
-    ------------------------------------------------------------------
-    chk_out :: Class -> TyCon -> [TcType] -> Maybe SDoc
-    chk_out clas tycon tys
-       | notNull tys                                                   = Just ty_args_why
-       | not (getUnique clas `elem` derivableClassKeys)                = Just (non_std_why clas)
-       | clas `hasKey` enumClassKey    && not is_enumeration           = Just nullary_why
-       | clas `hasKey` boundedClassKey && not is_enumeration_or_single = Just single_nullary_why
-       | clas `hasKey` ixClassKey      && not is_enumeration_or_single = Just single_nullary_why
-       | null data_cons                                                = Just no_cons_why
-       | any isExistentialDataCon data_cons                            = Just existential_why     
-       | otherwise                                                     = Nothing
+    standard_class gla_exts clas =  key `elem` derivableClassKeys
+                                || (gla_exts && (key == typeableClassKey || key == dataClassKey))
        where
-           data_cons = tyConDataCons tycon
-           is_enumeration = isEnumerationTyCon tycon
-           is_single_con  = maybeToBool (maybeTyConSingleCon tycon)
-           is_enumeration_or_single = is_enumeration || is_single_con
+         key = classKey clas
 
-           single_nullary_why = ptext SLIT("one constructor data type or type with all nullary constructors expected")
-           nullary_why        = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors")
-           no_cons_why        = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
-           ty_args_why        = quotes (ppr pred) <+> ptext SLIT("is not a class")
-           existential_why    = quotes (ppr tycon) <+> ptext SLIT("has existentially-quantified constructor(s)")
 
-           pred = mkClassPred clas tys
 
-non_std_why clas = quotes (ppr clas) <+> ptext SLIT("is not a derivable class")
 
 new_dfun_name clas tycon       -- Just a simple wrapper
   = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
        -- The type passed to newDFunName is only used to generate
        -- a suitable string; hence the empty type arg list
+
+
+------------------------------------------------------------------
+-- Check side conditions that dis-allow derivability for particular classes
+-- This is *apart* from the newtype-deriving mechanism
+
+checkSideConditions :: Bool -> Class -> TyCon -> [TcType] -> Maybe SDoc
+checkSideConditions gla_exts clas tycon tys
+  | notNull tys        
+  = Just ty_args_why   -- e.g. deriving( Foo s )
+  | otherwise
+  = case [cond | (key,cond) <- sideConditions, key == getUnique clas] of
+       []     -> Just (non_std_why clas)
+       [cond] -> cond (gla_exts, tycon)
+       other  -> pprPanic "checkSideConditions" (ppr clas)
+  where
+    ty_args_why             = quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("is not a class")
+
+non_std_why clas = quotes (ppr clas) <+> ptext SLIT("is not a derivable class")
+
+sideConditions :: [(Unique, Condition)]
+sideConditions
+  = [  (eqClassKey,       cond_std),
+       (ordClassKey,      cond_std),
+       (readClassKey,     cond_std),
+       (showClassKey,     cond_std),
+       (enumClassKey,     cond_std `andCond` cond_isEnumeration),
+       (ixClassKey,       cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
+       (boundedClassKey,  cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
+       (typeableClassKey, cond_glaExts `andCond` cond_allTypeKind),
+       (dataClassKey,     cond_glaExts `andCond` cond_std)
+    ]
+
+type Condition = (Bool, TyCon) -> Maybe SDoc   -- Nothing => OK
+
+orCond :: Condition -> Condition -> Condition
+orCond c1 c2 tc 
+  = case c1 tc of
+       Nothing -> Nothing              -- c1 succeeds
+       Just x  -> case c2 tc of        -- c1 fails
+                    Nothing -> Nothing
+                    Just y  -> Just (x $$ ptext SLIT("  and") $$ y)
+                                       -- Both fail
+
+andCond c1 c2 tc = case c1 tc of
+                    Nothing -> c2 tc   -- c1 succeeds
+                    Just x  -> Just x  -- c1 fails
+
+cond_std :: Condition
+cond_std (gla_exts, tycon)
+  | any isExistentialDataCon data_cons         = Just existential_why     
+  | null data_cons                     = Just no_cons_why
+  | otherwise                          = Nothing
+  where
+    data_cons       = tyConDataCons tycon
+    no_cons_why            = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
+    existential_why = quotes (ppr tycon) <+> ptext SLIT("has existentially-quantified constructor(s)")
+  
+cond_isEnumeration :: Condition
+cond_isEnumeration (gla_exts, tycon)
+  | isEnumerationTyCon tycon = Nothing
+  | otherwise               = Just why
+  where
+    why = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors")
+
+cond_isProduct :: Condition
+cond_isProduct (gla_exts, tycon)
+  | isProductTyCon tycon = Nothing
+  | otherwise           = Just why
+  where
+    why = quotes (ppr tycon) <+> ptext SLIT("has more than one constructor")
+
+cond_allTypeKind :: Condition
+cond_allTypeKind (gla_exts, tycon)
+  | all (isTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing
+  | otherwise                                       = Just why
+  where
+    why  = quotes (ppr tycon) <+> ptext SLIT("is parameterised over arguments of kind other than `*'")
+
+cond_glaExts :: Condition
+cond_glaExts (gla_exts, tycon) | gla_exts  = Nothing
+                              | otherwise = Just why
+  where
+    why  = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")
 \end{code}
 
 %************************************************************************
@@ -666,28 +767,32 @@ the renamer.  What a great hack!
 
 \begin{code}
 -- Generate the method bindings for the required instance
--- (paired with class name, as we need that when renaming
+-- (paired with DFunId, as we need that when renaming
 --  the method binds)
-gen_bind :: DFunId -> TcM (Name, RdrNameMonoBinds)
+gen_bind :: DFunId -> TcM (DFunId, (RdrNameMonoBinds, RdrNameMonoBinds))
 gen_bind dfun
   = getFixityEnv               `thenM` \ fix_env -> 
-    returnM (cls_nm, gen_binds_fn fix_env cls_nm tycon)
-  where
-    cls_nm       = className clas
-    (clas, tycon) = simpleDFunClassTyCon dfun
-
-gen_binds_fn fix_env cls_nm
-  = assoc "gen_bind:bad derived class"
-         gen_list (nameUnique cls_nm)
-  where
-    gen_list = [(eqClassKey,      gen_Eq_binds)
-              ,(ordClassKey,     gen_Ord_binds)
-              ,(enumClassKey,    gen_Enum_binds)
-              ,(boundedClassKey, gen_Bounded_binds)
-              ,(ixClassKey,      gen_Ix_binds)
-              ,(showClassKey,    gen_Show_binds fix_env)
-              ,(readClassKey,    gen_Read_binds fix_env)
-              ]
+    let
+        (clas, tycon) = simpleDFunClassTyCon dfun
+       gen_binds_fn  = assoc "gen_bind:bad derived class"
+                             gen_list (getUnique clas)
+    
+       gen_list = [(eqClassKey,      no_aux_binds gen_Eq_binds)
+                  ,(ordClassKey,     no_aux_binds gen_Ord_binds)
+                  ,(enumClassKey,    no_aux_binds gen_Enum_binds)
+                  ,(boundedClassKey, no_aux_binds gen_Bounded_binds)
+                  ,(ixClassKey,      no_aux_binds gen_Ix_binds)
+                  ,(showClassKey,    no_aux_binds (gen_Show_binds fix_env))
+                  ,(readClassKey,    no_aux_binds (gen_Read_binds fix_env))
+                  ,(typeableClassKey,no_aux_binds gen_Typeable_binds)
+                  ,(dataClassKey,    gen_Data_binds fix_env)
+                  ]
+
+               -- Used for generators that don't need to produce       
+               -- any auxiliary bindings
+       no_aux_binds f tc = (f tc, EmptyMonoBinds)
+    in
+    returnM (dfun, gen_binds_fn tycon)
 \end{code}
 
 
@@ -742,7 +847,7 @@ gen_taggery_Names dfuns
         ((we_are_deriving eqClassKey tycon
            && any isNullaryDataCon (tyConDataCons tycon))
         || (we_are_deriving ordClassKey  tycon
-           && not (maybeToBool (maybeTyConSingleCon tycon)))
+           && not (isProductTyCon tycon))
         || (we_are_deriving enumClassKey tycon)
         || (we_are_deriving ixClassKey   tycon))