aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/Create.hs12
-rw-r--r--src/Haddock/Interface/Rename.hs80
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 6034688e..7417d234 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -325,22 +325,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
@@ -349,15 +338,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
@@ -366,7 +376,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
@@ -383,14 +393,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
@@ -413,14 +415,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