aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs5
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs3
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs15
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs17
-rw-r--r--haddock-api/src/Haddock/Types.hs3
6 files changed, 21 insertions, 26 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 63b12a14..d52c136f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -39,6 +39,7 @@ import Data.Char
import Control.Monad
import Data.Maybe
import Data.List ( sort )
+import Data.Void ( absurd )
import Prelude hiding ((<>))
import Haddock.Doc (combineDocumentation)
@@ -530,7 +531,7 @@ ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc)
tyvarNames :: LHsQTyVars DocNameI -> [Name]
-tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit
+tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -1080,7 +1081,7 @@ ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)
ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind
ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
-ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty (HsSpliceTy v _) _ = absurd v
ppr_mono_ty (HsRecTy {}) _ = text "{..}"
ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index b450dc94..25669ca7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -32,6 +32,7 @@ import Haddock.Doc (combineDocumentation)
import Data.List ( intersperse, sort )
import qualified Data.Map as Map
import Data.Maybe
+import Data.Void ( absurd )
import Text.XHtml hiding ( name, title, p, quote )
import BasicTypes (PromotionFlag(..), isPromoted)
@@ -1215,7 +1216,7 @@ ppr_mono_ty (HsKindSig _ ty kind) u q e =
ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts
-ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v
ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 77d6ec39..f600997a 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -165,18 +165,17 @@ nubByName f ns = go emptyNameSet ns
where
y = f x
+
-- ---------------------------------------------------------------------
-- These functions are duplicated from the GHC API, as they must be
-- instantiated at DocNameI instead of (GhcPass _).
-hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName
-hsTyVarNameI (UserTyVar _ (L _ n)) = n
-hsTyVarNameI (KindedTyVar _ (L _ n) _) = n
-hsTyVarNameI (XTyVarBndr nec) = noExtCon nec
-
-hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName
-hsLTyVarNameI = hsTyVarNameI . unLoc
+-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)
+hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n
+hsTyVarBndrName (UserTyVar _ name) = unLoc name
+hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name
+hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec
getConNamesI :: ConDecl DocNameI -> [Located DocName]
getConNamesI ConDeclH98 {con_name = name} = [name]
@@ -311,7 +310,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
[] -> defn { dd_ND = DataType, dd_cons = [] }
[con] -> defn { dd_cons = [con] }
_ -> error "Should not happen"
-restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"
+restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec
restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 0b122b07..ce3878b8 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -313,7 +313,7 @@ renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))
= do { n' <- rename n
; kind' <- renameLKind kind
; return (L loc (KindedTyVar x (L lv n') kind')) }
-renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr"
+renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec
renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
@@ -512,7 +512,7 @@ renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc sel lbl)) = do
sel' <- rename sel
return $ L l (FieldOcc sel' lbl)
-renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc"
+renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 03cc1b7e..19b03596 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -9,6 +9,7 @@ module Haddock.Interface.Specialize
) where
+import Haddock.GhcUtils ( hsTyVarBndrName )
import Haddock.Syb
import Haddock.Types
@@ -56,13 +57,9 @@ specialize specs = go spec_map0
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
-specializeTyVarBndrs bndrs typs =
- specialize $ zip bndrs' typs
+specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs
where
- bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
- bname (UserTyVar _ (L _ name)) = name
- bname (KindedTyVar _ (L _ name) _) = name
- bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
+ bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs
@@ -212,7 +209,7 @@ freeVariables =
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx)
- bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
+ bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)
-- | Make given type visually unambiguous.
@@ -295,7 +292,7 @@ renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname
renameBinder (KindedTyVar x lname lkind) =
KindedTyVar x <$> located renameName lname <*> located renameType lkind
-renameBinder (XTyVarBndr _) = error "haddock:renameBinder"
+renameBinder (XTyVarBndr nec) = noExtCon nec
-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
@@ -349,7 +346,3 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
-tyVarName :: HsTyVarBndr name -> IdP name
-tyVarName (UserTyVar _ name) = unLoc name
-tyVarName (KindedTyVar _ (L _ name) _) = name
-tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 28e3caed..ec76fb72 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -35,6 +35,7 @@ import Control.Monad.IO.Class (MonadIO(..))
import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
+import Data.Void (Void)
import Documentation.Haddock.Types
import BasicTypes (Fixity(..), PromotionFlag(..))
@@ -713,7 +714,7 @@ type instance XOpTy DocNameI = NoExtField
type instance XParTy DocNameI = NoExtField
type instance XIParamTy DocNameI = NoExtField
type instance XKindSig DocNameI = NoExtField
-type instance XSpliceTy DocNameI = NoExtField
+type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy`
type instance XDocTy DocNameI = NoExtField
type instance XBangTy DocNameI = NoExtField
type instance XRecTy DocNameI = NoExtField
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 09:42:21 +0000