From 1faa61028e4c1253f3dacbda9efb92466c5749f9 Mon Sep 17 00:00:00 2001 From: Michal Terepeta Date: Sat, 14 May 2011 19:25:51 +0200 Subject: [PATCH] Change TypeSig to take a list of names (fixes #1595). --- compiler/deSugar/DsMeta.hs | 19 ++++++++++--------- compiler/hsSyn/Convert.lhs | 2 +- compiler/hsSyn/HsBinds.lhs | 32 +++++++++++--------------------- compiler/hsSyn/HsUtils.lhs | 2 +- compiler/parser/Parser.y.pp | 8 ++++---- compiler/parser/RdrHsSyn.lhs | 9 ++++----- compiler/rename/RnBinds.lhs | 13 +++++++------ compiler/rename/RnNames.lhs | 2 +- compiler/rename/RnSource.lhs | 2 +- compiler/typecheck/TcBinds.lhs | 34 +++++++++++++++++++--------------- compiler/typecheck/TcClassDcl.lhs | 2 +- compiler/typecheck/TcGenDeriv.lhs | 10 +++++----- 12 files changed, 65 insertions(+), 70 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index a5cbdd3..2d9e762 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -419,23 +419,24 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig (L loc (TypeSig nms ty)) = rep_proto nms ty loc rep_sig (L _ (GenericSig nm _)) = failWithDs msg where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm) , ptext (sLit "Default signatures are not supported by Template Haskell") ] - rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig _ = return [] -rep_proto :: Located Name -> LHsType Name -> SrcSpan +rep_proto :: [Located Name] -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_proto nm ty loc - = do { nm1 <- lookupLOcc nm - ; ty1 <- repLTy ty - ; sig <- repProto nm1 ty1 - ; return [(loc, sig)] - } +rep_proto nms ty loc + = mapM f nms + where + f nm = do { nm1 <- lookupLOcc nm + ; ty1 <- repLTy ty + ; sig <- repProto nm1 ty1 + ; return (loc, sig) + } rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 492f255..8d79afe 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -143,7 +143,7 @@ cvtDec (TH.FunD nm cls) cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnL $ Hs.SigD (TypeSig nm' ty') } + ; returnL $ Hs.SigD (TypeSig [nm'] ty') } cvtDec (PragmaD prag) = do { prag' <- cvtPragmaD prag diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 5871914..d4e4a21 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -252,7 +252,7 @@ getTypeSigNames :: HsValBinds a -> NameSet getTypeSigNames (ValBindsIn {}) = panic "getTypeSigNames" getTypeSigNames (ValBindsOut _ sigs) - = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs] + = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names] \end{code} What AbsBinds means @@ -595,7 +595,7 @@ type LSig name = Located (Sig name) data Sig name -- Signatures and pragmas = -- An ordinary type signature -- f :: Num a => a -> a - TypeSig (Located name) (LHsType name) + TypeSig [Located name] (LHsType name) -- A type signature for a default method inside a class -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool @@ -685,18 +685,6 @@ okInstDclSig (GenericSig _ _) = False okInstDclSig (FixSig _) = False okInstDclSig _ = True -sigName :: LSig name -> Maybe name --- Used only in Haddock -sigName (L _ sig) = sigNameNoLoc sig - -sigNameNoLoc :: Sig name -> Maybe name --- Used only in Haddock -sigNameNoLoc (TypeSig n _) = Just (unLoc n) -sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) -sigNameNoLoc (InlineSig n _) = Just (unLoc n) -sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n) -sigNameNoLoc _ = Nothing - isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True isFixityLSig _ = False @@ -748,7 +736,7 @@ Signature equality is used when checking for duplicate signatures eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 -eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (TypeSig ns1 _)) (L _ (TypeSig ns2 _)) = map unLoc ns1 == map unLoc ns2 eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over @@ -762,9 +750,9 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) -ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty) -ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) +ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig [unLoc var] (ppr ty) +ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) @@ -776,11 +764,13 @@ instance Outputable name => Outputable (FixitySig name) where pragBrackets :: SDoc -> SDoc pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") -pprVarSig :: (Outputable id) => id -> SDoc -> SDoc -pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty] +pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map ppr vars) pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc -pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty +pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty where pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index cc57e05..6ddbd99 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -606,7 +606,7 @@ hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name] hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})) = cls_name : - concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs] + concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons})) = tc_name : hsConDeclsBinders cons diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 01d768a..6504312 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -721,7 +721,7 @@ decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) } -- A 'default' signature used with the generic-programming extension | 'default' infixexp '::' sigtypedoc - {% do { (TypeSig l ty) <- checkValSig $2 $4 + {% do { (l, ty) <- checkValSig $2 $4 ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } } decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed @@ -1236,10 +1236,10 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp '::' sigtypedoc - {% do s <- checkValSig $1 $3 - ; return (LL $ unitOL (LL $ SigD s)) } + {% do (l, ty) <- checkValSig $1 $3 + ; return (LL $ unitOL (LL $ SigD $ TypeSig [l] ty)) } | var ',' sig_vars '::' sigtypedoc - { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } + { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index a943344..eaeb140 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -768,13 +768,12 @@ checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs ; return (PatBind lhs grhss placeHolderType placeHolderNames) } -checkValSig - :: LHsExpr RdrName - -> LHsType RdrName - -> P (Sig RdrName) +checkValSig :: LHsExpr RdrName + -> LHsType RdrName + -> P (Located RdrName, LHsType RdrName) checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) - = return (TypeSig (L l v) ty) + = return (L l v, ty) checkValSig lhs@(L l _) ty = parseErrorSDoc l ((text "Invalid type signature:" <+> ppr lhs <+> text "::" <+> ppr ty) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 80a47a4..08433a7 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -560,8 +560,9 @@ mkSigTvFn sigs where env :: NameEnv [Name] env = mkNameEnv [ (name, map hsLTyVarName ltvs) - | L _ (TypeSig (L _ name) - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + | L _ (TypeSig names + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs + , (L _ name) <- names] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all \end{code} @@ -693,10 +694,10 @@ renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) = return (IdSig x) -- Actually this never occurs -renameSig mb_names sig@(TypeSig v ty) - = do { new_v <- lookupSigOccRn mb_names sig v - ; new_ty <- rnHsSigType (quotes (ppr v)) ty - ; return (TypeSig new_v new_ty) } +renameSig mb_names sig@(TypeSig vs ty) + = do { new_vs <- mapM (lookupSigOccRn mb_names sig) vs + ; new_ty <- rnHsSigType (quotes (ppr vs)) ty + ; return (TypeSig new_vs new_ty) } renameSig mb_names sig@(GenericSig v ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 71d134d..46258a6 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -472,7 +472,7 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders val_bndrs :: [Located RdrName] - val_bndrs | is_hs_boot = [nm | L _ (TypeSig nm _) <- val_sigs] + val_bndrs | is_hs_boot = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns] | otherwise = for_hs_bndrs new_simple :: Located RdrName -> RnM (GenAvailInfo Name) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 54dc378..73da1f1 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -799,7 +799,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] + ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 881c304..dfdb7b2 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -102,11 +102,12 @@ tcHsBootSigs :: HsValBinds Name -> TcM [Id] -- signatures in it. The renamer checked all this tcHsBootSigs (ValBindsOut binds sigs) = do { checkTc (null binds) badBootDeclErr - ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where - tc_boot_sig (TypeSig (L _ name) ty) - = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; return (mkVanillaGlobal name sigma_ty) } + tc_boot_sig (TypeSig lnames ty) = mapM f lnames + where + f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) @@ -177,7 +178,7 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside ; ty_sigs = filter isTypeLSig sigs ; sig_fn = mkSigFun ty_sigs } - ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) + ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs) -- No recovery from bad signatures, because the type sigs -- may bind type variables, so proceeding without them -- can lead to a cascade of errors @@ -1068,10 +1069,12 @@ mkSigFun :: [LSig Name] -> SigFun -- Precondition: no duplicates mkSigFun sigs = lookupNameEnv env where - env = mkNameEnv (mapCatMaybes mk_pair sigs) - mk_pair (L loc (TypeSig (L _ name) lhs_ty)) = Just (name, (hsExplicitTvs lhs_ty, loc)) - mk_pair (L loc (IdSig id)) = Just (idName id, ([], loc)) - mk_pair _ = Nothing + env = mkNameEnv (concatMap mk_pair sigs) + mk_pair (L loc (IdSig id)) = [(idName id, ([], loc))] + mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames + where + f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc)) + mk_pair _ = [] -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because -- of nested type synonyms. See Note [More instantiated than scoped].) @@ -1079,13 +1082,14 @@ mkSigFun sigs = lookupNameEnv env \end{code} \begin{code} -tcTySig :: LSig Name -> TcM TcId -tcTySig (L span (TypeSig (L _ name) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; return (mkLocalId name sigma_ty) } +tcTySig :: LSig Name -> TcM [TcId] +tcTySig (L span (TypeSig names ty)) + = setSrcSpan span $ mapM f names + where + f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkLocalId name sigma_ty) } tcTySig (L _ (IdSig id)) - = return id + = return [id] tcTySig s = pprPanic "tcTySig" (ppr s) ------------------- diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 8fc8a24..aabeea3 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -105,7 +105,7 @@ tcClassSigs clas sigs def_methods ; return (op_info, gen_dm_env) } where - vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] + vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nms ty) <- sigs, nm <- nms] gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index ad640ef..e412910 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1670,7 +1670,7 @@ fiddling around. genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName) genAuxBind loc (GenCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where rdr_name = con2tag_RDR tycon @@ -1695,7 +1695,7 @@ genAuxBind loc (GenTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon @@ -1704,7 +1704,7 @@ genAuxBind loc (GenTag2Con tycon) genAuxBind loc (GenMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where rdr_name = maxtag_RDR tycon sig_ty = HsCoreTy intTy @@ -1714,7 +1714,7 @@ genAuxBind loc (GenMaxTag tycon) genAuxBind loc (MkTyCon tycon) -- $dT = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_data_type_name tycon sig_ty = nlHsTyVar dataType_RDR @@ -1725,7 +1725,7 @@ genAuxBind loc (MkTyCon tycon) -- $dT genAuxBind loc (MkDataCon dc) -- $cT1 etc = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_constr_name dc sig_ty = nlHsTyVar constr_RDR -- 1.7.5.3