diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 19 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 71 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 116 |
3 files changed, 119 insertions, 87 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 5800736f..cef0da20 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -221,8 +221,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] @@ -238,12 +239,18 @@ ppCtor dflags dat subdocs con -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = commaSeparate dflags . map unL $ con_names con + name = commaSeparate 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 ppFixity :: DynFlags -> (Name, Fixity) -> [String] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index a71ae784..e7780d6e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -577,14 +577,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 @@ -611,6 +611,71 @@ ppConstrHdr forall tvs ctxt unicode 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) = leader <-> case con_res con of @@ -672,7 +737,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 5f5a9e61..af672ff7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -645,11 +645,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") @@ -663,7 +663,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)] -> @@ -679,7 +681,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 @@ -688,15 +692,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 links (OriginData docname) instances @@ -713,8 +715,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) @@ -727,28 +729,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 @@ -758,12 +747,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 @@ -782,11 +770,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) @@ -800,35 +788,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 @@ -838,15 +816,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 @@ -955,24 +931,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 @@ -1005,7 +963,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 = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys |