From: simonpj Date: Fri, 2 Apr 2004 16:47:05 +0000 (+0000) Subject: [project @ 2004-04-02 16:46:57 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1919 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=40888e1d6141c919254f93545ae0d795e20ae4bf;p=ghc-hetmet.git [project @ 2004-04-02 16:46:57 by simonpj] Extend the "newtype deriving" feature a little bit more (at the request of Wolfgang Jeltsch) Here's the example: class C a b instance C [a] Char newtype T = T Char deriving( C [a] ) Perfectly sensible, and no reason it should not work. Fixing this required me to generalise the abstract syntax of a 'deriving' item, hence the non-local effects. --- diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index bba9d9a..229bb54 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -288,7 +288,7 @@ repBangTy (L _ (BangType str ty)) = do -- Deriving clause ------------------------------------------------------- -repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name]) +repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name]) repDerivs Nothing = coreList nameTyConName [] repDerivs (Just (L _ ctxt)) = do { strs <- mapM rep_deriv ctxt ; @@ -296,8 +296,8 @@ repDerivs (Just (L _ ctxt)) where rep_deriv :: LHsPred Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form - rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls - rep_deriv other = panic "rep_deriv" + rep_deriv (L _ (HsPredTy (L _ (HsClassP cls [])))) = lookupOcc cls + rep_deriv other = panic "rep_deriv" ------------------------------------------------------- diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 930dcdc..827bec8 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -306,9 +306,13 @@ data TyClDecl name tcdLName :: Located name, -- Type constructor tcdTyVars :: [LHsTyVarBndr name], -- Type variables tcdCons :: [LConDecl name], -- Data constructors - tcdDerivs :: Maybe (LHsContext name) + tcdDerivs :: Maybe [LHsType name] -- Derivings; Nothing => not specified -- Just [] => derive exactly what is asked + -- These "types" must be of form + -- forall ab. C ty1 ty2 + -- Typically the foralls and ty args are empty, but they + -- are non-empty for the newtype-deriving case } | TySynonym { tcdLName :: Located name, -- type constructor @@ -433,8 +437,7 @@ pp_tydecl pp_head pp_decl_rhs derivings pp_decl_rhs, case derivings of Nothing -> empty - Just ds -> hsep [ptext SLIT("deriving"), - ppr_hs_context (unLoc ds)] + Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)] ]) instance Outputable NewOrData where diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index cb3c70f..170175a 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -123,7 +123,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) = (length cs, case derivs of Nothing -> 0 - Just ds -> length (unLoc ds)) + Just ds -> length ds) data_info other = (0,0) class_info decl@(ClassDecl {}) diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 4826a93..49eefb3 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -723,9 +723,9 @@ opt_asig :: { Maybe (LHsType RdrName) } : {- empty -} { Nothing } | '::' atype { Just $2 } -sigtypes :: { [LHsType RdrName] } +sigtypes1 :: { [LHsType RdrName] } : sigtype { [ $1 ] } - | sigtypes ',' sigtype { $3 : $1 } + | sigtype ',' sigtypes1 { $1 : $3 } sigtype :: { LHsType RdrName } : ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) } @@ -785,6 +785,10 @@ atype :: { LHsType RdrName } inst_type :: { LHsType RdrName } : ctype {% checkInstType $1 } +inst_types1 :: { [LHsType RdrName] } + : inst_type { [$1] } + | inst_type ',' inst_types1 { $1 : $3 } + comma_types0 :: { [LHsType RdrName] } : comma_types1 { $1 } | {- empty -} { [] } @@ -894,9 +898,10 @@ strict_mark :: { Located HsBang } : '!' { L1 HsStrict } | '{-# UNPACK' '#-}' '!' { LL HsUnbox } -deriving :: { Located (Maybe (LHsContext RdrName)) } - : {- empty -} { noLoc Nothing } - | 'deriving' context { LL (Just $2) } +deriving :: { Located (Maybe [LHsType RdrName]) } + : {- empty -} { noLoc Nothing } + | 'deriving' '(' ')' { LL (Just []) } + | 'deriving' '(' inst_types1 ')' { LL (Just $3) } -- Glasgow extension: allow partial -- applications in derivings @@ -953,7 +958,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } { LL $ unitOL (LL $ SigD (InlineSig True $3 $2)) } | '{-# NOINLINE' inverse_activation qvar '#-}' { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) } - | '{-# SPECIALISE' qvar '::' sigtypes '#-}' + | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $2 t) | t <- $4] } | '{-# SPECIALISE' 'instance' inst_type '#-}' diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 3e8c930..8b5953c 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -636,7 +636,7 @@ checkPred (L spn ty) checkDictTy :: LHsType RdrName -> P (LHsType RdrName) checkDictTy (L spn ty) = check ty [] where - check (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + check (HsTyVar t) args | not (isRdrTyVar t) = return (L spn (HsPredTy (L spn (HsClassP t args)))) check (HsAppTy l r) args = check (unLoc l) (r:args) check (HsParTy t) args = check (unLoc t) args diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 43e644e..e173907 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -17,7 +17,7 @@ import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv ) import RdrHsSyn ( extractGenericPatTyVars ) import RnHsSyn import RnExpr ( rnLExpr, checkTH ) -import RnTypes ( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext ) +import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds, rnBindsAndThen, renameSigs, checkSigs ) import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames, @@ -506,8 +506,8 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ] rn_derivs Nothing = returnM (Nothing, emptyFVs) - rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> - returnM (Just ds', extractHsCtxtTyNames ds') + rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> + returnM (Just ds', extractHsTyNames_s ds') rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) = lookupLocatedTopBndrRn name `thenM` \ name' -> diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 7ec84e0..82c1a5d 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -4,7 +4,7 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnTypes ( rnHsType, rnLHsType, rnContext, +module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsSigType, rnHsTypeFVs, rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part rnLit, rnOverLit, -- of any mutual recursion @@ -174,7 +174,7 @@ rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] -> LHsContext Rdr rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty -- One reason for this case is that a type like Int# - -- starts of as (HsForAllTy Nothing [] Int), in case + -- starts off as (HsForAllTy Nothing [] Int), in case -- there is some quantification. Now that we have quantified -- and discovered there are no type variables, it's nicer to turn -- it into plain Int. If it were Int# instead of Int, we'd actually diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 06b1c28..f1e72be 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -21,7 +21,7 @@ import TcEnv ( newDFunName, pprInstInfoDetails, ) import TcGenDeriv -- Deriv stuff import InstEnv ( simpleDFunClassTyCon, extendInstEnv ) -import TcHsType ( tcHsPred ) +import TcHsType ( tcHsDeriv ) import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopBinds ) @@ -45,7 +45,7 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, - getClassPredTys_maybe, tcTyConAppTyCon, + tcSplitForAllTys, tcSplitPredTy_maybe, getClassPredTys_maybe, tcTyConAppTyCon, isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy ) import Var ( TyVar, tyVarKind, idType, varName ) @@ -313,39 +313,40 @@ makeDerivEqns tycl_decls returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where ------------------------------------------------------------------ - derive_these :: [(NewOrData, Name, LHsPred Name)] + derive_these :: [(NewOrData, Name, LHsType Name)] -- Find the (nd, TyCon, Pred) pairs that must be `derived' derive_these = [ (nd, tycon, pred) | L _ (TyData { tcdND = nd, tcdLName = L _ tycon, - tcdDerivs = Just (L _ preds) }) <- tycl_decls, + tcdDerivs = Just preds }) <- tycl_decls, pred <- preds ] ------------------------------------------------------------------ - mk_eqn :: (NewOrData, Name, LHsPred Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) + mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) -- We swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation + -- + -- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign + -- we allow deriving (forall a. C [a]). - mk_eqn (new_or_data, tycon_name, pred) + mk_eqn (new_or_data, tycon_name, hs_deriv_ty) = tcLookupTyCon tycon_name `thenM` \ tycon -> addSrcSpan (srcLocSpan (getSrcLoc tycon)) $ addErrCtxt (derivCtxt Nothing tycon) $ tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention -- the type variables for the type constructor - tcHsPred pred `thenM` \ pred' -> - case getClassPredTys_maybe pred' of - Nothing -> bale_out (malformedPredErr tycon pred) - Just (clas, tys) -> doptM Opt_GlasgowExts `thenM` \ gla_exts -> - mk_eqn_help gla_exts new_or_data tycon clas tys + tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) -> + doptM Opt_GlasgowExts `thenM` \ gla_exts -> + mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys ------------------------------------------------------------------ - mk_eqn_help gla_exts DataType tycon clas tys - | Just err <- checkSideConditions gla_exts clas tycon tys + mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys + | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err) | otherwise = do { eqn <- mkDataTypeEqn tycon clas ; returnM (Just eqn, Nothing) } - mk_eqn_help gla_exts NewType tycon clas tys + mk_eqn_help gla_exts NewType tycon deriv_tvs clas tys | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas) = -- Go ahead and use the isomorphism traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_` @@ -353,7 +354,7 @@ makeDerivEqns tycl_decls returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name, iBinds = NewTypeDerived rep_tys })) | std_class gla_exts clas - = mk_eqn_help gla_exts DataType tycon clas tys -- Go via bale-out route + = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route | otherwise -- Non-standard instance = bale_out (if gla_exts then @@ -390,20 +391,19 @@ makeDerivEqns tycl_decls -- to get instance Monad (ST s) => Monad (T s) -- Note [newtype representation] - -- We must not use newTyConRep to get the representation - -- type, because that looks through all intermediate newtypes - -- To get the RHS of *this* newtype, just look at the data - -- constructor. For example + -- Need newTyConRhs *not* newTyConRep to get the representation + -- type, because the latter looks through all intermediate newtypes + -- 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, -- when making the Num instance of A! - (tyvars, rep_ty) = newTyConRhs tycon + (tc_tvs, rep_ty) = newTyConRhs tycon (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty n_tyvars_to_keep = tyConArity tycon - n_args_to_drop - tyvars_to_drop = drop n_tyvars_to_keep tyvars - tyvars_to_keep = take n_tyvars_to_keep tyvars + tyvars_to_drop = drop n_tyvars_to_keep tc_tvs + tyvars_to_keep = take n_tyvars_to_keep tc_tvs n_args_to_keep = length rep_ty_args - n_args_to_drop args_to_drop = drop n_args_to_keep rep_ty_args @@ -439,11 +439,12 @@ makeDerivEqns tycl_decls -- If there are no tyvars, there's no need -- to abstract over the dictionaries we need - dict_args | null tyvars = [] - | otherwise = rep_pred : sc_theta + dict_tvs = deriv_tvs ++ tc_tvs + dict_args | null dict_tvs = [] + | otherwise = rep_pred : sc_theta -- Finally! Here's where we build the dictionary Id - mk_dfun dfun_name = mkDictFunId dfun_name tyvars dict_args clas inst_tys + mk_dfun dfun_name = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys ------------------------------------------------------------------- -- Figuring out whether we can only do this newtype-deriving thing @@ -563,9 +564,9 @@ mkDataTypeEqn tycon clas -- 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 +checkSideConditions :: Bool -> TyCon -> [TyVar] -> Class -> [TcType] -> Maybe SDoc +checkSideConditions gla_exts tycon deriv_tvs clas tys + | notNull deriv_tvs || notNull tys = Just ty_args_why -- e.g. deriving( Foo s ) | otherwise = case [cond | (key,cond) <- sideConditions, key == getUnique clas] of @@ -921,8 +922,6 @@ derivingThingErr clas tys tycon tyvars why where pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)]) -malformedPredErr tycon pred = ptext SLIT("Illegal deriving item") <+> ppr pred - derivCtxt :: Maybe Class -> TyCon -> SDoc derivCtxt maybe_cls tycon = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon) diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index ea1444c..59b1d38 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -5,7 +5,7 @@ \begin{code} module TcHsType ( - tcHsSigType, tcHsPred, + tcHsSigType, tcHsDeriv, UserTypeCtxt(..), -- Kind checking @@ -50,7 +50,7 @@ import Inst ( Inst, InstOrigin(..), newMethod, instToId ) import Id ( mkLocalId, idName, idType ) import Var ( TyVar, mkTyVar, tyVarKind ) import TyCon ( TyCon, tyConKind ) -import Class ( classTyCon ) +import Class ( Class, classTyCon ) import Name ( Name ) import NameSet import PrelNames ( genUnitTyConName ) @@ -155,12 +155,27 @@ tcHsSigType ctxt hs_ty ; checkValidType ctxt ty ; returnM ty } --- tcHsPred is happy with a partial application, e.g. (ST s) --- Used from TcDeriv -tcHsPred pred - = do { (kinded_pred,_) <- wrapLocFstM kc_pred pred -- kc_pred rather than kcHsPred - -- to avoid the partial application check - ; dsHsPred kinded_pred } +-- Used for the deriving(...) items +tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type]) +tcHsDeriv = addLocM (tc_hs_deriv []) + +tc_hs_deriv tv_names (HsPredTy (L _ (HsClassP cls_name hs_tys))) + = kcHsTyVars tv_names $ \ tv_names' -> + do { cls_kind <- kcClass cls_name + ; (tys, res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys + ; tcTyVarBndrs tv_names' $ \ tyvars -> + do { arg_tys <- dsHsTypes tys + ; cls <- tcLookupClass cls_name + ; return (tyvars, cls, arg_tys) }} + +tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty)) + = -- Funny newtype deriving form + -- forall a. C [a] + -- where C has arity 2. Hence can't use regular functions + tc_hs_deriv (tv_names1 ++ tv_names2) ty + +tc_hs_deriv _ other + = failWithTc (ptext SLIT("Illegal deriving item") <+> ppr other) \end{code} These functions are used during knot-tying in @@ -299,18 +314,19 @@ kc_hs_type (HsPredTy pred) kc_hs_type (HsForAllTy exp tv_names context ty) = kcHsTyVars tv_names $ \ tv_names' -> kcHsContext context `thenM` \ ctxt' -> - kcLiftedType ty `thenM` \ ty' -> - -- The body of a forall must be a type, but in principle + kcHsType ty `thenM` \ (ty', kind) -> + -- The body of a forall is usually a type, but in principle -- there's no reason to prohibit *unlifted* types. -- In fact, GHC can itself construct a function with an -- unboxed tuple inside a for-all (via CPR analyis; see -- typecheck/should_compile/tc170) -- - -- Still, that's only for internal interfaces, which aren't - -- kind-checked, and it's a bit inconvenient to use kcTypeType - -- here (because it doesn't return the result kind), so I'm - -- leaving it as lifted types for now. - returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) + -- Furthermore, in newtype deriving we allow + -- deriving( forall a. C [a] ) + -- where C :: *->*->*, so it's awkward to prohibit higher-kinded + -- bodies. In any case, if there is a higher-kinded body + -- and we propagate that up, the caller will find any bugs. + returnM (HsForAllTy exp tv_names' ctxt' ty', kind) --------------------------- kcApps :: TcKind -- Function kind diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 0e430f4..af03b7a 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -508,7 +508,7 @@ allDistinctTyVars (ty:tys) acc tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty -tcSplitPredTy_maybe (PredTy p) = Just p +tcSplitPredTy_maybe (PredTy p) = Just p tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique