git.iko.soy/ghcide
on master help sign in
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>

commit956e11dff8059b1b78ea487db7d6dcb3430ad6c4 authorAlejandro Serrano <trupill@gmail.com> dateMon 27 Jan 2020, 16:30 (7 years ago) parentea50c27
3 files changed+82−8
compare with master
unifiedsplit
ghcide.cabal+2−1 src/Development/IDE/Spans/Common.hs+18−7 test/exe/Main.hs+62
ghcide.cabal+2−1
@@ -112,6 +112,7 @@ library
112112 Development.IDE.LSP.LanguageServer
113113 Development.IDE.LSP.Protocol
114114 Development.IDE.LSP.Server
115+ Development.IDE.Spans.Common
115116 Development.IDE.Types.Diagnostics
116117 Development.IDE.Types.Location
117118 Development.IDE.Types.Logger
@@ -134,7 +135,6 @@ library
134135 Development.IDE.LSP.Outline
135136 Development.IDE.Spans.AtPoint
136137 Development.IDE.Spans.Calculate
137− Development.IDE.Spans.Common
138138 Development.IDE.Spans.Documentation
139139 Development.IDE.Spans.Type
140140 Development.IDE.Plugin.Completions.Logic
@@ -217,6 +217,7 @@ test-suite ghcide-tests
217217 --------------------------------------------------------------
218218 ghcide,
219219 ghc-typelits-knownnat,
220+ haddock-library,
220221 haskell-lsp-types,
221222 lens,
222223 lsp-test >= 0.8,
src/Development/IDE/Spans/Common.hs+18−7
@@ -12,6 +12,7 @@ module Development.IDE.Spans.Common (
1212, SpanDoc(..)
1313, emptySpanDoc
1414, spanDocToMarkdown
15+, spanDocToMarkdownForTest
1516) where
1617
1718import Data.Data
@@ -27,11 +28,9 @@ import DataCon
2728import Var
2829#endif
2930
30−#if MIN_GHC_API_VERSION(8,6,0)
3131import Data.Char (isSpace)
3232import qualified Documentation.Haddock.Parser as H
3333import qualified Documentation.Haddock.Types as H
34−#endif
3534
3635showGhc :: Outputable a => a -> String
3736showGhc = showPpr unsafeGlobalDynFlags
@@ -81,7 +80,14 @@ spanDocToMarkdown (SpanDocString _)
8180#endif
8281spanDocToMarkdown (SpanDocText txt) = txt
8382
84−#if MIN_GHC_API_VERSION(8,6,0)
83+spanDocToMarkdownForTest :: String -> String
84+spanDocToMarkdownForTest
85+#if MIN_VERSION_haddock_library(1,6,0)
86+ = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
87+#else
88+ = haddockToMarkdown . H.toRegular . H._doc . H.parseParas
89+#endif
90+
8591-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
8692haddockToMarkdown
8793 :: H.DocH String String -> String
@@ -89,7 +95,7 @@ haddockToMarkdown
8995haddockToMarkdown H.DocEmpty
9096 = ""
9197haddockToMarkdown (H.DocAppend d1 d2)
92− = haddockToMarkdown d1 Prelude.<> haddockToMarkdown d2
98+ = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2
9399haddockToMarkdown (H.DocString s)
94100 = s
95101haddockToMarkdown (H.DocParagraph p)
@@ -138,9 +144,9 @@ haddockToMarkdown (H.DocHeader (H.Header level title))
138144 = replicate level '#' ++ " " ++ haddockToMarkdown title
139145
140146haddockToMarkdown (H.DocUnorderedList things)
141− = '\n' : (unlines $ map (\thing -> "+ " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
147+ = '\n' : (unlines $ map (("+ " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)
142148haddockToMarkdown (H.DocOrderedList things)
143− = '\n' : (unlines $ map (\thing -> "1. " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
149+ = '\n' : (unlines $ map (("1. " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)
144150haddockToMarkdown (H.DocDefList things)
145151 = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
146152
@@ -157,4 +163,9 @@ haddockToMarkdown (H.DocTable _t)
157163-- things I don't really know how to handle
158164haddockToMarkdown (H.DocProperty _)
159165 = "" -- don't really know what to do
160−#endif
166+
167+splitForList :: String -> String
168+splitForList s
169+ = case lines s of
170+ [] -> ""
171+ (first:rest) -> unlines $ first : map ((" " ++) . dropWhile isSpace) rest
test/exe/Main.hs+62
@@ -17,6 +17,7 @@ import Data.Foldable
1717import Data.List
1818import Development.IDE.GHC.Util
1919import qualified Data.Text as T
20+import Development.IDE.Spans.Common
2021import Development.IDE.Test
2122import Development.IDE.Test.Runfiles
2223import Development.IDE.Types.Location
@@ -53,6 +54,7 @@ main = defaultMain $ testGroup "HIE"
5354 , preprocessorTests
5455 , thTests
5556 , unitTests
57+ , haddockTests
5658 ]
5759
5860initializeResponseTests :: TestTree
@@ -1638,6 +1640,66 @@ data Expect
16381640
16391641mkR :: Int -> Int -> Int -> Int -> Expect
16401642mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1643+
1644+haddockTests :: TestTree
1645+haddockTests
1646+ = testGroup "haddock"
1647+ [ testCase "Num" $ checkHaddock
1648+ (unlines
1649+ [ "However, '(+)' and '(*)' are"
1650+ , "customarily expected to define a ring and have the following properties:"
1651+ , ""
1652+ , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
1653+ , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
1654+ , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
1655+ ]
1656+ )
1657+ (unlines
1658+ [ ""
1659+ , ""
1660+#if MIN_VERSION_haddock_library(1,8,0)
1661+ , "However, `(+)` and `(*)` are"
1662+#else
1663+ , "However, '(+)' and '(*)' are"
1664+#endif
1665+ , "customarily expected to define a ring and have the following properties: "
1666+ , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1667+ , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1668+ , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"
1669+ ]
1670+ )
1671+ , testCase "unsafePerformIO" $ checkHaddock
1672+ (unlines
1673+ [ "may require"
1674+ , "different precautions:"
1675+ , ""
1676+ , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
1677+ , " that calls 'unsafePerformIO'. If the call is inlined,"
1678+ , " the I\\/O may be performed more than once."
1679+ , ""
1680+ , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
1681+ , " elimination being performed on the module."
1682+ , ""
1683+ ]
1684+ )
1685+ (unlines
1686+ [ ""
1687+ , ""
1688+ , "may require"
1689+ , "different precautions: "
1690+ , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "
1691+ , " that calls `unsafePerformIO` . If the call is inlined,"
1692+ , " the I/O may be performed more than once."
1693+ , ""
1694+ , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
1695+ , " elimination being performed on the module."
1696+ , ""
1697+ ]
1698+ )
1699+ ]
1700+ where
1701+ checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
1702+
16411703----------------------------------------------------------------------
16421704-- Utils
16431705