From 5628084e7a9d7bf8ec083cd93321eaa6ac686b4a Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 17:34:18 +0000 Subject: Follow changes to HsTYpe Not yet complete (but on a wip/ branch) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 35 ++++++++------------ haddock-api/src/Haddock/Convert.hs | 46 ++++++++++++++------------ haddock-api/src/Haddock/Interface/Create.hs | 48 ++++++++------------------- haddock-api/src/Haddock/Interface/Rename.hs | 51 ++++++++++++++--------------- haddock-api/src/Haddock/Utils.hs | 29 ++++++++++++++++ 5 files changed, 105 insertions(+), 104 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index afa694e3..1d85b474 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -122,8 +122,8 @@ 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 subdocs - 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 ++ ppFixities f _ = [] @@ -135,31 +135,33 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) - ++ [mkSig n] - mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ + ++ [pp_sig dflags names (hsSigWcType sig)] getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) - typ = unL (hsSigType sig) + typ = unL (hsSigWcType sig) ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] ppSig dflags x = ppSigWithDoc dflags x [] +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 -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods +ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where - decl' = decl - { tcdSigs = [], tcdMeths = emptyBag - , tcdATs = [], tcdATDefs = [] - } - ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl + ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext + add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x) + ppTyFams | null $ tcdATs decl = "" | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat @@ -173,17 +175,6 @@ ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods , rbrace ] - 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 decl) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) - tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index bad99f24..7f807569 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -97,17 +97,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) @@ -317,16 +310,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 @@ -338,12 +331,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 @@ -361,6 +356,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) @@ -399,11 +403,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 7a5eb8d7..11906efa 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -353,15 +353,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 @@ -740,8 +739,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)) @@ -785,17 +784,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 }) -> @@ -809,24 +808,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 @@ -835,7 +816,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)] @@ -845,7 +826,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 61eb6cde..3a170f4a 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) @@ -338,13 +338,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 }) @@ -352,7 +352,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 @@ -376,7 +376,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' @@ -415,7 +415,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 @@ -453,15 +453,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) @@ -496,7 +493,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 @@ -523,7 +520,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' @@ -544,15 +541,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 -------------------------------------------------------------------------------- -- cgit v1.2.3