aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/AttachInstances.hs8
-rw-r--r--src/Haddock/Interface/Create.hs28
-rw-r--r--src/Haddock/Interface/Rename.hs102
3 files changed, 89 insertions, 49 deletions
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 4b5f159d..04c4e5e1 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -58,15 +58,19 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> Exp
attachToExportItem expInfo 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 =
case mb_info of
Just (_, _, instances) ->
+ let insts = map (first synifyInstHead) $ sortImage (first instHead)
+ [ (instanceSig i, getName i) | i <- instances ]
+{- FIXME
let insts = map (first synifyInstHead) $ sortImage (first instHead) $
filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys)
[ (instanceHead' i, getName i) | i <- instances ]
+-}
in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap)
| (inst, name) <- insts ]
Nothing -> []
@@ -96,11 +100,13 @@ lookupInstDoc name iface ifaceMap instIfaceMap =
-- | Like GHC's 'instanceHead' but drops "silent" arguments.
+{- FIXME
instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)
where
dfun = is_dfun ispec
(tvs, theta, cls, tys) = instanceHead ispec
+-}
-- | Drop "silent" arguments. See GHC Note [Silent superclass
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 6c121ad4..40016a0b 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -35,7 +35,7 @@ import qualified Data.Traversable as T
import qualified Packages
import qualified Module
import qualified SrcLoc
-import GHC hiding (flags)
+import GHC
import HscTypes
import Name
import Bag
@@ -192,7 +192,6 @@ moduleWarning dflags gre ws =
WarnSome _ -> return Nothing
WarnAll w -> Just <$> parseWarning dflags gre w
-
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
parseWarning dflags gre w = do
r <- case w of
@@ -280,7 +279,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]:
@@ -308,7 +307,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)
@@ -324,7 +323,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)
@@ -343,7 +342,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,
@@ -386,7 +385,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 [
@@ -395,8 +398,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 [
@@ -747,11 +753,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 9f3a4155..a2499726 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -330,10 +330,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
@@ -342,19 +340,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
@@ -363,8 +363,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
@@ -378,19 +378,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
@@ -446,24 +451,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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:21:22 +0000