{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}

module Development.IDE.Spans.Common (
  unqualIEWrapName
, safeTyThingId
, safeTyThingType
, SpanDoc(..)
, SpanDocUris(..)
, emptySpanDoc
, spanDocToMarkdown
, spanDocToMarkdownForTest
, DocMap
, TyThingMap
) where

import           Control.DeepSeq
import           Data.List.Extra
import           Data.Maybe
import qualified Data.Text                    as T
import           GHC.Generics

import           GHC

import           Data.Bifunctor               (second)
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Orphans  ()
import           Development.IDE.GHC.Util
import qualified Documentation.Haddock.Parser as H
import qualified Documentation.Haddock.Types  as H

type DocMap = NameEnv SpanDoc
type TyThingMap = NameEnv TyThing

-- | Shows IEWrappedName, without any modifier, qualifier or unique identifier.
#if MIN_VERSION_ghc(9,5,0)
unqualIEWrapName :: IEWrappedName GhcPs -> T.Text
#else
unqualIEWrapName :: IEWrappedName RdrName -> T.Text
#endif
unqualIEWrapName :: IEWrappedName GhcPs -> Text
unqualIEWrapName = OccName -> Text
forall a. Outputable a => a -> Text
printOutputable (OccName -> Text)
-> (IEWrappedName GhcPs -> OccName) -> IEWrappedName GhcPs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (IEWrappedName GhcPs -> RdrName)
-> IEWrappedName GhcPs
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEWrappedName GhcPs -> IdP GhcPs
IEWrappedName GhcPs -> RdrName
forall (p :: Pass). IEWrappedName (GhcPass p) -> IdP (GhcPass p)
ieWrappedName

-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
safeTyThingType :: TyThing -> Maybe Type
safeTyThingType :: TyThing -> Maybe Type
safeTyThingType TyThing
thing
  | Just Id
i <- TyThing -> Maybe Id
safeTyThingId TyThing
thing = Type -> Maybe Type
forall a. a -> Maybe a
Just (Id -> Type
varType Id
i)
safeTyThingType (ATyCon TyCon
tycon)    = Type -> Maybe Type
forall a. a -> Maybe a
Just (TyCon -> Type
tyConKind TyCon
tycon)
safeTyThingType TyThing
_                 = Maybe Type
forall a. Maybe a
Nothing

safeTyThingId :: TyThing -> Maybe Id
safeTyThingId :: TyThing -> Maybe Id
safeTyThingId (AnId Id
i)                         = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
i
safeTyThingId (AConLike (RealDataCon DataCon
dataCon)) = Id -> Maybe Id
forall a. a -> Maybe a
Just (DataCon -> Id
dataConWrapId DataCon
dataCon)
safeTyThingId TyThing
_                                = Maybe Id
forall a. Maybe a
Nothing

-- Possible documentation for an element in the code
#if MIN_VERSION_ghc(9,3,0)
data SpanDoc
  = SpanDocString [HsDocString] SpanDocUris
#else
data SpanDoc
  = SpanDocString HsDocString SpanDocUris
#endif
  | SpanDocText   [T.Text] SpanDocUris
  deriving stock (SpanDoc -> SpanDoc -> Bool
(SpanDoc -> SpanDoc -> Bool)
-> (SpanDoc -> SpanDoc -> Bool) -> Eq SpanDoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpanDoc -> SpanDoc -> Bool
== :: SpanDoc -> SpanDoc -> Bool
$c/= :: SpanDoc -> SpanDoc -> Bool
/= :: SpanDoc -> SpanDoc -> Bool
Eq, Int -> SpanDoc -> ShowS
[SpanDoc] -> ShowS
SpanDoc -> [Char]
(Int -> SpanDoc -> ShowS)
-> (SpanDoc -> [Char]) -> ([SpanDoc] -> ShowS) -> Show SpanDoc
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpanDoc -> ShowS
showsPrec :: Int -> SpanDoc -> ShowS
$cshow :: SpanDoc -> [Char]
show :: SpanDoc -> [Char]
$cshowList :: [SpanDoc] -> ShowS
showList :: [SpanDoc] -> ShowS
Show, (forall x. SpanDoc -> Rep SpanDoc x)
-> (forall x. Rep SpanDoc x -> SpanDoc) -> Generic SpanDoc
forall x. Rep SpanDoc x -> SpanDoc
forall x. SpanDoc -> Rep SpanDoc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SpanDoc -> Rep SpanDoc x
from :: forall x. SpanDoc -> Rep SpanDoc x
$cto :: forall x. Rep SpanDoc x -> SpanDoc
to :: forall x. Rep SpanDoc x -> SpanDoc
Generic)
  deriving anyclass SpanDoc -> ()
(SpanDoc -> ()) -> NFData SpanDoc
forall a. (a -> ()) -> NFData a
$crnf :: SpanDoc -> ()
rnf :: SpanDoc -> ()
NFData

data SpanDocUris =
  SpanDocUris
  { SpanDocUris -> Maybe Text
spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page
  , SpanDocUris -> Maybe Text
spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page
  } deriving stock (SpanDocUris -> SpanDocUris -> Bool
(SpanDocUris -> SpanDocUris -> Bool)
-> (SpanDocUris -> SpanDocUris -> Bool) -> Eq SpanDocUris
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpanDocUris -> SpanDocUris -> Bool
== :: SpanDocUris -> SpanDocUris -> Bool
$c/= :: SpanDocUris -> SpanDocUris -> Bool
/= :: SpanDocUris -> SpanDocUris -> Bool
Eq, Int -> SpanDocUris -> ShowS
[SpanDocUris] -> ShowS
SpanDocUris -> [Char]
(Int -> SpanDocUris -> ShowS)
-> (SpanDocUris -> [Char])
-> ([SpanDocUris] -> ShowS)
-> Show SpanDocUris
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpanDocUris -> ShowS
showsPrec :: Int -> SpanDocUris -> ShowS
$cshow :: SpanDocUris -> [Char]
show :: SpanDocUris -> [Char]
$cshowList :: [SpanDocUris] -> ShowS
showList :: [SpanDocUris] -> ShowS
Show, (forall x. SpanDocUris -> Rep SpanDocUris x)
-> (forall x. Rep SpanDocUris x -> SpanDocUris)
-> Generic SpanDocUris
forall x. Rep SpanDocUris x -> SpanDocUris
forall x. SpanDocUris -> Rep SpanDocUris x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SpanDocUris -> Rep SpanDocUris x
from :: forall x. SpanDocUris -> Rep SpanDocUris x
$cto :: forall x. Rep SpanDocUris x -> SpanDocUris
to :: forall x. Rep SpanDocUris x -> SpanDocUris
Generic)
    deriving anyclass SpanDocUris -> ()
(SpanDocUris -> ()) -> NFData SpanDocUris
forall a. (a -> ()) -> NFData a
$crnf :: SpanDocUris -> ()
rnf :: SpanDocUris -> ()
NFData

emptySpanDoc :: SpanDoc
emptySpanDoc :: SpanDoc
emptySpanDoc = [Text] -> SpanDocUris -> SpanDoc
SpanDocText [] (Maybe Text -> Maybe Text -> SpanDocUris
SpanDocUris Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)

-- | Convert `SpanDoc` to Markdown format.
--
-- Return a list `Text` includes haddock, document uri and source code uri,
-- each item can be empty and must end with '\\n' if exist. This is to prevent
-- subsequent render problem caused by the missing newline.
--
-- Example:
--
-- For return value ["xxxx","yyyy"], if we concat the list with inserting
-- a separate line(note by "---\n"),
-- it will result "xxxx---\nyyyy" and can't be rendered as a normal doc.
-- Therefore we check every item in the value to make sure they all end with '\\n',
-- this makes "xxxx\n---\nyyy\n" and can be rendered correctly.
--
-- Notes:
--
-- To insert a new line in Markdown, we need two '\\n', like ("\\n\\n"), __or__ a section
-- symbol with one '\\n', like ("***\\n").
spanDocToMarkdown :: SpanDoc -> [T.Text]
spanDocToMarkdown :: SpanDoc -> [Text]
spanDocToMarkdown = \case
    (SpanDocString [HsDocString]
docs SpanDocUris
uris) ->
        let doc :: Text
doc = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ DocH [Char] [Char] -> [Char]
haddockToMarkdown (DocH [Char] [Char] -> [Char]) -> DocH [Char] [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ DocH [Char] Identifier -> DocH [Char] [Char]
forall mod. DocH mod Identifier -> DocH mod [Char]
H.toRegular (DocH [Char] Identifier -> DocH [Char] [Char])
-> DocH [Char] Identifier -> DocH [Char] [Char]
forall a b. (a -> b) -> a -> b
$ MetaDoc [Char] Identifier -> DocH [Char] Identifier
forall mod id. MetaDoc mod id -> DocH mod id
H._doc (MetaDoc [Char] Identifier -> DocH [Char] Identifier)
-> MetaDoc [Char] Identifier -> DocH [Char] Identifier
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [Char] -> MetaDoc [Char] Identifier
forall mod. Maybe [Char] -> [Char] -> MetaDoc mod Identifier
H.parseParas Maybe [Char]
forall a. Maybe a
Nothing ([Char] -> MetaDoc [Char] Identifier)
-> [Char] -> MetaDoc [Char] Identifier
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_ghc(9,3,0)
                      [HsDocString] -> [Char]
renderHsDocStrings [HsDocString]
docs
#else
                      unpackHDS docs
#endif
        in  [Text] -> SpanDocUris -> [Text]
go [Text
doc] SpanDocUris
uris
    (SpanDocText [Text]
txt SpanDocUris
uris) -> [Text] -> SpanDocUris -> [Text]
go [Text]
txt SpanDocUris
uris
  where
    go :: [Text] -> SpanDocUris -> [Text]
go [] SpanDocUris
uris = Text -> Text
render (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanDocUris -> [Text]
spanDocUrisToMarkdown SpanDocUris
uris
    go [Text]
txt SpanDocUris
uris = [Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
init [Text]
txt [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text -> Text
render ([Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
txt)] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
render (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanDocUris -> [Text]
spanDocUrisToMarkdown SpanDocUris
uris)
    -- If the doc is not end with an '\n', we append it.
    render :: Text -> Text
render Text
txt
      | Text -> Bool
T.null Text
txt = Text
txt
      | HasCallStack => Text -> Char
Text -> Char
T.last Text
txt Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = Text
txt
      | Bool
otherwise = Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
"\n"

spanDocUrisToMarkdown :: SpanDocUris -> [T.Text]
spanDocUrisToMarkdown :: SpanDocUris -> [Text]
spanDocUrisToMarkdown (SpanDocUris Maybe Text
mdoc Maybe Text
msrc) = [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes
  [ Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
linkify Text
"Documentation" (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mdoc
  , Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
linkify Text
"Source" (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
msrc
  ]
  where linkify :: a -> a -> a
linkify a
title a
uri = a
"[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
title a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"](" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
uri a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")"

spanDocToMarkdownForTest :: String -> String
spanDocToMarkdownForTest :: ShowS
spanDocToMarkdownForTest
  = DocH [Char] [Char] -> [Char]
haddockToMarkdown (DocH [Char] [Char] -> [Char])
-> ([Char] -> DocH [Char] [Char]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH [Char] Identifier -> DocH [Char] [Char]
forall mod. DocH mod Identifier -> DocH mod [Char]
H.toRegular (DocH [Char] Identifier -> DocH [Char] [Char])
-> ([Char] -> DocH [Char] Identifier)
-> [Char]
-> DocH [Char] [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaDoc [Char] Identifier -> DocH [Char] Identifier
forall mod id. MetaDoc mod id -> DocH mod id
H._doc (MetaDoc [Char] Identifier -> DocH [Char] Identifier)
-> ([Char] -> MetaDoc [Char] Identifier)
-> [Char]
-> DocH [Char] Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Char] -> [Char] -> MetaDoc [Char] Identifier
forall mod. Maybe [Char] -> [Char] -> MetaDoc mod Identifier
H.parseParas Maybe [Char]
forall a. Maybe a
Nothing

-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
haddockToMarkdown
  :: H.DocH String String -> String

haddockToMarkdown :: DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
H.DocEmpty
  = [Char]
""
haddockToMarkdown (H.DocAppend DocH [Char] [Char]
d1 DocH [Char] [Char]
d2)
  = DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
d1 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
d2
haddockToMarkdown (H.DocString [Char]
s)
  = ShowS
escapeBackticks [Char]
s
haddockToMarkdown (H.DocParagraph DocH [Char] [Char]
p)
  = [Char]
"\n\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
p
haddockToMarkdown (H.DocIdentifier [Char]
i)
  = [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
i [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
haddockToMarkdown (H.DocIdentifierUnchecked [Char]
i)
  = [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
i [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
#if MIN_VERSION_haddock_library(1,10,0)
haddockToMarkdown (H.DocModule (H.ModLink [Char]
i Maybe (DocH [Char] [Char])
Nothing))
  = [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks [Char]
i [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
-- See https://github.com/haskell/haddock/pull/1315
-- Module references can be labeled in markdown style, e.g. [some label]("Some.Module")
-- However, we don't want to use the link markup here, since the module name would be covered
-- up by the label. Thus, we keep both the label and module name in the following style:
-- some label ( `Some.Module` )
haddockToMarkdown (H.DocModule (H.ModLink [Char]
i (Just DocH [Char] [Char]
label)))
  = DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
label [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" ( `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks [Char]
i [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` )"
#else
haddockToMarkdown (H.DocModule i)
  = "`" ++ escapeBackticks i ++ "`"
#endif
haddockToMarkdown (H.DocWarning DocH [Char] [Char]
w)
  = DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
w
haddockToMarkdown (H.DocEmphasis DocH [Char] [Char]
d)
  = [Char]
"*" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
d [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"*"
haddockToMarkdown (H.DocBold DocH [Char] [Char]
d)
  = [Char]
"**" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
d [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"**"
haddockToMarkdown (H.DocMonospaced DocH [Char] [Char]
d)
  = [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
removeUnescapedBackticks (DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
d) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
haddockToMarkdown (H.DocCodeBlock DocH [Char] [Char]
d)
  = [Char]
"\n```haskell\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
d [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n```\n"
haddockToMarkdown (H.DocExamples [Example]
es)
  = [Char]
"\n```haskell\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines ((Example -> [Char]) -> [Example] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Example -> [Char]
exampleToMarkdown [Example]
es) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n```\n"
  where
    exampleToMarkdown :: Example -> [Char]
exampleToMarkdown (H.Example [Char]
expr [[Char]]
result)
      = [Char]
">>> " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
expr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines [[Char]]
result
haddockToMarkdown (H.DocHyperlink (H.Hyperlink [Char]
url Maybe (DocH [Char] [Char])
Nothing))
  = [Char]
"<" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">"
haddockToMarkdown (H.DocHyperlink (H.Hyperlink [Char]
url (Just DocH [Char] [Char]
label)))
  = [Char]
"[" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
label [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"](" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
haddockToMarkdown (H.DocPic (H.Picture [Char]
url Maybe [Char]
Nothing))
  = [Char]
"![](" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
haddockToMarkdown (H.DocPic (H.Picture [Char]
url (Just [Char]
label)))
  = [Char]
"![" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
label [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"](" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
haddockToMarkdown (H.DocAName [Char]
aname)
  = [Char]
"[" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks [Char]
aname [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"]:"
haddockToMarkdown (H.DocHeader (H.Header Int
level DocH [Char] [Char]
title))
  = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
level Char
'#' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
title

haddockToMarkdown (H.DocUnorderedList [DocH [Char] [Char]]
things)
  = Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ([[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (DocH [Char] [Char] -> [Char]) -> [DocH [Char] [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"+ " ++) ShowS
-> (DocH [Char] [Char] -> [Char]) -> DocH [Char] [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trimStart ShowS
-> (DocH [Char] [Char] -> [Char]) -> DocH [Char] [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
splitForList ShowS
-> (DocH [Char] [Char] -> [Char]) -> DocH [Char] [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH [Char] [Char] -> [Char]
haddockToMarkdown) [DocH [Char] [Char]]
things)
haddockToMarkdown (H.DocOrderedList [(Int, DocH [Char] [Char])]
things) =
#if MIN_VERSION_haddock_library(1,11,0)
  Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ([[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ((Int, DocH [Char] [Char]) -> [Char])
-> [(Int, DocH [Char] [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((\(Int
num, [Char]
str) -> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
". " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
str) ((Int, [Char]) -> [Char])
-> ((Int, DocH [Char] [Char]) -> (Int, [Char]))
-> (Int, DocH [Char] [Char])
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocH [Char] [Char] -> [Char])
-> (Int, DocH [Char] [Char]) -> (Int, [Char])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ShowS
trimStart ShowS
-> (DocH [Char] [Char] -> [Char]) -> DocH [Char] [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
splitForList ShowS
-> (DocH [Char] [Char] -> [Char]) -> DocH [Char] [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH [Char] [Char] -> [Char]
haddockToMarkdown)) [(Int, DocH [Char] [Char])]
things)
#else
  '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
#endif
haddockToMarkdown (H.DocDefList [(DocH [Char] [Char], DocH [Char] [Char])]
things)
  = Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ([[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ((DocH [Char] [Char], DocH [Char] [Char]) -> [Char])
-> [(DocH [Char] [Char], DocH [Char] [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\(DocH [Char] [Char]
term, DocH [Char] [Char]
defn) -> [Char]
"+ **" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
term [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"**: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH [Char] [Char] -> [Char]
haddockToMarkdown DocH [Char] [Char]
defn) [(DocH [Char] [Char], DocH [Char] [Char])]
things)

-- we cannot render math by default
haddockToMarkdown (H.DocMathInline [Char]
_)
  = [Char]
"*cannot render inline math formula*"
haddockToMarkdown (H.DocMathDisplay [Char]
_)
  = [Char]
"\n\n*cannot render display math formula*\n\n"

-- TODO: render tables
haddockToMarkdown (H.DocTable Table (DocH [Char] [Char])
_t)
  = [Char]
"\n\n*tables are not yet supported*\n\n"

-- things I don't really know how to handle
haddockToMarkdown (H.DocProperty [Char]
_)
  = [Char]
""  -- don't really know what to do

escapeBackticks :: String -> String
escapeBackticks :: ShowS
escapeBackticks [Char]
""       = [Char]
""
escapeBackticks (Char
'`':[Char]
ss) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'`'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escapeBackticks [Char]
ss
escapeBackticks (Char
s  :[Char]
ss) = Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escapeBackticks [Char]
ss

removeUnescapedBackticks :: String -> String
removeUnescapedBackticks :: ShowS
removeUnescapedBackticks = \case
  Char
'\\' : Char
'`' : [Char]
ss -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'`' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
removeUnescapedBackticks [Char]
ss
  Char
'`' : [Char]
ss        -> ShowS
removeUnescapedBackticks [Char]
ss
  [Char]
""              -> [Char]
""
  Char
s : [Char]
ss          -> Char
s Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
removeUnescapedBackticks [Char]
ss

splitForList :: String -> String
splitForList :: ShowS
splitForList [Char]
s
  = case [Char] -> [[Char]]
lines [Char]
s of
      []           -> [Char]
""
      ([Char]
first:[[Char]]
rest) -> [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
first [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"  " ++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trimStart) [[Char]]
rest