From: simonpj@microsoft.com Date: Tue, 20 Nov 2007 12:57:32 +0000 (+0000) Subject: FIX Trac #1825: standalone deriving Typeable X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f22f248b88346df835b25f03f8d3372c7bb87950 FIX Trac #1825: standalone deriving Typeable Standalone deriving of typeable now requires you to say instance Typeable1 Maybe which is exactly the shape of instance decl that is generated by a 'deriving( Typeable )' clause on the data type decl. This is a bit horrid, but it's the only consistent way, at least for now. If you say something else, the error messages are helpful. MERGE to 6.8 branch --- diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 774bbe9..445a1f4 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -86,8 +86,13 @@ data DerivSpec = DS { ds_loc :: SrcSpan 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, @@ -360,12 +365,12 @@ makeDerivSpecs :: [LTyClDecl Name] -> 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 ] - ; eqns2 <- mapM deriveStandalone deriv_decls + ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls ; return (catMaybes (eqns1 ++ eqns2)) } where extractTyDataPreds decls = @@ -421,20 +426,12 @@ deriveTyData _other ------------------------------------------------------------------ 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 - = 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 { (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving @@ -442,12 +439,12 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta -- 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 - 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"))) @@ -504,27 +501,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 -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 - | 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 @@ -550,6 +533,34 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta ; 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 @@ -563,28 +574,27 @@ checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc | 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") - -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 @@ -1116,7 +1126,8 @@ derivingThingErr clas tys ty why pred = mkClassPred clas (tys ++ [ty]) 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 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index f118f47..68db3a2 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -561,6 +561,19 @@ recoverM recover thing Left exn -> recover Right res -> returnM res } + +----------------------- +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +-- Drop elements of the input that fail, so the result +-- list can be shorter than the argument list +mapAndRecoverM f [] = return [] +mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x) + ; rs <- mapAndRecoverM f xs + ; return (case mb_r of + Left _ -> rs + Right r -> r:rs) } + + ----------------------- tryTc :: TcRn a -> TcRn (Messages, Maybe a) -- (tryTc m) executes m, and returns