diff options
| -rw-r--r-- | haddock-api/src/Haddock.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Org.hs | 46 |
2 files changed, 25 insertions, 23 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 40cf8414..d011078a 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -472,7 +472,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc libDir return () when (Flag_Org `elem` flags) $ do - withTiming logger dflags' "ppOrg" (const ()) $ do + withTiming logger "ppOrg" (const ()) $ do let org = {-# SCC ppOrg #-} ppOrg title (_doc <$> prologue) (fromJust pkgStr) visibleIfaces writeUtf8File (fromMaybe "haddock" (cleanPkgStr <$> pkgStr) <.> "org") org diff --git a/haddock-api/src/Haddock/Backends/Org.hs b/haddock-api/src/Haddock/Backends/Org.hs index 9d02d0db..d651551d 100644 --- a/haddock-api/src/Haddock/Backends/Org.hs +++ b/haddock-api/src/Haddock/Backends/Org.hs @@ -245,8 +245,10 @@ processExport _ (ExportModule mdl ) = do ppFnArgsDoc :: FnArgsDoc DocName -> [OrgBlock] ppFnArgsDoc aDoc = if M.null aDoc then [] - else ((`ppDoc` Nothing) . DocParagraph . DocString) "Arguments (in order):" - ++ ((`ppDoc` Nothing) . DocOrderedList . toList . M.map _doc) aDoc + else + ((`ppDoc` Nothing) . DocParagraph . DocString) "Arguments (in order):" + ++ ((`ppDoc` Nothing) . DocOrderedList . map snd . toList . M.map _doc) + aDoc ppDocumentation :: Documentation DocName -> Maybe Int -> [OrgBlock] ppDocumentation (Documentation (Just mdoc) _) minLevel = ppMDoc mdoc minLevel @@ -266,7 +268,7 @@ ppDocBlock (DocParagraph x) _ = [Paragraph (ppDocInline x)] ppDocBlock (DocUnorderedList docs) _ = [PlainList Unordered $ (`ppDocBlock` Nothing) <$> docs] ppDocBlock (DocOrderedList items) _ = - [PlainList Ordered (map ((`ppDocBlock` Nothing) . snd) items)] + [PlainList Ordered (map (`ppDocBlock` Nothing) items)] ppDocBlock (DocDefList pairs) _ = [ DefList $ (\(term, def) -> (ppDocInline term, ppDocBlock def Nothing)) @@ -653,19 +655,19 @@ ppConDecl (ConDeclH98 _ (L _ docName) _forall exTvs mbCtxt args _) subdocs path ] _ -> ppFnArgsDoc aDoc -- TODO: handle con_bndrs and con_mb_cxt -ppConDecl (ConDeclGADT _ names _ _ args resTy _) subdocs path level = - [ Heading - level - ( interNotNull - [Whitespace] - [ intersperse (Plain $ text ", ") - (map (Plain . docNameToDoc . unLoc) names) - , [plaintext "::"] - ] - ++ [Whitespace] - ++ ppConDeclGADTDetailsPrefix args resTy - ) - (concatMap (cIdPaths path . unLoc) names) +ppConDecl (ConDeclGADT { con_names = names, con_g_args = args, con_res_ty = resTy }) subdocs path level + = [ Heading + level + ( interNotNull + [Whitespace] + [ intersperse (Plain $ text ", ") + (map (Plain . docNameToDoc . unLoc) names) + , [plaintext "::"] + ] + ++ [Whitespace] + ++ ppConDeclGADTDetailsPrefix args resTy + ) + (concatMap (cIdPaths path . unLoc) names) ] ++ maybe [] (`ppDocForDecl` (Just level)) @@ -692,7 +694,7 @@ ppConDeclGADTDetailsRec -> ModPath -> Int -> [OrgBlock] -ppConDeclGADTDetailsRec (RecConGADT (L _ args)) resTy subdocs path level = +ppConDeclGADTDetailsRec (RecConGADT (L _ args) _) resTy subdocs path level = concatMap (\arg -> ppConDeclField (unLoc arg) subdocs path level) args ++ [Heading level (plaintext "} -> " : ppLHsType resTy) []] ppConDeclGADTDetailsRec _ _ _ _ _ = [] @@ -810,8 +812,8 @@ ppHsSigTypeDoc (HsSig _ bndrs (L _ ty)) adoc = ppHsTypeDoc :: HsType DocNameI -> Int -> [DefListItem] ppHsTypeDoc (HsFunTy _ _ (L _ lTy) (L _ rTy)) i = ppHsTypeDoc lTy i ++ ppHsTypeDoc rTy (i + 1) - ppHsTypeDoc (HsQualTy _ mbCtxt (L _ body)) i = - (ppMbLHsContext mbCtxt, []) : ppHsTypeDoc body i + ppHsTypeDoc (HsQualTy _ ctxt (L _ body)) i = + (ppMbLHsContext (Just ctxt), []) : ppHsTypeDoc body i ppHsTypeDoc (HsForAllTy _ tele (L _ body)) i = (ppHsForAllTelescope tele ++ [plaintext "."], []) : ppHsTypeDoc body i ppHsTypeDoc typ i = [(ppHsType typ, ppADoc adoc i)] @@ -832,8 +834,8 @@ ppHsType :: HsType DocNameI -> [OrgInline] ppHsType (HsForAllTy _ tele (L _ body)) = ppHsForAllTelescope tele ++ [plaintext ".", Whitespace] ++ ppHsType body -- e.g. forall a. Ord a => a -ppHsType (HsQualTy _ mbCtxt (L _ body)) = - interNotNull [Whitespace] [ppMbLHsContext mbCtxt, ppHsType body] +ppHsType (HsQualTy _ ctxt (L _ body)) = + interNotNull [Whitespace] [ppMbLHsContext (Just ctxt), ppHsType body] -- e.g. Bool ppHsType (HsTyVar _ promo (L _ docName)) = ppPromoted promo ++ ppDocName docName @@ -857,7 +859,7 @@ ppHsType (HsTupleTy _ sort tys) = orgParens $ maybeUnbox $ intercalate -- e.g. (# a | b #) ppHsType (HsSumTy _ tys) = orgParens . orgUnbox $ intercalate [plaintext " | "] (map ppLHsType tys) -ppHsType (HsOpTy _ (L _ lTy) (L _ docName) (L _ rTy)) = +ppHsType (HsOpTy _ _promo (L _ lTy) (L _ docName) (L _ rTy)) = intercalate [Whitespace] [ppHsType lTy, ppDocName docName, ppHsType rTy] -- e.g. (a -> a) ppHsType (HsParTy _ (L _ t)) = orgParens $ ppHsType t |