diff options
Diffstat (limited to 'src/Haddock/Interface')
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 12 | ||||
| -rw-r--r-- | src/Haddock/Interface/Rename.hs | 80 |
2 files changed, 51 insertions, 41 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 00f1319c..5029dce8 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -188,7 +188,7 @@ mkMaps dflags gre instances exports decls = do let subNames = map fst subDocs let names = case d of - InstD (ClsInstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. + InstD (ClsInstD (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. _ -> filter (`elem` exports) (getMainDeclBinder d) let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs)) @@ -217,7 +217,7 @@ subordinates (TyClD decl) ] dataSubs = constrs ++ fields where - cons = map unL $ tcdCons decl + cons = map unL $ (td_cons (tcdTyDefn 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) @@ -233,7 +233,7 @@ typeDocs d = case d of SigD (TypeSig _ ty) -> docs (unLoc ty) ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) - TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty) + TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) @@ -295,7 +295,7 @@ warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () warnAboutFilteredDecls mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ tcdName d | L _ (InstD (FamInstDecl d)) <- decls ] + nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD d)) <- decls ] unless (null typeInstances) $ tell [ @@ -304,7 +304,7 @@ warnAboutFilteredDecls mdl decls = do ++ "will be filtered out:\n " ++ concat (intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (ClsInstDecl i _ _ ats)) <- decls + let instances = nub [ pretty i | L _ (InstD (ClsInstD i _ _ ats)) <- decls , not (null ats) ] unless (null instances) $ @@ -644,7 +644,7 @@ 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 (tcdCons d) + L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d)) in L pos (SigD sig) _ -> error "internal: extractDecl" where diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 0e75fef7..1c54216b 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -327,22 +327,11 @@ renameTyClD d = case d of -- return (TyFamily flav lname' ltyvars' kind' tckind) return (TyFamily flav lname' ltyvars' tckind') - TyData x lcontext lname cType ltyvars typats k cons _ -> do - lcontext' <- renameLContext lcontext + TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - typats' <- mapM (mapM renameLType) typats - k' <- renameMaybeLKind k - cons' <- mapM renameLCon cons - -- I don't think we need the derivings, so we return Nothing - return (TyData x lcontext' lname' cType ltyvars' typats' k' cons' Nothing) - - TySynonym lname ltyvars typats ltype fvs -> do - lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - ltype' <- renameLType ltype - typats' <- mapM (mapM renameLType) typats - return (TySynonym lname' ltyvars' typats' ltype' fvs) + tyvars' <- mapM renameLTyVarBndr tyvars + defn' <- renameTyDefn defn + return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs }) ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do lcontext' <- renameLContext lcontext @@ -351,15 +340,36 @@ renameTyClD d = case d of lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats - at_defs' <- mapM renameLTyClD at_defs + at_defs' <- mapM (mapM renameFamInstD) at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' []) where - renameLCon (L loc con) = return . L loc =<< renameCon con - renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do + renameLFunDep (L loc (xs, ys)) = do + xs' <- mapM rename xs + ys' <- mapM rename ys + return (L loc (xs', ys')) + + 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 + 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' }) + +renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- renameLContext lcontext @@ -368,7 +378,7 @@ renameTyClD d = case d of mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' }) - + where renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do @@ -385,14 +395,6 @@ renameTyClD d = case d of renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) - - renameLSig (L loc sig) = return . L loc =<< renameSig sig - - renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do @@ -415,14 +417,22 @@ renameForD (ForeignExport lname ltype co x) = do renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -renameInstD (ClsInstDecl ltype _ _ lATs) = do +renameInstD (ClsInstD ltype _ _ lATs) = do ltype' <- renameLType ltype - lATs' <- mapM renameLTyClD lATs - return (ClsInstDecl ltype' emptyBag [] lATs') + lATs' <- mapM (mapM renameFamInstD) lATs + return (ClsInstD ltype' emptyBag [] lATs') + +renameInstD (FamInstD d) = do + d' <- renameFamInstD d + return (FamInstD d') + +renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName) +renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = HsBSig pats fvs, fid_defn = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; defn' <- renameTyDefn defn + ; return (FamInstDecl { fid_tycon = tc', fid_pats = HsBSig pats' fvs, fid_defn = defn' }) } -renameInstD (FamInstDecl d) = do - d' <- renameTyClD d - return (FamInstDecl d') renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of |