Commit a0770aa6 authored by waern's avatar waern

Change TypeSig and GenericSig to take a list of names (fixes #1595).

This is a merge of a patch contributed by Michal Terepeta and the
recent generics changes.
parent f31e9349
......@@ -419,7 +419,7 @@ 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") ]
......@@ -428,14 +428,16 @@ 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
......
......@@ -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
......
......@@ -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,11 +595,11 @@ 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
| GenericSig (Located name) (LHsType name)
| GenericSig [Located name] (LHsType name)
-- A type signature in generated code, notably the code
-- generated for record selectors. We simply record
......@@ -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,8 +736,8 @@ 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 _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (TypeSig ns1 _)) (L _ (TypeSig ns2 _)) = map unLoc ns1 == map unLoc ns2
eqHsSig (L _ (GenericSig ns1 _)) (L _ (GenericSig ns2 _)) = map unLoc ns1 == map unLoc ns2
eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate
......@@ -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 vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (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
......
......@@ -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
......
......@@ -1241,7 +1241,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
{% do s <- checkValSig $1 $3
; return (LL $ unitOL (LL $ SigD s)) }
| 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 '#-}'
......
......@@ -774,7 +774,7 @@ checkValSig
-> P (Sig RdrName)
checkValSig (L l (HsVar v)) ty
| isUnqual v && not (isDataOcc (rdrNameOcc v))
= return (TypeSig (L l v) ty)
= return (TypeSig [L l v] ty)
checkValSig lhs@(L l _) ty
= parseErrorSDoc l ((text "Invalid type signature:" <+>
ppr lhs <+> text "::" <+> ppr ty)
......
......@@ -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,16 +694,16 @@ 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)
renameSig mb_names sig@(GenericSig vs ty)
= do { defaultSigs_on <- xoptM Opt_DefaultSignatures
; unless defaultSigs_on (addErr (defaultSigErr sig))
; new_v <- lookupSigOccRn mb_names sig v
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; new_v <- mapM (lookupSigOccRn mb_names sig) vs
; new_ty <- rnHsSigType (quotes (ppr vs)) ty
; return (GenericSig new_v new_ty) }
renameSig _ (SpecInstSig ty)
......
......@@ -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)
......
......@@ -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.
......
......@@ -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
......@@ -1053,10 +1054,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].)
......@@ -1064,13 +1067,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)
-------------------
......
......@@ -89,10 +89,10 @@ tcClassSigs :: Name -- Name of the class
-> TcM ([TcMethInfo], -- Exactly one for each method
NameEnv Type) -- Types of the generic-default methods
tcClassSigs clas sigs def_methods
= do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
= do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
; let gen_dm_env = mkNameEnv gen_dm_prs
; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
; sequence_ [ failWithTc (badMethodErr clas n)
......@@ -110,16 +110,17 @@ tcClassSigs clas sigs def_methods
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]
tc_sig genop_env (L _ op_name, op_hs_ty)
tc_sig genop_env (op_names, op_hs_ty)
= do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
; let dm | op_name `elemNameEnv` genop_env = GenericDM
| op_name `elem` dm_bind_names = VanillaDM
| otherwise = NoDM
; return (op_name, dm, op_ty) }
; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
where
f nm | nm `elemNameEnv` genop_env = GenericDM
| nm `elem` dm_bind_names = VanillaDM
| otherwise = NoDM
tc_gen_sig (L _ op_name, gen_hs_ty)
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcHsKindedType gen_hs_ty
; return (op_name, gen_op_ty) }
; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
\end{code}
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment