1{-# LANGUAGE CPP                #-}
2{-# LANGUAGE DeriveAnyClass     #-}
3{-# LANGUAGE DerivingStrategies #-}
4
5module Development.IDE.Spans.Common (
6  showGhc
7, showNameWithoutUniques
8, unqualIEWrapName
9, safeTyThingId
10, safeTyThingType
11, SpanDoc(..)
12, SpanDocUris(..)
13, emptySpanDoc
14, spanDocToMarkdown
15, spanDocToMarkdownForTest
16, DocMap
17, KindMap
18) where
19
20import           Control.DeepSeq
21import           Data.List.Extra
22import           Data.Maybe
23import qualified Data.Text                    as T
24import           GHC.Generics
25
26import           ConLike
27import           DynFlags
28import           GHC
29import           NameEnv
30import           Outputable                   hiding ((<>))
31import           Var
32
33import           Development.IDE.GHC.Compat   (oldMkUserStyle,
34                                               oldRenderWithStyle)
35import           Development.IDE.GHC.Orphans  ()
36import           Development.IDE.GHC.Util
37import qualified Documentation.Haddock.Parser as H
38import qualified Documentation.Haddock.Types  as H
39import           RdrName                      (rdrNameOcc)
40
41type DocMap = NameEnv SpanDoc
42type KindMap = NameEnv TyThing
43
44showGhc :: Outputable a => a -> T.Text
45showGhc = showSD . ppr
46
47showSD :: SDoc -> T.Text
48showSD = T.pack . unsafePrintSDoc
49
50showNameWithoutUniques :: Outputable a => a -> T.Text
51showNameWithoutUniques = T.pack . prettyprint
52  where
53    dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques
54    prettyprint x = oldRenderWithStyle dyn (ppr x) style
55    style = oldMkUserStyle dyn neverQualify AllTheWay
56
57-- | Shows IEWrappedName, without any modifier, qualifier or unique identifier.
58unqualIEWrapName :: IEWrappedName RdrName -> T.Text
59unqualIEWrapName = showNameWithoutUniques . rdrNameOcc . ieWrappedName
60
61-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
62safeTyThingType :: TyThing -> Maybe Type
63safeTyThingType thing
64  | Just i <- safeTyThingId thing = Just (varType i)
65safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)
66safeTyThingType _                 = Nothing
67
68safeTyThingId :: TyThing -> Maybe Id
69safeTyThingId (AnId i)           = Just i
70safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike
71safeTyThingId _                  = Nothing
72
73-- Possible documentation for an element in the code
74data SpanDoc
75  = SpanDocString HsDocString SpanDocUris
76  | SpanDocText   [T.Text] SpanDocUris
77  deriving stock (Eq, Show, Generic)
78  deriving anyclass NFData
79
80data SpanDocUris =
81  SpanDocUris
82  { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page
83  , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page
84  } deriving stock (Eq, Show, Generic)
85    deriving anyclass NFData
86
87emptySpanDoc :: SpanDoc
88emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing)
89
90spanDocToMarkdown :: SpanDoc -> [T.Text]
91spanDocToMarkdown (SpanDocString docs uris)
92  = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]
93    <> ["\n"] <> spanDocUrisToMarkdown uris
94  -- Append the extra newlines since this is markdown --- to get a visible newline,
95  -- you need to have two newlines
96spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris
97
98spanDocUrisToMarkdown :: SpanDocUris -> [T.Text]
99spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes
100  [ linkify "Documentation" <$> mdoc
101  , linkify "Source" <$> msrc
102  ]
103  where linkify title uri = "[" <> title <> "](" <> uri <> ")"
104
105spanDocToMarkdownForTest :: String -> String
106spanDocToMarkdownForTest
107  = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
108
109-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
110haddockToMarkdown
111  :: H.DocH String String -> String
112
113haddockToMarkdown H.DocEmpty
114  = ""
115haddockToMarkdown (H.DocAppend d1 d2)
116  = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2
117haddockToMarkdown (H.DocString s)
118  = escapeBackticks s
119haddockToMarkdown (H.DocParagraph p)
120  = "\n\n" ++ haddockToMarkdown p
121haddockToMarkdown (H.DocIdentifier i)
122  = "`" ++ i ++ "`"
123haddockToMarkdown (H.DocIdentifierUnchecked i)
124  = "`" ++ i ++ "`"
125#if MIN_VERSION_haddock_library(1,10,0)
126haddockToMarkdown (H.DocModule (H.ModLink i Nothing))
127  = "`" ++ escapeBackticks i ++ "`"
128-- See https://github.com/haskell/haddock/pull/1315
129-- Module references can be labeled in markdown style, e.g. [some label]("Some.Module")
130-- However, we don't want to use the link markup here, since the module name would be covered
131-- up by the label. Thus, we keep both the label and module name in the following style:
132-- some label ( `Some.Module` )
133haddockToMarkdown (H.DocModule (H.ModLink i (Just label)))
134  = haddockToMarkdown label ++ " ( `" ++ escapeBackticks i ++ "` )"
135#else
136haddockToMarkdown (H.DocModule i)
137  = "`" ++ escapeBackticks i ++ "`"
138#endif
139haddockToMarkdown (H.DocWarning w)
140  = haddockToMarkdown w
141haddockToMarkdown (H.DocEmphasis d)
142  = "*" ++ haddockToMarkdown d ++ "*"
143haddockToMarkdown (H.DocBold d)
144  = "**" ++ haddockToMarkdown d ++ "**"
145haddockToMarkdown (H.DocMonospaced d)
146  = "`" ++ removeUnescapedBackticks (haddockToMarkdown d) ++ "`"
147haddockToMarkdown (H.DocCodeBlock d)
148  = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"
149haddockToMarkdown (H.DocExamples es)
150  = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"
151  where
152    exampleToMarkdown (H.Example expr result)
153      = ">>> " ++ expr ++ "\n" ++ unlines result
154haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
155  = "<" ++ url ++ ">"
156haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
157  = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
158haddockToMarkdown (H.DocPic (H.Picture url Nothing))
159  = "![](" ++ url ++ ")"
160haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
161  = "![" ++ label ++ "](" ++ url ++ ")"
162haddockToMarkdown (H.DocAName aname)
163  = "[" ++ escapeBackticks aname ++ "]:"
164haddockToMarkdown (H.DocHeader (H.Header level title))
165  = replicate level '#' ++ " " ++ haddockToMarkdown title
166
167haddockToMarkdown (H.DocUnorderedList things)
168  = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)
169haddockToMarkdown (H.DocOrderedList things)
170  = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
171haddockToMarkdown (H.DocDefList things)
172  = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
173
174-- we cannot render math by default
175haddockToMarkdown (H.DocMathInline _)
176  = "*cannot render inline math formula*"
177haddockToMarkdown (H.DocMathDisplay _)
178  = "\n\n*cannot render display math formula*\n\n"
179
180-- TODO: render tables
181haddockToMarkdown (H.DocTable _t)
182  = "\n\n*tables are not yet supported*\n\n"
183
184-- things I don't really know how to handle
185haddockToMarkdown (H.DocProperty _)
186  = ""  -- don't really know what to do
187
188escapeBackticks :: String -> String
189escapeBackticks ""       = ""
190escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss
191escapeBackticks (s  :ss) = s:escapeBackticks ss
192
193removeUnescapedBackticks :: String -> String
194removeUnescapedBackticks = \case
195  '\\' : '`' : ss -> '\\' : '`' : removeUnescapedBackticks ss
196  '`' : ss        -> removeUnescapedBackticks ss
197  ""              -> ""
198  s : ss          -> s : removeUnescapedBackticks ss
199
200splitForList :: String -> String
201splitForList s
202  = case lines s of
203      []           -> ""
204      (first:rest) -> unlines $ first : map (("  " ++) . trimStart) rest
205