From b86ec0eb427fe89513b630b6ad7a61bb41c97846 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 27 Jan 2020 16:30:54 +0100 Subject: [PATCH] Enhancements to Haddock -> Markdown conversion (#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 --- ghcide.cabal | 3 +- src/Development/IDE/Spans/Common.hs | 25 ++++++++---- test/exe/Main.hs | 62 +++++++++++++++++++++++++++++ 3 files changed, 82 insertions(+), 8 deletions(-) diff --git a/ghcide.cabal b/ghcide.cabal index 83ffe2f29..d2eed9dc3 100644 --- a/ghcide.cabal +++ b/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/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs index 7505e9d49..2cf2fef51 100644 --- a/src/Development/IDE/Spans/Common.hs +++ b/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,7 +80,14 @@ 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 @@ -89,7 +95,7 @@ haddockToMarkdown 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 \ No newline at end of file + +splitForList :: String -> String +splitForList s + = case lines s of + [] -> "" + (first:rest) -> unlines $ first : map ((" " ++) . dropWhile isSpace) rest \ No newline at end of file diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 47eaaf1f9..11836a774 100644 --- a/test/exe/Main.hs +++ b/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