aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs31
-rw-r--r--haddock-api/src/Haddock/Convert.hs46
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs48
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs51
-rw-r--r--haddock-api/src/Haddock/Utils.hs29
5 files changed, 103 insertions, 102 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 8664db27..b7dfad64 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -113,38 +113,29 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
f (TyClD d@ClassDecl{}) = ppClass dflags d
- f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
- f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+ f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
+ f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
f (SigD sig) = ppSig dflags sig
f _ = []
ppExport _ _ = []
ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig)
- = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
- where
- prettyNames = intercalate ", " $ map (out dflags) names
- typ = unL (hsSigType sig)
+ppSig dflags (TypeSig names sig) = pp_sig dflags names (hsSigWcType sig)
ppSig _ _ = []
+pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> [String]
+pp_sig dflags names (L _ typ)
+ = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
+ where
+ prettyNames = intercalate ", " $ map (out dflags) names
-- note: does not yet output documentation for class methods
ppClass :: DynFlags -> TyClDecl Name -> [String]
ppClass dflags x = out dflags x{tcdSigs=[]} :
- concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
- where
- addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig)))
- addContext (MinimalSig src sig) = MinimalSig src sig
- addContext _ = error "expected TypeSig"
-
- f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty))
- f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty
- f ty = HsQualTy (reL [context]) ty
-
- context = nlHsTyConApp (tcdName x)
- (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
-
+ concatMap (ppSig dflags . unL . add_ctxt) (tcdSigs x)
+ where
+ add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
ppInstance :: DynFlags -> ClsInst -> [String]
ppInstance dflags x = [dropComment $ out dflags x]
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index d74d528e..952650c1 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -96,17 +96,10 @@ tyThingToLHsDecl t = case t of
-- a data-constructor alone just gets rendered as a function:
AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
- (synifyType ImplicitizeForAll (dataConUserType dc)))
+ (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps
- qtvs = univ_tvs ++ ex_tvs
- ty = mkFunTys arg_tys res_ty
- in allOK . SigD $ PatSynSig (synifyName ps)
- (Implicit, synifyTyVars qtvs)
- (synifyCtx req_theta)
- (synifyCtx prov_theta)
- (synifyType WithinType ty)
+ allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps))
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -316,16 +309,16 @@ synifyDataCon use_gadt_syntax dc =
, con_cxt = ctx
, con_details = hat
, con_res = hs_res_ty
- , con_doc = Nothing }
+ , con_doc = Nothing
-- we don't want any "deprecated GADT syntax" warnings!
- False
+ , con_old_rec = False }
synifyName :: NamedThing n => n -> Located Name
synifyName = noLoc . getName
synifyIdSig :: SynifyTypeState -> Id -> Sig Name
-synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) []
+synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))
synifyCtx :: [PredType] -> LHsContext Name
@@ -337,12 +330,14 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
, hsq_tvs = map synifyTyVar tvs }
where
(kvs, tvs) = partition isKindVar ktvs
- synifyTyVar tv
- | isLiftedTypeKind kind = noLoc (UserTyVar name)
- | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
- where
- kind = tyVarKind tv
- name = getName tv
+
+synifyTyVar :: TyVar -> LHsTyVarBndr Name
+synifyTyVar tv
+ | isLiftedTypeKind kind = noLoc (UserTyVar name)
+ | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
+ where
+ kind = tyVarKind tv
+ name = getName tv
--states of what to do with foralls:
data SynifyTypeState
@@ -360,6 +355,15 @@ data SynifyTypeState
-- the defining class gets to quantify all its functions for free!
+synifySigType :: SynifyTypeState -> Type -> LHsSigType Name
+-- The empty binders is a bit suspicious;
+-- what if the type has free variables?
+synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)
+
+synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
+-- Ditto (see synifySigType)
+synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
+
synifyType :: SynifyTypeState -> Type -> LHsType Name
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
synifyType _ (TyConApp tc tys)
@@ -398,11 +402,11 @@ synifyType _ (FunTy t1 t2) = let
in noLoc $ HsFunTy s1 s2
synifyType s forallty@(ForAllTy _tv _ty) =
let (tvs, ctx, tau) = tcSplitSigmaTy forallty
- sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx)
- , hst_body = noLoc (synify WithinType tau) }
+ sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
+ , hst_body = synifyType WithinType tau }
in case s of
DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
- WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs
+ WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs
, hst_body = noLoc sPhi }
ImplicitizeForAll -> noLoc sPhi
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 8f3b9f9a..d53e7351 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -347,15 +347,14 @@ typeDocs :: HsDecl Name -> Map Int HsDocString
typeDocs d =
let docs = go 0 in
case d of
- SigD (TypeSig _ ty _) -> docs (unLoc ty)
- SigD (PatSynSig _ _ req prov ty) ->
- let allTys = ty : concat [ unLoc req, unLoc prov ]
- in F.foldMap (docs . unLoc) allTys
- ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
+ SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))
+ SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
+ ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty))
TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
_ -> M.empty
where
- go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty)
+ go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+ go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)
go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
go n (HsDocTy _ (L _ doc)) = M.singleton n doc
@@ -728,8 +727,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
expandSig = foldr f []
where
f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
- f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names
- f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names
f x xs = x : xs
mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
@@ -773,17 +772,17 @@ extractDecl name mdl decl
case unLoc decl of
TyClD d@ClassDecl {} ->
let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
- isVanillaLSig sig ] -- TODO: document fixity
+ isTypeLSig sig ] -- TODO: document fixity
in case matches of
- [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
- L pos sig = extractClassDecl n tyvar_names s0
+ [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
+ L pos sig = addClassContext n tyvar_names s0
in L pos (SigD sig)
_ -> error "internal: extractDecl (ClassDecl)"
TyClD d@DataDecl {} ->
- let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
- in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
+ let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
+ in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
- , dfid_pats = HsWB { hswb_cts = tys }
+ , dfid_pats = HsIB { hsib_body = tys }
, dfid_defn = defn }) ->
SigD <$> extractRecSel name mdl n tys (dd_cons defn)
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
@@ -797,24 +796,6 @@ extractDecl name mdl decl
[d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
- where
- getTyVars = hsLTyVarLocNames . tyClDeclTyVars
-
-
-toTypeNoLoc :: Located Name -> LHsType Name
-toTypeNoLoc = noLoc . HsTyVar . unLoc
-
-
-extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
-extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of
- L _ (HsForAllTy expl _ tvs (L _ preds) ty) ->
- L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) [])
- _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) [])
- where
- lctxt = noLoc . ctxt
- ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
-extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
-
extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
@@ -823,7 +804,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
- L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
+ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
_ -> extractRecSel nm mdl t tvs rest
where
matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
@@ -833,7 +814,6 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
| ResTyGADT _ ty <- con_res con = ty
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
-
-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 318a88c0..f95e527e 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -170,11 +170,11 @@ renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType Name -> RnM (LHsType DocName)
renameLType = mapM renameType
-renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
-renameLSigType = renameWc renameLType
+renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)
+renameLSigType = renameImplicit renameLType
-renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
-renameLWcSigType = renameImplicit renameLSigType
+renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)
+renameLSigWcType = renameImplicit (renameWc renameLType)
renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
renameLKind = renameLType
@@ -205,11 +205,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameType :: HsType Name -> RnM (HsType DocName)
renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
- tyvars' <- renameLTyVarBndrs tyvars
+ tyvars' <- mapM renameLTyVarBndr tyvars
ltype' <- renameLType ltype
return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
- HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do
+ HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
@@ -262,10 +262,10 @@ renameType t = case t of
HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
-renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
-renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
+renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) }
-- This is rather bogus, but I'm not sure what else to do
renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
@@ -330,13 +330,13 @@ renameTyClD d = case d of
SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do
lname' <- renameL lname
- tyvars' <- renameLTyVarBndrs tyvars
+ tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames })
DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do
lname' <- renameL lname
- tyvars' <- renameLTyVarBndrs tyvars
+ tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames })
@@ -344,7 +344,7 @@ renameTyClD d = case d of
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
+ ltyvars' <- renameLHsQTyVars ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
ats' <- mapM (renameLThing renameFamilyDecl) ats
@@ -368,7 +368,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdInjectivityAnn = injectivity }) = do
info' <- renameFamilyInfo info
lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
+ ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
return (FamilyDecl { fdInfo = info', fdLName = lname'
@@ -397,7 +397,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
, con_cxt = lcontext, con_details = details
, con_res = restype, con_doc = mbldoc }) = do
lnames' <- mapM renameL lnames
- ltyvars' <- renameLTyVarBndrs ltyvars
+ ltyvars' <- renameLHsQTyVars ltyvars
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
@@ -435,15 +435,12 @@ renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
TypeSig lnames ltype -> do
lnames' <- mapM renameL lnames
- ltype' <- renameLWcSigType ltype
+ ltype' <- renameLSigWcType ltype
return (TypeSig lnames' ltype')
- PatSynSig lname (flag, qtvs) lreq lprov lty -> do
+ PatSynSig lname sig_ty -> do
lname' <- renameL lname
- qtvs' <- renameLTyVarBndrs qtvs
- lreq' <- renameLContext lreq
- lprov' <- renameLContext lprov
- lty' <- renameLSigType lty
- return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
+ sig_ty' <- renameLSigType sig_ty
+ return $ PatSynSig lname' sig_ty'
FixSig (FixitySig lnames fixity) -> do
lnames' <- mapM renameL lnames
return $ FixSig (FixitySig lnames' fixity)
@@ -478,7 +475,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_poly_ty =ltype, cid_tyfam_insts = lATs
, cid_datafam_insts = lADTs }) = do
- ltype' <- renameLType ltype
+ ltype' <- renameLSigType ltype
lATs' <- mapM (mapM renameTyFamInstD) lATs
lADTs' <- mapM (mapM renameDataFamInstD) lADTs
return (ClsInstDecl { cid_overlap_mode = omode
@@ -505,7 +502,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs
renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
= do { tc' <- renameL tc
- ; tvs' <- renameLTyVarBndrs tvs
+ ; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
; return (L loc (TyFamEqn { tfe_tycon = tc'
, tfe_pats = tvs'
@@ -526,15 +523,15 @@ renameImplicit :: (in_thing -> RnM out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
- , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder })
+ , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
- -> HsWildcardBndrs Name in_thing
- -> RnM (HsWildcardBndrs DocName out_thing)
+ -> HsWildCardBndrs Name in_thing
+ -> RnM (HsWildCardBndrs DocName out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
- , hswc_wcs = PlaceHolder, hswc_ctx = Nothing })
+ , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
renameExportItem item = case item of
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 3964c86a..6a499f64 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -16,6 +16,7 @@ module Haddock.Utils (
-- * Misc utilities
restrictTo, emptyHsQTvs,
toDescription, toInstalledDescription,
+ mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
@@ -124,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo
mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc { _doc = x }
+mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)
+
+addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
+-- Add the class context to a class-op signature
+addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype))
+ = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
+ -- The mkEmptySigWcType is suspicious
+ where
+ go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))
+ = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })
+ go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })
+ go (L loc ty)
+ = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+
+ extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
+ add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
+
+lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
+lHsQTyVarsToTypes tvs
+ = [ noLoc (HsTyVar (hsLTyVarName tv))
+ | tv <- hsQTvBndrs tvs ]
+
--------------------------------------------------------------------------------
-- * Making abstract declarations
--------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-03 21:40:17 +0000