diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-12-23 15:50:28 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-12-23 15:50:28 +0000 |
commit | 47be31308f5c90c4ae5e78252989c7da70b46e70 (patch) | |
tree | 46a2c53b699113671eab58bc95f9bd360ad5c828 /src/Haddock/Interface | |
parent | 45e5d834d473ab2f5930371e272a438590bc3f7e (diff) | |
parent | 8bdd26e3d2864151c4d0dccbc530c2deac362892 (diff) |
Merge branch 'master' of http://darcs.haskell.org//haddock
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r-- | src/Haddock/Interface/AttachInstances.hs | 2 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 25 | ||||
-rw-r--r-- | src/Haddock/Interface/Rename.hs | 102 |
3 files changed, 82 insertions, 47 deletions
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index a4d4764e..86d1a7b8 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -53,7 +53,7 @@ attachToExportItem :: Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name - attachToExportItem iface ifaceMap instIfaceMap export = case export of ExportDecl { expItemDecl = L _ (TyClD d) } -> do - mb_info <- getAllInfo (unLoc (tcdLName d)) + mb_info <- getAllInfo (tcdName d) let export' = export { expItemInstances = diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 9fca453d..8f429d9c 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -268,7 +268,7 @@ mkMaps dflags gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] names :: HsDecl Name -> [Name] - names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2]. + names (InstD (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ }))) = maybeToList (M.lookup l instanceMap) -- See note [2]. names decl = getMainDeclBinder decl -- Note [2]: @@ -296,7 +296,7 @@ subordinates (TyClD decl) ] dataSubs = constrs ++ fields where - cons = map unL $ (td_cons (tcdTyDefn decl)) + cons = map unL $ (dd_cons (tcdDataDefn decl)) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) @@ -312,7 +312,7 @@ typeDocs d = case d of SigD (TypeSig _ ty) -> docs (unLoc ty) ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) - TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty) + TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) @@ -331,7 +331,7 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls docs = mkDecls tcdDocs DocD class_ defs = mkDecls (bagToList . tcdMeths) ValD class_ sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs TyClD class_ + ats = mkDecls tcdATs (TyClD . FamDecl) class_ -- | The top-level declarations of a module that we care about, @@ -374,7 +374,11 @@ warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM () warnAboutFilteredDecls dflags mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ] + nub (concat [[ unLoc (tfie_tycon eqn) + | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqns = eqns }))) <- decls + , L _ eqn <- eqns ], + [ unLoc (dfid_tycon d) + | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ]]) unless (null typeInstances) $ tell [ @@ -383,8 +387,11 @@ warnAboutFilteredDecls dflags mdl decls = do ++ "will be filtered out:\n " ++ (intercalate ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls - , not (null ats) ] + let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD (ClsInstDecl + { cid_poly_ty = i + , cid_tyfam_insts = ats + , cid_datafam_insts = adts }))) <- decls + , not (null ats) || not (null adts) ] unless (null instances) $ tell [ @@ -734,11 +741,11 @@ extractDecl name mdl decl _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d)) + L pos sig = extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) in L pos (SigD sig) _ -> error "internal: extractDecl" where - name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d)) + name_and_tyvars d = (tcdName d, hsLTyVarLocNames (tyClDeclTyVars d)) toTypeNoLoc :: Located Name -> LHsType Name diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 6109c341..b384886c 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -322,10 +322,8 @@ renameDecl decl = case decl of return (InstD d') _ -> error "renameDecl" - -renameLTyClD :: LTyClDecl Name -> RnM (LTyClDecl DocName) -renameLTyClD (L loc d) = return . L loc =<< renameTyClD d - +renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) +renameLThing fn (L loc x) = return . L loc =<< fn x renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of @@ -334,19 +332,21 @@ renameTyClD d = case d of return (ForeignType lname' b) -- TyFamily flav lname ltyvars kind tckind -> do - TyFamily flav lname ltyvars tckind -> do - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars --- kind' <- renameMaybeLKind kind - tckind' <- renameMaybeLKind tckind --- return (TyFamily flav lname' ltyvars' kind' tckind) - return (TyFamily flav lname' ltyvars' tckind') + FamDecl { tcdFam = decl } -> do + decl' <- renameFamilyDecl decl + return (FamDecl { tcdFam = decl' }) + + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do + lname' <- renameL lname + tyvars' <- renameLTyVarBndrs tyvars + rhs' <- renameLType rhs + return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs }) - TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars - defn' <- renameTyDefn defn - return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs }) + defn' <- renameDataDefn defn + return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -355,8 +355,8 @@ renameTyClD d = case d of ltyvars' <- renameLTyVarBndrs ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs - ats' <- mapM renameLTyClD ats - at_defs' <- mapM (mapM renameFamInstD) at_defs + ats' <- mapM (renameLThing renameFamilyDecl) ats + at_defs' <- mapM (mapM renameTyFamInstD) at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag @@ -370,19 +370,24 @@ renameTyClD d = case d of renameLSig (L loc sig) = return . L loc =<< renameSig sig -renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName) -renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType - , td_kindSig = k, td_cons = cons }) = do +renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) +renameFamilyDecl (FamilyDecl { fdFlavour = flav, fdLName = lname + , fdTyVars = ltyvars, fdKindSig = tckind }) = do + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + tckind' <- renameMaybeLKind tckind + return (FamilyDecl { fdFlavour = flav, fdLName = lname' + , fdTyVars = ltyvars', fdKindSig = tckind' }) + +renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) +renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType + , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- renameLContext lcontext k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType - , td_kindSig = k', td_cons = cons', td_derivs = Nothing }) - -renameTyDefn (TySynonym { td_synRhs = ltype }) = do - ltype' <- renameLType ltype - return (TySynonym { td_synRhs = ltype' }) + return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType + , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars @@ -435,24 +440,47 @@ renameForD (ForeignExport lname ltype co x) = do renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do +renameInstD (ClsInstD { cid_inst = d }) = do + d' <- renameClsInstD d + return (ClsInstD { cid_inst = d' }) +renameInstD (TyFamInstD { tfid_inst = d }) = do + d' <- renameTyFamInstD d + return (TyFamInstD { tfid_inst = d' }) +renameInstD (DataFamInstD { dfid_inst = d }) = do + d' <- renameDataFamInstD d + return (DataFamInstD { dfid_inst = d' }) + +renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) +renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do ltype' <- renameLType ltype - lATs' <- mapM (mapM renameFamInstD) lATs - return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] - , cid_fam_insts = lATs' }) + lATs' <- mapM (mapM renameTyFamInstD) lATs + lADTs' <- mapM (mapM renameDataFamInstD) lADTs + return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] + , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameInstD (FamInstD { lid_inst = d }) = do - d' <- renameFamInstD d - return (FamInstD { lid_inst = d' }) -renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName) -renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = pats_w_bndrs, fid_defn = defn }) +renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) +renameTyFamInstD (TyFamInstDecl { tfid_eqns = eqns , tfid_group = eqn_group }) + = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns + ; return (TyFamInstDecl { tfid_eqns = eqns' + , tfid_group = eqn_group + , tfid_fvs = placeHolderNames }) } + +renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName) +renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs }) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) - ; defn' <- renameTyDefn defn - ; return (FamInstDecl { fid_tycon = tc', fid_pats = pats_w_bndrs { hswb_cts = pats' } - , fid_defn = defn', fid_fvs = placeHolderNames }) } + ; rhs' <- renameLType rhs + ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' } + , tfie_rhs = rhs' }) } +renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; defn' <- renameDataDefn defn + ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' } + , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of |