Another round of External Core fixes

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

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index d414c6f..2edd836 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -46,6 +46,7 @@ import SrcLoc
 import Util
 import ListSetOps
 import Outputable
 import Util
 import ListSetOps
 import Outputable

+import FastString

 import Bag
 \end{code}
 
 import Bag
 \end{code}
 

@@ -86,8 +87,13 @@ data DerivSpec  = DS { ds_loc     :: SrcSpan
 
 type EarlyDerivSpec = Either DerivSpec DerivSpec
        -- Left  ds => the context for the instance should be inferred
 
 type EarlyDerivSpec = Either DerivSpec DerivSpec
        -- Left  ds => the context for the instance should be inferred

-       --              (ds_theta is required)
-       -- Right ds => the context for the instance is supplied by the programmer
+       --             In this case ds_theta is the list of all the 
+       --                constraints needed, such as (Eq [a], Eq a)
+       --                The inference process is to reduce this to a 
+       --                simpler form (e.g. Eq a)
+       -- 
+       -- Right ds => the exact context for the instance is supplied 
+       --             by the programmer; it is ds_theta

 
 pprDerivSpec :: DerivSpec -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 
 
 pprDerivSpec :: DerivSpec -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 

@@ -222,6 +228,9 @@ And then translate it to:
        
 Note [Newtype deriving superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        
 Note [Newtype deriving superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+(See also Trac #1220 for an interesting exchange on newtype
+deriving and superclasses.)
+

 The 'tys' here come from the partial application in the deriving
 clause. The last arg is the new instance type.
 
 The 'tys' here come from the partial application in the deriving
 clause. The last arg is the new instance type.
 

@@ -257,7 +266,7 @@ tcDeriving  :: [LTyClDecl Name]  -- All type constructors
                    HsValBinds Name)    -- Extra generated top-level bindings
 
 tcDeriving tycl_decls inst_decls deriv_decls
                    HsValBinds Name)    -- Extra generated top-level bindings
 
 tcDeriving tycl_decls inst_decls deriv_decls

-  = recoverM (returnM ([], emptyValBindsOut)) $
+  = 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
     do {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
        ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls

@@ -278,8 +287,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
        ; let inst_info = insts1 ++ insts2
 
        ; dflags <- getDOpts
        ; let inst_info = insts1 ++ insts2
 
        ; dflags <- getDOpts

-       ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" 
-                  (ddump_deriving inst_info rn_binds))
+       ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                (ddump_deriving inst_info rn_binds))

 
        ; return (inst_info, rn_binds) }
   where
 
        ; return (inst_info, rn_binds) }
   where

@@ -357,12 +366,12 @@ makeDerivSpecs :: [LTyClDecl Name]
               -> TcM [EarlyDerivSpec]
 
 makeDerivSpecs tycl_decls inst_decls deriv_decls
               -> TcM [EarlyDerivSpec]
 
 makeDerivSpecs tycl_decls inst_decls deriv_decls

-  = do { eqns1 <- mapM deriveTyData $
+  = do { eqns1 <- mapAndRecoverM deriveTyData $

                      extractTyDataPreds tycl_decls ++
                     [ pd                        -- traverse assoc data families
                      | L _ (InstDecl _ _ _ ats) <- inst_decls
                     , pd <- extractTyDataPreds ats ]
                      extractTyDataPreds tycl_decls ++
                     [ pd                        -- traverse assoc data families
                      | L _ (InstDecl _ _ _ ats) <- inst_decls
                     , pd <- extractTyDataPreds ats ]

-       ; eqns2 <- mapM deriveStandalone deriv_decls
+       ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls

        ; return (catMaybes (eqns1 ++ eqns2)) }
   where
     extractTyDataPreds decls =                    
        ; return (catMaybes (eqns1 ++ eqns2)) }
   where
     extractTyDataPreds decls =                    

@@ -418,33 +427,36 @@ deriveTyData _other
 
 ------------------------------------------------------------------
 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
 
 ------------------------------------------------------------------
 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type

-          -> Maybe ThetaType           -- Just    => context supplied
-                                       -- Nothing => context inferred
+          -> Maybe ThetaType   -- Just    => context supplied (standalone deriving)
+                               -- Nothing => context inferred (deriving on data decl)

           -> TcRn (Maybe EarlyDerivSpec)
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
           -> TcRn (Maybe EarlyDerivSpec)
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app

-  = do {       -- Make tc_app saturated, because that's what the
-               -- mkDataTypeEqn things expect
-               -- It might not be saturated in the standalone deriving case
-               --      derive instance Monad (T a)
-         let extra_tvs = dropList tc_args (tyConTyVars tycon)
-             full_tc_args = tc_args ++ mkTyVarTys extra_tvs
-             full_tvs = tvs ++ extra_tvs
-               
-       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
+  = do {
+       -- For standalone deriving (mtheta /= Nothing), 
+       -- check that all the data constructors are in scope
+       -- By this time we know that the thing is algebraic
+       --      because we've called checkInstHead in derivingStandalone
+         rdr_env <- getGlobalRdrEnv
+       ; let hidden_data_cons = filter not_in_scope (tyConDataCons tycon)
+             not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))
+       ; checkTc (isNothing mtheta || null hidden_data_cons) 
+                 (derivingHiddenErr tycon)

 
        ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
        ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 
 
        ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
        ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 

+       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
+

           -- Be careful to test rep_tc here: in the case of families, we want
           -- to check the instance tycon, not the family tycon
        ; if isDataTyCon rep_tc then
           -- Be careful to test rep_tc here: in the case of families, we want
           -- to check the instance tycon, not the family tycon
        ; if isDataTyCon rep_tc then

-               mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys 
-                             tycon full_tc_args rep_tc rep_tc_args mtheta
+               mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys 
+                             tycon tc_args rep_tc rep_tc_args mtheta

          else
                mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
          else
                mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving

-                            full_tvs cls cls_tys 
-                            tycon full_tc_args rep_tc rep_tc_args mtheta }
+                            tvs cls cls_tys 
+                            tycon tc_args rep_tc rep_tc_args mtheta }

   | otherwise
   = baleOut (derivingThingErr cls cls_tys tc_app
                (ptext SLIT("Last argument of the instance must be a type application")))
   | otherwise
   = baleOut (derivingThingErr cls cls_tys tc_app
                (ptext SLIT("Last argument of the instance must be a type application")))

@@ -501,27 +513,13 @@ mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
   = ASSERT( null cls_tys )
     mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 
   = ASSERT( null cls_tys )
     mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 

-mk_data_eqn :: InstOrigin -> [TyVar] -> Class 
-            -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
-            -> TcM (Maybe EarlyDerivSpec)
+mk_data_eqn, mk_typeable_eqn
+   :: InstOrigin -> [TyVar] -> Class 
+   -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
+   -> TcM (Maybe EarlyDerivSpec)

 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta

-  | cls `hasKey` typeableClassKey
-  =    -- The Typeable class is special in several ways
-       --        data T a b = ... deriving( Typeable )
-       -- gives
-       --        instance Typeable2 T where ...
-       -- Notice that:
-       -- 1. There are no constraints in the instance
-       -- 2. There are no type variables either
-       -- 3. The actual class we want to generate isn't necessarily
-       --      Typeable; it depends on the arity of the type
-    do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
-       ; dfun_name <- new_dfun_name real_clas tycon
-       ; loc <- getSrcSpanM
-       ; return (Just $ Right $
-                 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
-                    , ds_cls = real_clas, ds_tys = [mkTyConApp tycon []] 
-                    , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+  | getName cls `elem` typeableClassNames
+  = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta

 
   | otherwise
   = do { dfun_name <- new_dfun_name cls tycon
 
   | otherwise
   = do { dfun_name <- new_dfun_name cls tycon

@@ -533,20 +531,51 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
                                dataConInstOrigArgTys data_con rep_tc_args,
                    not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 
                                dataConInstOrigArgTys data_con rep_tc_args,
                    not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 

+                       -- See Note [Superclasses of derived instance]
+             sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+                                         (classSCTheta cls)
+             inst_tys =  [mkTyConApp tycon tc_args]
+

              stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
              stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
              stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
              stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)

-             all_constraints = stupid_constraints ++ ordinary_constraints
-                        -- see Note [Data decl contexts] above
+             all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints

 
              spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs 
 
              spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs 

-                       , ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args]
+                       , ds_cls = cls, ds_tys = inst_tys

                        , ds_theta =  mtheta `orElse` all_constraints
                        , ds_newtype = False }
 
        ; return (if isJust mtheta then Just (Right spec)       -- Specified context
                                   else Just (Left spec)) }     -- Infer context
 
                        , ds_theta =  mtheta `orElse` all_constraints
                        , ds_newtype = False }
 
        ; return (if isJust mtheta then Just (Right spec)       -- Specified context
                                   else Just (Left spec)) }     -- Infer context
 

+mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
+       -- The Typeable class is special in several ways
+       --        data T a b = ... deriving( Typeable )
+       -- gives
+       --        instance Typeable2 T where ...
+       -- Notice that:
+       -- 1. There are no constraints in the instance
+       -- 2. There are no type variables either
+       -- 3. The actual class we want to generate isn't necessarily
+       --      Typeable; it depends on the arity of the type
+  | isNothing mtheta   -- deriving on a data type decl
+  = do { checkTc (cls `hasKey` typeableClassKey)
+                 (ptext SLIT("Use deriving( Typeable ) on a data type declaration"))
+       ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
+       ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
+
+  | otherwise          -- standaone deriving
+  = do { checkTc (null tc_args)
+                 (ptext SLIT("Derived typeable instance must be of form (Typeable") 
+                       <> int (tyConArity tycon) <+> ppr tycon <> rparen)
+       ; dfun_name <- new_dfun_name cls tycon
+       ; loc <- getSrcSpanM
+       ; return (Just $ Right $
+                 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
+                    , ds_cls = cls, ds_tys = [mkTyConApp tycon []] 
+                    , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+

 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism

@@ -560,28 +589,27 @@ checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
   | notNull cls_tys    
   = Just ty_args_why   -- e.g. deriving( Foo s )
   | otherwise
   | notNull cls_tys    
   = Just ty_args_why   -- e.g. deriving( Foo s )
   | otherwise

-  = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
-       []     -> Just (non_std_why cls)
-       [cond] -> cond (mayDeriveDataTypeable, rep_tc)
-       _other -> pprPanic "checkSideConditions" (ppr cls)
+  = case sideConditions cls of
+       Just cond -> cond (mayDeriveDataTypeable, rep_tc)
+       Nothing   -> Just non_std_why

   where
     ty_args_why        = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
   where
     ty_args_why        = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")

-
-non_std_why :: Class -> SDoc
-non_std_why cls = quotes (ppr cls) <+> 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_mayDeriveDataTypeable `andCond` cond_typeableOK),
-       (dataClassKey,     cond_mayDeriveDataTypeable `andCond` cond_std)
-    ]
+    non_std_why = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
+
+sideConditions :: Class -> Maybe Condition
+sideConditions cls
+  | cls_key == eqClassKey   = Just cond_std
+  | cls_key == ordClassKey  = Just cond_std
+  | cls_key == readClassKey = Just cond_std
+  | cls_key == showClassKey = Just cond_std
+  | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+  | cls_key == ixClassKey   = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+  | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+  | cls_key == dataClassKey    = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
+  | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
+  | otherwise = Nothing
+  where
+    cls_key = getUnique cls

 
 type Condition = (Bool, TyCon) -> Maybe SDoc
        -- Bool is whether or not we are allowed to derive Data and Typeable
 
 type Condition = (Bool, TyCon) -> Maybe SDoc
        -- Bool is whether or not we are allowed to derive Data and Typeable

@@ -671,6 +699,30 @@ new_dfun_name clas tycon   -- Just a simple wrapper
        -- a suitable string; hence the empty type arg list
 \end{code}
 
        -- a suitable string; hence the empty type arg list
 \end{code}
 

+Note [Superclasses of derived instance] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+       data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is 
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint 
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+       data T a = MkT deriving( Data, Typeable )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+       instance Typable a => Data (T a) where ...
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -747,10 +799,10 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
                -- Want to drop 1 arg from (T s a) and (ST s a)
                -- to get       instance Monad (ST s) => Monad (T s)
 
                -- Want to drop 1 arg from (T s a) and (ST s a)
                -- to get       instance Monad (ST s) => Monad (T s)
 

-       -- Note [newtype representation]
-       -- Need newTyConRhs *not* newTyConRep to get the representation 
-       -- type, because the latter looks through all intermediate newtypes
-       -- For example
+       -- Note [Newtype representation]
+       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       -- Need newTyConRhs (*not* a recursive representation finder) 
+       -- to get the representation type. For example

        --      newtype B = MkB Int
        --      newtype A = MkA B deriving( Num )
        -- We want the Num instance of B, *not* the Num instance of Int,
        --      newtype B = MkB Int
        --      newtype A = MkA B deriving( Num )
        -- We want the Num instance of B, *not* the Num instance of Int,

@@ -1112,8 +1164,14 @@ derivingThingErr clas tys ty why
   where
     pred = mkClassPred clas (tys ++ [ty])
 
   where
     pred = mkClassPred clas (tys ++ [ty])
 

+derivingHiddenErr :: TyCon -> SDoc
+derivingHiddenErr tc
+  = hang (ptext SLIT("The data constructors of") <+> quotes (ppr tc) <+> ptext SLIT("are not all in scope"))
+       2 (ptext SLIT("so you cannot derive an instance for it"))
+

 standaloneCtxt :: LHsType Name -> SDoc
 standaloneCtxt :: LHsType Name -> SDoc

-standaloneCtxt ty = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty)
+standaloneCtxt ty = hang (ptext SLIT("In the stand-alone deriving instance for")) 
+                      2 (quotes (ppr ty))

 
 derivInstCtxt :: Class -> [Type] -> Message
 derivInstCtxt clas inst_tys
 
 derivInstCtxt :: Class -> [Type] -> Message
 derivInstCtxt clas inst_tys