From ec20bd15e724d580a01d9fad98791bb53db5e57c 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/Interface/Create.hs | 48 ++++++++------------------- haddock-api/src/Haddock/Interface/Rename.hs | 51 ++++++++++++++--------------- 2 files changed, 38 insertions(+), 61 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') 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 -- cgit v1.2.3