diff --git a/Data/Hackage.hs b/Data/Hackage.hs index a72f0cc..8d9b56b 100644 --- a/Data/Hackage.hs +++ b/Data/Hackage.hs @@ -40,6 +40,8 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.Blaze.Html (unsafeByteString) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A +import qualified Documentation.Haddock.Parser as Haddock +import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..)) sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory sinkUploadHistory = @@ -277,7 +279,9 @@ getMetadata name version hash' gpd = do , metadataExes = length $ PD.executables pd , metadataTestSuites = length $ PD.testSuites pd , metadataBenchmarks = length $ PD.benchmarks pd - , metadataReadme = collapseHtml $ fromMaybe (toHtml $ Textarea $ pack $ PD.description pd) mreadme + , metadataReadme = collapseHtml $ fromMaybe + (hToHtml . Haddock.toRegular . Haddock.parseString $ PD.description pd) + mreadme , metadataChangelog = collapseHtml <$> mchangelog , metadataLicenseContent = collapseHtml <$> mlicenseContent } @@ -286,6 +290,51 @@ getMetadata name version hash' gpd = do goDep (PD.Dependency (PD.PackageName n) _) = singletonSet $ pack n goComp (_, tree, mtree) = goTree tree ++ maybe mempty goTree mtree +-- | Convert a Haddock doc to HTML. +hToHtml :: DocH String String -> Html +hToHtml = + go + where + go :: DocH String String -> Html + go DocEmpty = mempty + go (DocAppend x y) = go x ++ go y + go (DocString x) = toHtml x + go (DocParagraph x) = H.p $ go x + go (DocIdentifier s) = H.code $ toHtml s + go (DocIdentifierUnchecked s) = H.code $ toHtml s + go (DocModule s) = H.code $ toHtml s + go (DocWarning x) = H.span H.! A.class_ "warning" $ go x + go (DocEmphasis x) = H.em $ go x + go (DocMonospaced x) = H.code $ go x + go (DocBold x) = H.strong $ go x + go (DocUnorderedList xs) = H.ul $ foldMap (H.li . go) xs + go (DocOrderedList xs) = H.ol $ foldMap (H.li . go) xs + go (DocDefList xs) = H.dl $ flip foldMap xs $ \(x, y) -> + H.dt (go x) ++ H.dd (go y) + go (DocCodeBlock x) = H.pre $ H.code $ go x + go (DocHyperlink (Hyperlink url mlabel)) = + H.a H.! A.href (H.toValue url) $ toHtml label + where + label = fromMaybe url mlabel + go (DocPic (Picture url mtitle)) = + H.img H.! A.src (H.toValue url) H.! A.title (H.toValue $ fromMaybe mempty mtitle) + go (DocAName s) = H.div H.! A.id (H.toValue s) $ mempty + go (DocProperty s) = toHtml s -- FIXME correct? + go (DocExamples es) = flip foldMap es $ \(Example exp' ress) -> + H.div H.! A.class_ "example" $ do + H.pre H.! A.class_ "expression" $ H.code $ toHtml exp' + flip foldMap ress $ \res -> + H.pre H.! A.class_ "result" $ H.code $ toHtml res + go (DocHeader (Header level content)) = + wrapper level $ go content + where + wrapper 1 = H.h1 + wrapper 2 = H.h2 + wrapper 3 = H.h3 + wrapper 4 = H.h4 + wrapper 5 = H.h5 + wrapper _ = H.h6 + showSourceRepo :: PD.SourceRepo -> Maybe Text showSourceRepo = fmap pack . PD.repoLocation diff --git a/stackage-server.cabal b/stackage-server.cabal index e72bb9e..9f57e60 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -145,6 +145,7 @@ library , markdown , formatting , blaze-html + , haddock-library executable stackage-server if flag(library-only)