aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs21
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs21
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs3
3 files changed, 32 insertions, 13 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c72d5f38..c9290ed0 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1076,8 +1076,8 @@ extractDecl declMap name decl
TyClD _ d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
in if isDataConName name
- then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
+ else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
@@ -1116,8 +1116,7 @@ extractDecl declMap name decl
O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"
O.$$ O.nest 4 (O.ppr decl)
-
-extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
+extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
extractPatternSyn nm t tvs cons =
case filter matches cons of
[] -> error "extractPatternSyn: constructor pattern not found"
@@ -1145,9 +1144,13 @@ extractPatternSyn nm t tvs cons =
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
+ mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty
+ mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki
+ mkAppTyArg f (HsArgPar _) = HsParTy noExt f
-extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
+extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
-> LSig GhcRn
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
@@ -1163,7 +1166,11 @@ extractRecSel nm t tvs (L _ con : rest) =
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
+ mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty
+ mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki
+ mkAppTyArg f (HsArgPar _) = HsParTy noExt f
-- | Keep export items with docs.
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index c6160b2b..57e6d699 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -183,6 +183,13 @@ renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI)
renameLType = mapM renameType
+renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI)
+renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty
+ ; return $ HsValArg ty' }
+renameLTypeArg (HsTypeArg ki) = do { ki' <- renameLKind ki
+ ; return $ HsTypeArg ki' }
+renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp
+
renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
renameLSigType = renameImplicit renameLType
@@ -238,6 +245,11 @@ renameType t = case t of
b' <- renameLType b
return (HsAppTy NoExt a' b')
+ HsAppKindTy _ a b -> do
+ a' <- renameLType a
+ b' <- renameLKind b
+ return (HsAppKindTy NoExt a' b')
+
HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
@@ -274,7 +286,7 @@ renameType t = case t of
HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ s -> renameHsSpliceTy s
- HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
+ HsWildCardTy a -> pure (HsWildCardTy a)
-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
@@ -309,9 +321,6 @@ renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo
-renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name))
-
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
cname <- rename ihdClsName
@@ -603,7 +612,7 @@ renameTyFamInstEqn eqn
, feqn_rhs = rhs })
= do { tc' <- renameL tc
; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
- ; pats' <- mapM renameLType pats
+ ; pats' <- mapM renameLTypeArg pats
; rhs' <- renameLType rhs
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
@@ -640,7 +649,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
, feqn_rhs = defn })
= do { tc' <- renameL tc
; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
- ; pats' <- mapM renameLType pats
+ ; pats' <- mapM renameLTypeArg pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 5ab3a7ee..6fd528af 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -255,6 +255,7 @@ renameType (HsQualTy x lctxt lt) =
renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
renameType t@(HsStarTy _ _) = pure t
renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
+renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk
renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
@@ -280,6 +281,8 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
+renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn)
+renameLKind = renameLType
renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:13:46 +0000