aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs10
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs24
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs24
-rw-r--r--haddock-api/src/Haddock/Convert.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs78
-rw-r--r--haddock-api/src/Haddock/Types.hs10
8 files changed, 82 insertions, 82 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index ef873500..70cdf8a3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -269,7 +269,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
(Map.map SrcExternal extSrcMap)
(Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
- pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap
+ pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap
pkgSrcMap'
| Flag_HyperlinkedSource `elem` flags =
Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index a8882fe2..1adcddfc 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -122,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
- f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
- f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
+ f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
f (SigD sig) = ppSig dflags sig ++ ppFixities
f _ = []
@@ -157,10 +157,10 @@ ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods
where
- ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl
- ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
+ ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
+ ppSig' = flip (ppSigWithDoc dflags) subdocs
- add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
+ add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
ppTyFams
| null $ tcdATs decl = ""
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 5eca973e..060534bf 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
module Haddock.Backends.Hyperlinker.Ast (enrich) where
@@ -10,6 +11,7 @@ import Haddock.Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
+import qualified FieldLabel as GHC
import Control.Applicative
import Data.Data
@@ -56,8 +58,8 @@ variables =
where
var term = case cast term of
(Just (GHC.L sspan (GHC.HsVar name))) ->
- pure (sspan, RtkVar name)
- (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) ->
+ pure (sspan, RtkVar (GHC.unLoc name))
+ (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
pure (sspan, RtkVar name)
_ -> empty
rec term = case cast term of
@@ -72,7 +74,7 @@ types =
where
ty term = case cast term of
(Just (GHC.L sspan (GHC.HsTyVar name))) ->
- pure (sspan, RtkType name)
+ pure (sspan, RtkType (GHC.unLoc name))
_ -> empty
-- | Obtain details map for identifier bindings.
@@ -85,12 +87,12 @@ binds =
everything (<|>) (fun `combine` pat `combine` tvar)
where
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->
pure (sspan, RtkBind name)
_ -> empty
pat term = case cast term of
(Just (GHC.L sspan (GHC.VarPat name))) ->
- pure (sspan, RtkBind name)
+ pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
[(sspan, RtkVar name)] ++ everything (<|>) rec recs
(Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
@@ -102,7 +104,7 @@ binds =
_ -> empty
tvar term = case cast term of
(Just (GHC.L sspan (GHC.UserTyVar name))) ->
- pure (sspan, RtkBind name)
+ pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
@@ -121,7 +123,7 @@ decls (group, _, _, _) = concatMap ($ group)
GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
@@ -134,9 +136,10 @@ decls (group, _, _, _) = concatMap ($ group)
pure . tyref $ GHC.tfe_tycon eqn
_ -> empty
fld term = case cast term of
- Just field -> map decl $ GHC.cd_fld_names field
+ Just (field :: GHC.ConDeclField GHC.Name)
+ -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
- sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names
+ sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
sig _ = []
decl (GHC.L sspan name) = (sspan, RtkDecl name)
tyref (GHC.L sspan name) = (sspan, RtkType name)
@@ -153,7 +156,8 @@ imports src@(_, imps, _, _) =
(Just (GHC.IEVar v)) -> pure $ var v
(Just (GHC.IEThingAbs t)) -> pure $ typ t
(Just (GHC.IEThingAll t)) -> pure $ typ t
- (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
+ (Just (GHC.IEThingWith t _ vs _fls)) ->
+ [typ t] ++ map var vs
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
var (GHC.L sspan name) = (sspan, RtkVar name)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 124debfb..ae1905bf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -270,24 +270,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
) <+>
ppFamDeclBinderWithVars summary d <+>
-
- (case result of
- NoSig -> noHtml
- KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
- TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
- ) <+>
+ ppResultSig result unicode qual <+>
(case injectivity of
Nothing -> noHtml
Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
)
+ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html
+ppResultSig result unicode qual = case result of
+ NoSig -> noHtml
+ KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+
ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
-> Html
ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
ppFamilyInfo True pfdInfo <+>
ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
- ppFamilyKind unicode qual pfdKindSig
+ ppResultSig (unLoc pfdKindSig) unicode qual
ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
@@ -530,7 +531,7 @@ ppClassDecl summary links instances fixities loc d subdocs
minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
- sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns]
+ sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]
-> noHtml
-- Minimal complete definition = the only shown method
@@ -612,9 +613,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-> [Sig DocName]
-> [Html]
ppInstanceSigs links splice unicode qual sigs = do
- TypeSig lnames (L loc typ) _ <- sigs
+ TypeSig lnames typ <- sigs
let names = map unLoc lnames
- return $ ppSimpleSig links splice unicode qual loc names typ
+ L loc rtyp = get_type typ
+ return $ ppSimpleSig links splice unicode qual loc names rtyp
+ where
+ get_type = hswc_body . hsib_body
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 664598ab..4a7ad162 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -100,14 +100,8 @@ tyThingToLHsDecl t = case t of
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
- qtvs = univ_tvs ++ ex_tvs
- ty = mkFunTys arg_tys res_ty
- in allOK . SigD $ PatSynSig (synifyName ps)
- (Implicit, synifyTyVars qtvs)
- (synifyCtx req_theta)
- (synifyCtx prov_theta)
- (synifyType WithinType ty)
+ allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType
+ (patSynType ps))
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -457,5 +451,5 @@ synifyFamInst fi opaque = do
return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
ityp (DataFamilyInst c) =
DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
- (ks,ts) = partitionInvisibles (classTyCon cls) id $ fi_tys fi
+ (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
synifyTypes = map (unLoc. synifyType WithinType)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e3a5a7d5..859afe6e 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -294,7 +294,7 @@ renameInstHead InstHead {..} = do
itype <- case ihdInstType of
ClassInst { .. } -> ClassInst
<$> mapM renameType clsiCtx
- <*> renameLTyVarBndrs clsiTyVars
+ <*> renameLHsQTyVars clsiTyVars
<*> mapM renameSig clsiSigs
<*> mapM renamePseudoFamilyDecl clsiAssocTys
TypeInst ts -> TypeInst <$> traverse renameType ts
@@ -390,7 +390,7 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
<$> renameFamilyInfo pfdInfo
<*> renameL pfdLName
<*> mapM renameLType pfdTyVars
- <*> renameMaybeLKind pfdKindSig
+ <*> renameFamilyResultSig pfdKindSig
renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index d6466570..e9b9c60a 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name)
specialize name details =
everywhere $ mkT step
where
- step (HsTyVar name') | name == name' = details
+ step (HsTyVar (L _ name')) | name == name' = details
step typ = typ
@@ -56,18 +56,18 @@ specialize' = flip $ foldr (uncurry specialize)
-- length of type list should be the same as the number of binders.
specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
=> Data a
- => LHsTyVarBndrs name -> [HsType name]
+ => LHsQTyVars name -> [HsType name]
-> a -> a
specializeTyVarBndrs bndrs typs =
specialize' $ zip bndrs' typs
where
- bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
- bname (UserTyVar name) = name
+ bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
+ bname (UserTyVar (L _ name)) = name
bname (KindedTyVar (L _ name) _) = name
specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
- => LHsTyVarBndrs name -> [HsType name]
+ => LHsQTyVars name -> [HsType name]
-> PseudoFamilyDecl name
-> PseudoFamilyDecl name
specializePseudoFamilyDecl bndrs typs decl =
@@ -76,14 +76,17 @@ specializePseudoFamilyDecl bndrs typs decl =
specializeTyVars = specializeTyVarBndrs bndrs typs
-specializeSig :: (Eq name, Typeable name, DataId name, SetName name)
- => LHsTyVarBndrs name -> [HsType name]
+specializeSig :: forall name . (Eq name, Typeable name, DataId name, SetName name)
+ => LHsQTyVars name -> [HsType name]
-> Sig name
-> Sig name
-specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
- TypeSig lnames (L loc typ') prn
+specializeSig bndrs typs (TypeSig lnames typ) =
+ TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})
where
- typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ
+ true_type :: HsType name
+ true_type = unLoc (hswc_body (hsib_body typ))
+ typ' :: HsType name
+ typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
fv = foldr Set.union Set.empty . map freeVariables $ typs
specializeSig _ _ sig = sig
@@ -120,7 +123,7 @@ sugar =
sugarLists :: NamedThing name => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)
+sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
name' = getName name
@@ -134,7 +137,7 @@ sugarTuples typ =
where
aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy (L _ typ')) = aux apps typ'
- aux apps (HsTyVar name)
+ aux apps (HsTyVar (L _ name))
| isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
where
name' = getName name
@@ -146,8 +149,8 @@ sugarTuples typ =
sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb)
- | isSymOcc $ getOccName name' = mkHsOpTy la (L loc name) lb
+sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar (L l name))) la)) lb)
+ | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
| isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
where
name' = getName name
@@ -219,13 +222,13 @@ freeVariables =
everythingWithState Set.empty Set.union query
where
query term ctx = case cast term :: Maybe (HsType name) of
- Just (HsForAllTy _ _ bndrs _ _) ->
+ Just (HsForAllTy bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
- Just (HsTyVar name)
+ Just (HsTyVar (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getNameRep name, ctx)
_ -> (Set.empty, ctx)
- bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
+ bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
-- | Make given type visually unambiguous.
@@ -256,26 +259,26 @@ data RenameEnv name = RenameEnv
renameType :: SetName name => HsType name -> Rename name (HsType name)
-renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' ->
+renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->
HsForAllTy
- <$> pure ex
- <*> pure mspan
- <*> pure lbndrs'
- <*> located renameContext lctx
+ <$> pure bndrs'
<*> renameLType lt
-renameType (HsTyVar name) = HsTyVar <$> renameName name
+renameType (HsQualTy lctxt lt) =
+ HsQualTy
+ <$> located renameContext lctxt
+ <*> renameLType lt
+renameType (HsTyVar name) = HsTyVar <$> located renameName name
renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
renameType (HsListTy lt) = HsListTy <$> renameLType lt
renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
renameType (HsOpTy la lop lb) =
- HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb
+ HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
renameType (HsParTy lt) = HsParTy <$> renameLType lt
renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
-renameType t@(HsQuasiQuoteTy _) = pure t
renameType t@(HsSpliceTy _ _) = pure t
renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
@@ -286,9 +289,7 @@ renameType (HsExplicitListTy ph ltys) =
renameType (HsExplicitTupleTy phs ltys) =
HsExplicitTupleTy phs <$> renameLTypes ltys
renameType t@(HsTyLit _) = pure t
-renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
-renameType HsWildcardTy = pure HsWildcardTy
-renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
+renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
@@ -302,21 +303,20 @@ renameLTypes = mapM renameLType
renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
renameContext = renameLTypes
-
+{-
renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
+-}
renameName :: SetName name => name -> Rename name name
renameName name = do
RenameEnv { rneCtx = ctx } <- ask
- pure $ case Map.lookup (getName name) ctx of
- Just name' -> name'
- Nothing -> name
+ pure $ fromMaybe name (Map.lookup (getName name) ctx)
rebind :: SetName name
- => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a)
+ => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a)
-> Rename name a
rebind lbndrs action = do
(lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
@@ -324,16 +324,14 @@ rebind lbndrs action = do
rebindLTyVarBndrs :: SetName name
- => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name)
-rebindLTyVarBndrs lbndrs = do
- tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs
- pure $ lbndrs { hsq_tvs = tys' }
+ => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]
+rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs
rebindTyVarBndr :: SetName name
=> HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
-rebindTyVarBndr (UserTyVar name) =
- UserTyVar <$> rebindName name
+rebindTyVarBndr (UserTyVar (L l name)) =
+ UserTyVar . L l <$> rebindName name
rebindTyVarBndr (KindedTyVar name kinds) =
KindedTyVar <$> located rebindName name <*> pure kinds
@@ -403,5 +401,5 @@ located f (L loc e) = L loc <$> f e
tyVarName :: HsTyVarBndr name -> name
-tyVarName (UserTyVar name) = name
+tyVarName (UserTyVar name) = unLoc name
tyVarName (KindedTyVar (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e07f55f1..6bc00f63 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -326,7 +326,7 @@ instance SetName DocName where
data InstType name
= ClassInst
{ clsiCtx :: [HsType name]
- , clsiTyVars :: LHsTyVarBndrs name
+ , clsiTyVars :: LHsQTyVars name
, clsiSigs :: [Sig name]
, clsiAssocTys :: [PseudoFamilyDecl name]
}
@@ -353,7 +353,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl
{ pfdInfo :: FamilyInfo name
, pfdLName :: Located name
, pfdTyVars :: [LHsType name]
- , pfdKindSig :: Maybe (LHsKind name)
+ , pfdKindSig :: LFamilyResultSig name
}
@@ -361,14 +361,14 @@ mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
{ pfdInfo = fdInfo
, pfdLName = fdLName
- , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_tvs fdTyVars ]
- , pfdKindSig = fdKindSig
+ , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ]
+ , pfdKindSig = fdResultSig
}
where
mkType (KindedTyVar (L loc name) lkind) =
HsKindSig tvar lkind
where
- tvar = L loc (HsTyVar name)
+ tvar = L loc (HsTyVar (L loc name))
mkType (UserTyVar name) = HsTyVar name
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 15:54:56 +0000