From 222954753de7a8a3708baff1d75a4b7c3a675f4b Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 5 Dec 2015 17:33:52 +0200
Subject: Matching changes for #11028
---
haddock-api/src/Haddock/Backends/Hoogle.hs | 19 ++--
haddock-api/src/Haddock/Backends/LaTeX.hs | 71 ++++++++++++++-
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 116 ++++++++-----------------
haddock-api/src/Haddock/Convert.hs | 24 ++---
haddock-api/src/Haddock/GhcUtils.hs | 6 +-
haddock-api/src/Haddock/Interface/Create.hs | 13 +--
haddock-api/src/Haddock/Interface/Rename.hs | 28 +++---
haddock-api/src/Haddock/Utils.hs | 20 ++++-
8 files changed, 176 insertions(+), 121 deletions(-)
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index bc5588af..54dfb193 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -166,8 +166,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
_ -> []
ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dflags dat subdocs con
- = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con)
+ppCtor dflags dat subdocs con@ConDeclH98 {}
+ -- AZ:TODO get rid of the concatMap
+ = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
@@ -180,12 +181,18 @@ ppCtor dflags dat subdocs con
apps = foldl1 (\x y -> reL $ HsAppTy x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
- name = out dflags $ map unL $ con_names con
+ name = out dflags $ map unL $ getConNames con
- resType = case con_res con of
- ResTyH98 -> apps $ map (reL . HsTyVar . reL) $
+ resType = apps $ map (reL . HsTyVar . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
- ResTyGADT _ x -> x
+
+ppCtor dflags _dat subdocs con@ConDeclGADT {}
+ = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
+ where
+ f = [typeSig name (hsib_body $ con_type con)]
+
+ typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
+ name = out dflags $ map unL $ getConNames con
---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4aec7917..223006f3 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -575,14 +575,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
where
cons = dd_cons (tcdDataDefn dataDecl)
- resTy = (con_res . unLoc . head) cons
+ resTy = (unLoc . head) cons
body = catMaybes [constrBit, doc >>= documentationToLaTeX]
(whereBit, leaders)
| null cons = (empty,[])
| otherwise = case resTy of
- ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty)
+ ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
_ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
constrBit
@@ -607,6 +607,71 @@ ppConstrHdr forall tvs ctxt unicode
False -> empty
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
+ -> LConDecl DocName -> LaTeX
+ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
+ leader <->
+ case con_details con of
+
+ PrefixCon args ->
+ decltt (hsep ((header_ unicode <+> ppOcc) :
+ map (ppLParendType unicode) args))
+ <-> rDoc mbDoc <+> nl
+
+ RecCon (L _ fields) ->
+ (decltt (header_ unicode <+> ppOcc)
+ <-> rDoc mbDoc <+> nl)
+ $$
+ doRecordFields fields
+
+ InfixCon arg1 arg2 ->
+ decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
+ ppOcc,
+ ppLParendType unicode arg2 ])
+ <-> rDoc mbDoc <+> nl
+
+ where
+ doRecordFields fields =
+ vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
+
+
+ header_ = ppConstrHdr False tyVars context
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
+ ppOcc = case occ of
+ [one] -> ppBinder one
+ _ -> cat (punctuate comma (map ppBinder occ))
+ tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con))
+ context = unLoc (fromMaybe (noLoc []) (con_cxt con))
+
+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+ -- or also because we want Haddock to do the doc-parsing, not GHC.
+ mbDoc = case getConNames con of
+ [] -> panic "empty con_names"
+ (cn:_) -> lookup (unLoc cn) subdocs >>=
+ fmap _doc . combineDocumentation . fst
+
+ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =
+ leader <->
+ doGADTCon (hsib_body $ con_type con)
+
+ where
+ doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+>
+ ppLType unicode resTy
+ ) <-> rDoc mbDoc
+
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
+ ppOcc = case occ of
+ [one] -> ppBinder one
+ _ -> cat (punctuate comma (map ppBinder occ))
+
+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+ -- or also because we want Haddock to do the doc-parsing, not GHC.
+ mbDoc = case getConNames con of
+ [] -> panic "empty con_names"
+ (cn:_) -> lookup (unLoc cn) subdocs >>=
+ fmap _doc . combineDocumentation . fst
+{- old
+
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
-> LConDecl DocName -> LaTeX
ppSideBySideConstr subdocs unicode leader (L loc con) =
@@ -670,7 +735,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) =
(cn:_) -> lookup (unLoc cn) subdocs >>=
fmap _doc . combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
-
+-}
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 1aa4d954..d49d0949 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -539,11 +539,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
| [] <- cons = dataHeader
- | [lcon] <- cons, ResTyH98 <- resTy,
+ | [lcon] <- cons, isH98,
(cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
- | ResTyH98 <- resTy = dataHeader
+ | isH98 = dataHeader
+++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
| otherwise = (dataHeader <+> keyword "where")
@@ -557,7 +557,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
cons = dd_cons (tcdDataDefn dataDecl)
- resTy = (con_res . unLoc . head) cons
+ isH98 = case unLoc (head cons) of
+ ConDeclH98 {} -> True
+ ConDeclGADT{} -> False
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
@@ -573,7 +575,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
where
docname = tcdName dataDecl
cons = dd_cons (tcdDataDefn dataDecl)
- resTy = (con_res . unLoc . head) cons
+ isH98 = case unLoc (head cons) of
+ ConDeclH98 {} -> True
+ ConDeclGADT{} -> False
header_ = topDeclElem links loc splice [docname] $
ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
@@ -582,15 +586,13 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
whereBit
| null cons = noHtml
- | otherwise = case resTy of
- ResTyGADT _ _ -> keyword "where"
- _ -> noHtml
+ | otherwise = if isH98 then noHtml else keyword "where"
constrBit = subConstructors qual
[ ppSideBySideConstr subdocs subfixs unicode qual c
| c <- cons
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
- (map unLoc (con_names (unLoc c)))) fixities
+ (map unLoc (getConNames (unLoc c)))) fixities
]
instancesBit = ppInstances instances docname unicode qual
@@ -606,8 +608,8 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
-- returns three pieces: header, body, footer so that header & footer can be
-- incorporated into the declaration
ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
-ppShortConstrParts summary dataInst con unicode qual = case con_res con of
- ResTyH98 -> case con_details con of
+ppShortConstrParts summary dataInst con unicode qual = case con of
+ ConDeclH98{} -> case con_details con of
PrefixCon args ->
(header_ unicode qual +++ hsep (ppOcc
: map (ppLParendType unicode qual) args), noHtml, noHtml)
@@ -620,28 +622,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
ppOccInfix, ppLParendType unicode qual arg2],
noHtml, noHtml)
- ResTyGADT _ resTy -> case con_details con of
- -- prefix & infix could use hsConDeclArgTys if it seemed to
- -- simplify the code.
- PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
- -- display GADT records with the new syntax,
- -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
- -- (except each field gets its own line in docs, to match
- -- non-GADT records)
- RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+>
- ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',
- doRecordFields fields,
- char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
- InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
+ ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml)
where
+ resTy = hsib_body (con_type con)
+
doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))
- doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [
- ppForAllCon forall_ ltvs lcontext unicode qual,
- ppLType unicode qual (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall_ tyVars context
- occ = map (nameOccName . getName . unLoc) $ con_names con
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
ppOcc = case occ of
[one] -> ppBinder summary one
@@ -651,12 +640,11 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
[one] -> ppBinderInfix summary one
_ -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
- ltvs = con_qvars con
+ ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)
tyVars = tyvarNames ltvs
- lcontext = con_cxt con
- context = unLoc (con_cxt con)
- forall_ = con_explicit con
- mkFunTy a b = noLoc (HsFunTy a b)
+ lcontext = fromMaybe (noLoc []) (con_cxt con)
+ context = unLoc lcontext
+ forall_ = False
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
@@ -675,11 +663,11 @@ ppConstrHdr forall_ tvs ctxt unicode qual
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
-> Unicode -> Qualification -> LConDecl DocName -> SubDecl
-ppSideBySideConstr subdocs fixities unicode qual (L loc con)
+ppSideBySideConstr subdocs fixities unicode qual (L _ con)
= (decl, mbDoc, fieldPart)
where
- decl = case con_res con of
- ResTyH98 -> case con_details con of
+ decl = case con of
+ ConDeclH98{} -> case con_details con of
PrefixCon args ->
hsep ((header_ +++ ppOcc)
: map (ppLParendType unicode qual) args)
@@ -693,35 +681,25 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con)
ppLParendType unicode qual arg2]
<+> fixity
- ResTyGADT _ resTy -> case con_details con of
- -- prefix & infix could also use hsConDeclArgTys if it seemed to
- -- simplify the code.
- PrefixCon args -> doGADTCon args resTy
- cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+ ConDeclGADT{} -> doGADTCon resTy
+
+ resTy = hsib_body (con_type con)
- fieldPart = case con_details con of
+ fieldPart = case getConDetails con of
RecCon (L _ fields) -> [doRecordFields fields]
_ -> []
doRecordFields fields = subFields qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
- doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
- doGADTCon args resTy = ppOcc <+> dcolon unicode
- <+> ppLType unicode qual (mk_forall $ mk_phi $
- foldr mkFunTy resTy args)
+ doGADTCon :: Located (HsType DocName) -> Html
+ doGADTCon ty = ppOcc <+> dcolon unicode
+ <+> ppLType unicode qual ty
<+> fixity
- mk_phi ty | null context = ty
- | otherwise = L loc (HsQualTy (con_cxt con) ty)
-
- mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
- | otherwise = ty
-
fixity = ppFixities fixities qual
header_ = ppConstrHdr forall_ tyVars context unicode qual
- occ = map (nameOccName . getName . unLoc) $ con_names con
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
ppOcc = case occ of
[one] -> ppBinder False one
@@ -731,15 +709,13 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con)
[one] -> ppBinderInfix False one
_ -> hsep (punctuate comma (map (ppBinderInfix False) occ))
- ltvs = con_qvars con
- tyVars = tyvarNames (con_qvars con)
- context = unLoc (con_cxt con)
- forall_ = con_explicit con
+ tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con))
+ context = unLoc (fromMaybe (noLoc []) (con_cxt con))
+ forall_ = False
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>=
+ mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>=
combineDocumentation . fst
- mkFunTy a b = noLoc (HsFunTy a b)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
@@ -848,24 +824,6 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocName -> Html
ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
--- Drop top-level for-all type variables in user style
--- since they are implicit in Haskell
-
-ppForAllCon :: Bool -> LHsQTyVars DocName
- -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
-ppForAllCon expl tvs cxt unicode qual =
- forall_part <+> ppLContext cxt unicode qual
- where
- forall_part = ppLTyVarBndrs expl tvs unicode qual
-
-ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html
-ppLTyVarBndrs show_forall tvs unicode _qual
- | show_forall
- , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode
- | otherwise = noHtml
- where
- tv_bndrs = hsQTvBndrs tvs
-
ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html
ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
@@ -898,7 +856,9 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO
ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q =
maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _ (HsRecTy {}) _ _ = mempty -- Can now legally occur
+ -- un ConDeclGADT, but is
+ -- output elsewhere
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 49c471a4..8983cc77 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -292,19 +292,21 @@ synifyDataCon use_gadt_syntax dc =
(False,True) -> case linear_tys of
[a,b] -> return $ InfixCon a b
_ -> Left "synifyDataCon: infix with non-2 args?"
- hs_res_ty = if use_gadt_syntax
- then ResTyGADT noSrcSpan (synifyType WithinType res_ty)
- else ResTyH98
+ gadt_ty = HsIB [] [] (synifyType WithinType res_ty)
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
- \hat -> return $ noLoc $
- ConDecl { con_names = [name]
- , con_explicit = False -- we don't know nor care
- , con_qvars = qvars
- , con_cxt = ctx
- , con_details = hat
- , con_res = hs_res_ty
- , con_doc = Nothing }
+ \hat ->
+ if use_gadt_syntax
+ then return $ noLoc $
+ ConDeclGADT { con_names = [name]
+ , con_type = gadt_ty
+ , con_doc = Nothing }
+ else return $ noLoc $
+ ConDeclH98 { con_name = name
+ , con_qvars = Just qvars
+ , con_cxt = Just ctx
+ , con_details = hat
+ , con_doc = Nothing }
synifyName :: NamedThing n => n -> Located Name
synifyName = noLoc . getName
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 49d6a420..ab4d6c78 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -188,14 +188,14 @@ class Parent a where
instance Parent (ConDecl Name) where
children con =
- case con_details con of
+ case getConDetails con of
RecCon fields -> map (selectorFieldOcc . unL) $
concatMap (cd_fld_names . unL) (unL fields)
_ -> []
instance Parent (TyClDecl Name) where
children d
- | isDataDecl d = map unL $ concatMap (con_names . unL)
+ | isDataDecl d = map unL $ concatMap (getConNames . unL)
$ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
map (unL . fdLName . unL) (tcdATs d) ++
@@ -209,7 +209,7 @@ family = getName &&& children
familyConDecl :: ConDecl Name -> [(Name, [Name])]
-familyConDecl d = zip (map unL (con_names d)) (repeat $ children d)
+familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
-- | A mapping from the parent (main-binder) to its children and from each
-- child to its grand-children, recursively.
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index da59c5fa..30b32963 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -47,6 +47,7 @@ import TcRnTypes
import FastString (concatFS)
import BasicTypes ( StringLiteral(..) )
import qualified Outputable as O
+import HsDecls ( gadtDeclDetails,getConDetails )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
@@ -334,9 +335,9 @@ subordinates instMap decl = case decl of
where
cons = map unL $ (dd_cons dd)
constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
- | c <- cons, cname <- con_names c ]
+ | c <- cons, cname <- getConNames c ]
fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
- | RecCon flds <- map con_details cons
+ | RecCon flds <- map getConDetails cons
, L _ (ConDeclField ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
@@ -785,7 +786,8 @@ extractDecl name mdl decl
SigD <$> extractRecSel name mdl 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)
+ -- , 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
@@ -800,7 +802,7 @@ extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
- case con_details con of
+ case getConDetails con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
_ -> extractRecSel nm mdl t tvs rest
@@ -809,7 +811,8 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
, L l n <- ns, selectorFieldOcc n == nm ]
data_ty
- | ResTyGADT _ ty <- con_res con = ty
+ -- | ResTyGADT _ ty <- con_res con = ty
+ | ConDeclGADT{} <- con = hsib_body $ con_type con
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs
-- | Keep export items with docs.
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index f2f93966..0b975687 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -393,17 +393,16 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
renameCon :: ConDecl Name -> RnM (ConDecl DocName)
-renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
- , con_cxt = lcontext, con_details = details
- , con_res = restype, con_doc = mbldoc }) = do
- lnames' <- mapM renameL lnames
- ltyvars' <- renameLHsQTyVars ltyvars
- lcontext' <- renameLContext lcontext
+renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
+ , con_cxt = lcontext, con_details = details
+ , con_doc = mbldoc }) = do
+ lname' <- renameL lname
+ ltyvars' <- traverse renameLHsQTyVars ltyvars
+ lcontext' <- traverse renameLContext lcontext
details' <- renameDetails details
- restype' <- renameResType restype
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext'
- , con_details = details', con_res = restype', con_doc = mbldoc' })
+ return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
+ , con_details = details', con_doc = mbldoc' })
where
renameDetails (RecCon (L l fields)) = do
@@ -415,9 +414,14 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
b' <- renameLType b
return (InfixCon a' b')
- renameResType (ResTyH98) = return ResTyH98
- renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t
-
+renameCon decl@(ConDeclGADT { con_names = lnames
+ , con_type = lty
+ , con_doc = mbldoc }) = do
+ lnames' <- mapM renameL lnames
+ lty' <- renameLSigType lty
+ mbldoc' <- mapM renameLDocHsSyn mbldoc
+ return (decl { con_names = lnames'
+ , con_type = lty', con_doc = mbldoc' })
renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
renameConDeclFieldField (L l (ConDeclField names t doc)) = do
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 658007ba..45deca9c 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -180,18 +180,32 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
where
- keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) =
- case con_details d of
+ keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
+ case getConDetails h98d of
PrefixCon _ -> Just d
RecCon fields
| all field_avail (unL fields) -> Just d
- | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) })
+ | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) })
-- if we have *all* the field names available, then
-- keep the record declaration. Otherwise degrade to
-- a constructor declaration. This isn't quite right, but
-- it's the best we can do.
InfixCon _ _ -> Just d
where
+ h98d = h98ConDecl d
+ h98ConDecl c@ConDeclH98{} = c
+ h98ConDecl c@ConDeclGADT{} = c'
+ where
+ (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)
+ c' :: ConDecl Name
+ c' = ConDeclH98
+ { con_name = head (con_names c)
+ , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs }
+ , con_cxt = Just cxt
+ , con_details = details
+ , con_doc = con_doc c
+ }
+
field_avail :: LConDeclField Name -> Bool
field_avail (L _ (ConDeclField fs _ _))
= all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
--
cgit v1.2.3