aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs10
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs9
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs5
-rw-r--r--haddock-api/src/Haddock/Convert.hs18
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs28
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs69
7 files changed, 83 insertions, 61 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 56f8176c..8e4e801e 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -184,11 +184,11 @@ ppClass dflags decl subdocs =
tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn
tyFamEqnToSyn tfe = SynDecl
- { tcdLName = tfe_tycon tfe
- , tcdTyVars = tfe_pats tfe
- , tcdFixity = tfe_fixity tfe
- , tcdRhs = tfe_rhs tfe
- , tcdFVs = emptyNameSet
+ { tcdLName = feqn_tycon tfe
+ , tcdTyVars = feqn_pats tfe
+ , tcdFixity = feqn_fixity tfe
+ , tcdRhs = feqn_rhs tfe
+ , tcdFVs = emptyNameSet
}
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 759a31d4..57ff72ff 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -159,10 +159,11 @@ decls (group, _, _, _) = concatMap ($ group)
++ everythingInRenamedSource fld cdcl
Nothing -> empty
ins term = case cast term of
- (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GhcRn))
- -> pure . tyref $ GHC.dfid_tycon inst
- (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->
- pure . tyref $ GHC.tfe_tycon eqn
+ (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))
+ :: GHC.InstDecl GHC.GhcRn))
+ -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
+ (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->
+ pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
_ -> empty
fld term = case cast term of
Just (field :: GHC.ConDeclField GHC.GhcRn)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 59ad41e4..3b53b1eb 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -318,8 +318,9 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
= ppInstances links (OriginFamily docname) instances splice unicode qual
-- Individual equation of a closed type family
- ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
- , tfe_pats = HsIB { hsib_body = ts }}
+ ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
+ ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs
+ , feqn_pats = ts } })
= ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 36efb3e4..67aa88e1 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -113,20 +113,20 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
= let name = synifyName tc
typats = map (synifyType WithinType) args
hs_rhs = synifyType WithinType rhs
- in TyFamEqn { tfe_tycon = name
- , tfe_pats = HsIB { hsib_body = typats
- , hsib_vars = map tyVarName tkvs
- , hsib_closed = True }
- , tfe_fixity = Prefix
- , tfe_rhs = hs_rhs }
+ in HsIB { hsib_vars = map tyVarName tkvs
+ , hsib_closed = True
+ , hsib_body = FamEqn { feqn_tycon = name
+ , feqn_pats = typats
+ , feqn_fixity = Prefix
+ , feqn_rhs = hs_rhs } }
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| isOpenTypeFamilyTyCon tc
, Just branch <- coAxiomSingleBranch_maybe ax
- = return $ InstD (TyFamInstD
- (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
- , tfid_fvs = placeHolderNamesTc }))
+ = return $ InstD
+ $ TyFamInstD
+ $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }
| Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 561c126f..a1009c1f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -59,12 +59,13 @@ getMainDeclBinder _ = []
-- instanceMap.
getInstLoc :: InstDecl name -> SrcSpan
getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
-getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
+getInstLoc (DataFamInstD (DataFamInstDecl
+ { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
getInstLoc (TyFamInstD (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some reason.
- { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l
+ { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l
-- Useful when there is a signature with multiple names, e.g.
-- foo, bar :: Types..
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 292680a7..62bdbcbe 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -406,11 +406,13 @@ subordinates :: InstMap
-> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
- DataFamInstDecl { dfid_tycon = L l _
- , dfid_defn = defn } <- unLoc <$> cid_datafam_insts d
+ DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_tycon = L l _
+ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
[ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
- InstD (DataFamInstD d) -> dataSubs (dfid_defn d)
+ InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d })))
+ -> dataSubs (feqn_rhs d)
TyClD d | isClassDecl d -> classSubs d
| isDataDecl d -> dataSubs (tcdDataDefn d)
_ -> []
@@ -1004,17 +1006,19 @@ extractDecl name decl
in if isDataConName name
then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
- InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
- , dfid_pats = HsIB { hsib_body = tys }
- , dfid_defn = defn }) ->
+ InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =
+ FamEqn { feqn_tycon = L _ n
+ , feqn_pats = tys
+ , feqn_rhs = defn }}))) ->
SigD <$> extractRecSel name n tys (dd_cons defn)
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
- let matches = [ d | L _ d <- insts
- -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
- , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d))
- , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
- , L _ n <- ns
- , selectorFieldOcc n == name
+ let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
+ <- insts
+ -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
+ , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))
+ , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
+ , L _ n <- ns
+ , selectorFieldOcc n == name
]
in case matches of
[d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 2e9a311a..70962d9c 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -415,7 +415,7 @@ renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI)
renameFamilyInfo DataFamily = return DataFamily
renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
renameFamilyInfo (ClosedTypeFamily eqns)
- = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns
+ = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns
; return $ ClosedTypeFamily eqns' }
renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)
@@ -542,39 +542,54 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
- = do { eqn' <- renameLTyFamInstEqn eqn
- ; return (TyFamInstDecl { tfid_eqn = eqn'
- , tfid_fvs = placeHolderNames }) }
-
-renameLTyFamInstEqn :: LTyFamInstEqn GhcRn -> RnM (LTyFamInstEqn DocNameI)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs }))
- = do { tc' <- renameL tc
- ; pats' <- renameImplicit (mapM renameLType) pats
- ; rhs' <- renameLType rhs
- ; return (L loc (TyFamEqn { tfe_tycon = tc'
- , tfe_pats = pats'
- , tfe_fixity = fixity
- , tfe_rhs = rhs' })) }
+ = do { eqn' <- renameTyFamInstEqn eqn
+ ; return (TyFamInstDecl { tfid_eqn = eqn' }) }
+
+renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
+renameTyFamInstEqn eqn
+ = renameImplicit rename_ty_fam_eqn eqn
+ where
+ rename_ty_fam_eqn
+ :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
+ -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
+ rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
+ , feqn_fixity = fixity, feqn_rhs = rhs })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType pats
+ ; rhs' <- renameLType rhs
+ ; return (FamEqn { feqn_tycon = tc'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' }) }
renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)
-renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs }))
+renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
+ , feqn_fixity = fixity, feqn_rhs = rhs }))
= do { tc' <- renameL tc
; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
- ; return (L loc (TyFamEqn { tfe_tycon = tc'
- , tfe_pats = tvs'
- , tfe_fixity = fixity
- , tfe_rhs = rhs' })) }
+ ; return (L loc (FamEqn { feqn_tycon = tc'
+ , feqn_pats = tvs'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' })) }
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn })
- = do { tc' <- renameL tc
- ; pats' <- renameImplicit (mapM renameLType) pats
- ; defn' <- renameDataDefn defn
- ; return (DataFamInstDecl { dfid_tycon = tc'
- , dfid_pats = pats'
- , dfid_fixity = fixity
- , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
+renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
+ = do { eqn' <- renameImplicit rename_data_fam_eqn eqn
+ ; return (DataFamInstDecl { dfid_eqn = eqn' }) }
+ where
+ rename_data_fam_eqn
+ :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
+ -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
+ rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
+ , feqn_fixity = fixity, feqn_rhs = defn })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType pats
+ ; defn' <- renameDataDefn defn
+ ; return (FamEqn { feqn_tycon = tc'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = defn' }) }
renameImplicit :: (in_thing -> RnM out_thing)
-> HsImplicitBndrs GhcRn in_thing
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:19:28 +0000