aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs78
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs3
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs1
-rw-r--r--haddock-api/src/Haddock/Types.hs17
7 files changed, 75 insertions, 36 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 0ecf7109..a9ffc36e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
module Haddock.Backends.Hyperlinker.Ast (enrich) where
@@ -80,13 +81,16 @@ variables =
everythingInRenamedSource (var `Syb.combine` rec)
where
var term = case cast term of
- (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) ->
+ (Just ((GHC.dL->GHC.L sspan (GHC.HsVar _ name))
+ :: GHC.LHsExpr GHC.GhcRn)) ->
pure (sspan, RtkVar (GHC.unLoc name))
- (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) ->
+ (Just (GHC.dL->GHC.L _ (GHC.RecordCon _
+ (GHC.dL->GHC.L sspan name) _))) ->
pure (sspan, RtkVar name)
_ -> empty
rec term = case cast term of
- Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) ->
+ Just (GHC.HsRecField (GHC.dL->GHC.L sspan name)
+ (_ :: GHC.LHsExpr GHC.GhcRn) _) ->
pure (sspan, RtkVar name)
_ -> empty
@@ -96,9 +100,11 @@ types = everythingInRenamedSource ty
where
ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]
ty term = case cast term of
- (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->
+ (Just ((GHC.dL->GHC.L sspan (GHC.HsTyVar _ _ name))
+ :: GHC.LHsType GHC.GhcRn)) ->
pure (sspan, RtkType (GHC.unLoc name))
- (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) ->
+ (Just ((GHC.dL->GHC.L sspan (GHC.HsOpTy _ l name r))
+ :: GHC.LHsType GHC.GhcRn)) ->
(sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)
_ -> empty
@@ -113,30 +119,38 @@ binds = everythingInRenamedSource
(fun `Syb.combine` pat `Syb.combine` tvar)
where
fun term = case cast term of
- (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
+ (Just (GHC.FunBind _ (GHC.dL->GHC.L sspan name) _ _ _
+ :: GHC.HsBind GHC.GhcRn)) ->
pure (sspan, RtkBind name)
- (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) ->
- pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args
+ (Just (GHC.PatSynBind _
+ (GHC.PSB _ (GHC.dL->GHC.L sspan name) args _ _))) ->
+ pure (sspan, RtkBind name)
+ ++ everythingInRenamedSource patsyn_binds args
_ -> empty
patsyn_binds term = case cast term of
- (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)
+ (Just (GHC.L sspan (name :: GHC.Name))) ->
+ pure (sspan, RtkVar name)
_ -> empty
pat term = case cast term of
- (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->
+ (Just ((GHC.dL->GHC.L sspan (GHC.VarPat _ name))
+ :: GHC.LPat GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
- (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
+ (Just (GHC.dL->GHC.L _
+ (GHC.ConPatIn (GHC.dL->GHC.L sspan name) recs))) ->
[(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
- (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) ->
+ (Just (GHC.dL->GHC.L _ (GHC.AsPat _ (GHC.dL->GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
rec term = case cast term of
- (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) ->
+ (Just (GHC.HsRecField (GHC.dL->GHC.L sspan name)
+ (_ :: GHC.LPat GHC.GhcRn) _)) ->
pure (sspan, RtkVar name)
_ -> empty
tvar term = case cast term of
- (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
+ (Just ((GHC.dL->GHC.L sspan (GHC.UserTyVar _ name))
+ :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
- (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) ->
+ (Just (GHC.dL->GHC.L _ (GHC.KindedTyVar _ (GHC.dL->GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
@@ -149,7 +163,7 @@ decls (group, _, _, _) = concatMap ($ group)
, everythingInRenamedSource (con `Syb.combine` ins)
]
where
- typ (GHC.L _ t) = case t of
+ typ (GHC.dL->GHC.L _ t) = case t of
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
GHC.SynDecl _ name _ _ _ -> pure . decl $ name
GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
@@ -159,9 +173,10 @@ decls (group, _, _, _) = concatMap ($ group)
++ concatMap tyfam tcdATs
GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
fun term = case cast term of
- (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
+ (Just (GHC.FunBind _ (GHC.dL->GHC.L sspan name) _ _ _
+ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
- (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _)))
+ (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.dL->GHC.L sspan name) _ _ _)))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
@@ -182,18 +197,20 @@ decls (group, _, _, _) = concatMap ($ group)
Nothing -> empty
fix term = case cast term of
Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn)
- -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names
+ -> map (\(GHC.dL->GHC.L sspan x) -> (sspan, RtkVar x)) names
Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn)
-> GHC.panic "haddock:decls"
Nothing -> empty
- tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
- tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels"
- sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names
- sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
- sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
+ tyfam (GHC.dL->GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
+ tyfam (GHC.dL->GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels"
+ tyfam _ = GHC.panic "tyfam: Impossible Match"
+
+ sig (GHC.dL->GHC.L _ (GHC.TypeSig _ names _)) = map decl names
+ sig (GHC.dL->GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
+ sig (GHC.dL->GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
sig _ = []
- decl (GHC.L sspan name) = (sspan, RtkDecl name)
- tyref (GHC.L sspan name) = (sspan, RtkType name)
+ decl (GHC.dL->GHC.L sspan name) = (sspan, RtkDecl name)
+ tyref (GHC.dL->GHC.L sspan name) = (sspan, RtkType name)
-- | Obtain details map for import declarations.
--
@@ -204,16 +221,17 @@ imports src@(_, imps, _, _) =
everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var
+ $ GHC.ieLWrappedName v
(Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingWith _ t _ vs _fls)) ->
[typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
(Just (GHC.IEModuleContents _ m)) -> pure $ modu m
_ -> empty
- typ (GHC.L sspan name) = (sspan, RtkType name)
- var (GHC.L sspan name) = (sspan, RtkVar name)
- modu (GHC.L sspan name) = (sspan, RtkModule name)
+ typ (GHC.dL->GHC.L sspan name) = (sspan, RtkType name)
+ var (GHC.dL->GHC.L sspan name) = (sspan, RtkVar name)
+ modu (GHC.dL->GHC.L sspan name) = (sspan, RtkModule name)
imp idecl
| not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl))
| otherwise = Nothing
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 22cb247f..b66116bb 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1,5 +1,7 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index db29c7cf..da8f7a53 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -397,11 +397,11 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d
where
names = exportName item ++ exportSubs item
- exportSubs :: ExportItem name -> [IdP name]
+ exportSubs :: ExportItem DocNameI -> [IdP DocNameI]
exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
exportSubs _ = []
- exportName :: ExportItem name -> [IdP name]
+ exportName :: ExportItem DocNameI -> [IdP DocNameI]
exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)
exportName ExportNoDecl { expItemName } = [expItemName]
exportName _ = []
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index ec8de12a..395c0837 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE TransformListComp #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Html.Decl
@@ -1215,4 +1217,3 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
-
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index e7d80969..cfb91f93 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -48,7 +49,8 @@ isConSym :: OccName -> Bool
isConSym = isLexConSym . occNameFS
-getMainDeclBinder :: HsDecl name -> [IdP name]
+getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
+ HsDecl p -> [IdP p]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
@@ -434,5 +436,3 @@ setStubDir f d = d{ stubDir = Just f
-- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
-- \#included from the .hc file when compiling with -fvia-C.
setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
-
-
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 42281470..c6160b2b 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index ea8ffe5f..7b3c90a2 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
@@ -742,3 +743,19 @@ type instance XHsWC DocNameI _ = NoExt
type instance XHsQTvs DocNameI = NoExt
type instance XConDeclField DocNameI = NoExt
+type instance XXPat DocNameI = Located (Pat DocNameI)
+
+type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI
+instance HasSrcSpan (LPat DocNameI) where
+ -- NB: The following chooses the behaviour of the outer location
+ -- wrapper replacing the inner ones.
+ composeSrcSpan (L sp p) = if sp == noSrcSpan
+ then p
+ else XPat (L sp (stripSrcSpanPat p))
+ -- NB: The following only returns the top-level location, if any.
+ decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p)
+ decomposeSrcSpan p = L noSrcSpan p
+
+stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI
+stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p
+stripSrcSpanPat p = p
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 01:29:45 +0000