mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
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 <moritz.kiefer@purelyfunctional.org>
This commit is contained in:
Alejandro Serrano
Moritz Kiefer
parent
ea50c27fad
commit
956e11dff8
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
splitForList :: String -> String
|
||||
splitForList s
|
||||
= case lines s of
|
||||
[] -> ""
|
||||
(first:rest) -> unlines $ first : map ((" " ++) . dropWhile isSpace) rest
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user