Enhancements to Haddock -> Markdown conversion (haskell/ghcide#344)

* Enhancements to Haddock -> Markdown conversion * Add tests for Haddock -> Markdown conversion * Make HLint happy * Let Haddock tests compile also in 8.4 * Fix build for 8.4 * Fix test for haddock-library 1.8.0 * Fix CPP problem * Make tests a bit more readable Co-authored-by: Moritz Kiefer <[email protected]>
pepeiborra · Jan 27, 2020 · e03aecd · e03aecd
1 parent e3b8f51
commit e03aecd
Show file tree

Hide file tree

Showing 3 changed files with 82 additions and 8 deletions.
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
@@ -112,6 +112,7 @@ library
         Development.IDE.LSP.LanguageServer
         Development.IDE.LSP.Protocol
         Development.IDE.LSP.Server
+        Development.IDE.Spans.Common
         Development.IDE.Types.Diagnostics
         Development.IDE.Types.Location
         Development.IDE.Types.Logger
@@ -134,7 +135,6 @@ library
         Development.IDE.LSP.Outline
         Development.IDE.Spans.AtPoint
         Development.IDE.Spans.Calculate
-        Development.IDE.Spans.Common
         Development.IDE.Spans.Documentation
         Development.IDE.Spans.Type
         Development.IDE.Plugin.Completions.Logic
@@ -217,6 +217,7 @@ test-suite ghcide-tests
         --------------------------------------------------------------
         ghcide,
         ghc-typelits-knownnat,
+        haddock-library,
         haskell-lsp-types,
         lens,
         lsp-test >= 0.8,

diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs
@@ -12,6 +12,7 @@ module Development.IDE.Spans.Common (
 , SpanDoc(..)
 , emptySpanDoc
 , spanDocToMarkdown
+, spanDocToMarkdownForTest
 ) where
 
 import Data.Data
@@ -27,11 +28,9 @@ import DataCon
 import Var
 #endif
 
-#if MIN_GHC_API_VERSION(8,6,0)
 import           Data.Char (isSpace)
 import qualified Documentation.Haddock.Parser as H
 import qualified Documentation.Haddock.Types as H
-#endif
 
 showGhc :: Outputable a => a -> String
 showGhc = showPpr unsafeGlobalDynFlags
@@ -81,15 +80,22 @@ spanDocToMarkdown (SpanDocString _)
 #endif
 spanDocToMarkdown (SpanDocText txt) = txt
 
-#if MIN_GHC_API_VERSION(8,6,0)
+spanDocToMarkdownForTest :: String -> String
+spanDocToMarkdownForTest
+#if MIN_VERSION_haddock_library(1,6,0)
+  = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
+#else
+  = haddockToMarkdown . H.toRegular . H._doc . H.parseParas
+#endif
+
 -- Simple (and a bit hacky) conversion from Haddock markup to Markdown
 haddockToMarkdown
   :: H.DocH String String -> String
 
 haddockToMarkdown H.DocEmpty
   = ""
 haddockToMarkdown (H.DocAppend d1 d2)
-  = haddockToMarkdown d1 Prelude.<> haddockToMarkdown d2
+  = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2
 haddockToMarkdown (H.DocString s)
   = s
 haddockToMarkdown (H.DocParagraph p)
@@ -138,9 +144,9 @@ haddockToMarkdown (H.DocHeader (H.Header level title))
   = replicate level '#' ++ " " ++ haddockToMarkdown title
 
 haddockToMarkdown (H.DocUnorderedList things)
-  = '\n' : (unlines $ map (\thing -> "+ " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
+  = '\n' : (unlines $ map (("+ " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)
 haddockToMarkdown (H.DocOrderedList things)
-  = '\n' : (unlines $ map (\thing -> "1. " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
+  = '\n' : (unlines $ map (("1. " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)
 haddockToMarkdown (H.DocDefList things)
   = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
 
@@ -157,4 +163,9 @@ haddockToMarkdown (H.DocTable _t)
 -- things I don't really know how to handle
 haddockToMarkdown (H.DocProperty _)
   = ""  -- don't really know what to do
-#endif
+
+splitForList :: String -> String
+splitForList s
+  = case lines s of
+      [] -> ""
+      (first:rest) -> unlines $ first : map (("  " ++) . dropWhile isSpace) rest
diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -17,6 +17,7 @@ import Data.Foldable
 import Data.List
 import Development.IDE.GHC.Util
 import qualified Data.Text as T
+import Development.IDE.Spans.Common
 import Development.IDE.Test
 import Development.IDE.Test.Runfiles
 import Development.IDE.Types.Location
@@ -53,6 +54,7 @@ main = defaultMain $ testGroup "HIE"
   , preprocessorTests
   , thTests
   , unitTests
+  , haddockTests
   ]
 
 initializeResponseTests :: TestTree
@@ -1638,6 +1640,66 @@ data Expect
 
 mkR :: Int -> Int -> Int -> Int -> Expect
 mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
+
+haddockTests :: TestTree
+haddockTests
+  = testGroup "haddock"
+      [ testCase "Num" $ checkHaddock
+          (unlines
+             [ "However, '(+)' and '(*)' are"
+             , "customarily expected to define a ring and have the following properties:"
+             , ""
+             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
+             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
+             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
+             ]
+          )
+          (unlines
+             [ ""
+             , ""
+#if MIN_VERSION_haddock_library(1,8,0)
+             , "However,  `(+)`  and  `(*)`  are"
+#else
+             , "However, '(+)' and '(*)' are"
+#endif
+             , "customarily expected to define a ring and have the following properties: "
+             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"
+             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"
+             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"
+             ]
+          )
+      , testCase "unsafePerformIO" $ checkHaddock
+          (unlines
+             [ "may require"
+             , "different precautions:"
+             , ""
+             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
+             , "        that calls 'unsafePerformIO'.  If the call is inlined,"
+             , "        the I\\/O may be performed more than once."
+             , ""
+             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
+             , "        elimination being performed on the module."
+             , ""
+             ]
+          )
+          (unlines
+             [ ""
+             , ""
+             , "may require"
+             , "different precautions: "
+             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "
+             , "  that calls  `unsafePerformIO` .  If the call is inlined,"
+             , "  the I/O may be performed more than once."
+             , ""
+             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"
+             , "  elimination being performed on the module."
+             , ""
+             ]
+          )
+      ]
+  where
+    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
+
 ----------------------------------------------------------------------
 -- Utils