Use haddock-library for parsing descriptions #46

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
 

stackage-server.cabal

@@ -145,6 +145,7 @@ library
                  , markdown
                  , formatting
                  , blaze-html
+                 , haddock-library
 
 executable         stackage-server
     if flag(library-only)