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

module Development.IDE.Spans.Common (
  unqualIEWrapName
, safeTyThingId
, safeTyThingType
, SpanDoc(..)
, SpanDocUris(..)
, emptySpanDoc
, spanDocToMarkdown
, spanDocToMarkdownForTest
, DocMap
, KindMap
) 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 KindMap = 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 RdrName -> Text
unqualIEWrapName = forall a. Outputable a => a -> Text
printOutputable forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. IEWrappedName name -> name
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 = forall a. a -> Maybe a
Just (Id -> Type
varType Id
i)
safeTyThingType (ATyCon TyCon
tycon)    = forall a. a -> Maybe a
Just (TyCon -> Type
tyConKind TyCon
tycon)
safeTyThingType TyThing
_                 = forall a. Maybe a
Nothing

safeTyThingId :: TyThing -> Maybe Id
safeTyThingId :: TyThing -> Maybe Id
safeTyThingId (AnId Id
i)                         = forall a. a -> Maybe a
Just Id
i
safeTyThingId (AConLike (RealDataCon DataCon
dataCon)) = forall a. a -> Maybe a
Just (DataCon -> Id
dataConWrapId DataCon
dataCon)
safeTyThingId TyThing
_                                = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpanDoc -> SpanDoc -> Bool
$c/= :: SpanDoc -> SpanDoc -> Bool
== :: SpanDoc -> SpanDoc -> Bool
$c== :: SpanDoc -> SpanDoc -> Bool
Eq, Int -> SpanDoc -> ShowS
[SpanDoc] -> ShowS
SpanDoc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpanDoc] -> ShowS
$cshowList :: [SpanDoc] -> ShowS
show :: SpanDoc -> String
$cshow :: SpanDoc -> String
showsPrec :: Int -> SpanDoc -> ShowS
$cshowsPrec :: Int -> SpanDoc -> ShowS
Show, 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
$cto :: forall x. Rep SpanDoc x -> SpanDoc
$cfrom :: forall x. SpanDoc -> Rep SpanDoc x
Generic)
  deriving anyclass SpanDoc -> ()
forall a. (a -> ()) -> NFData a
rnf :: SpanDoc -> ()
$crnf :: 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpanDocUris -> SpanDocUris -> Bool
$c/= :: SpanDocUris -> SpanDocUris -> Bool
== :: SpanDocUris -> SpanDocUris -> Bool
$c== :: SpanDocUris -> SpanDocUris -> Bool
Eq, Int -> SpanDocUris -> ShowS
[SpanDocUris] -> ShowS
SpanDocUris -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpanDocUris] -> ShowS
$cshowList :: [SpanDocUris] -> ShowS
show :: SpanDocUris -> String
$cshow :: SpanDocUris -> String
showsPrec :: Int -> SpanDocUris -> ShowS
$cshowsPrec :: Int -> SpanDocUris -> ShowS
Show, 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
$cto :: forall x. Rep SpanDocUris x -> SpanDocUris
$cfrom :: forall x. SpanDocUris -> Rep SpanDocUris x
Generic)
    deriving anyclass SpanDocUris -> ()
forall a. (a -> ()) -> NFData a
rnf :: SpanDocUris -> ()
$crnf :: SpanDocUris -> ()
NFData

emptySpanDoc :: SpanDoc
emptySpanDoc :: SpanDoc
emptySpanDoc = [Text] -> SpanDocUris -> SpanDoc
SpanDocText [] (Maybe Text -> Maybe Text -> SpanDocUris
SpanDocUris forall a. Maybe a
Nothing 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 = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ DocH String String -> String
haddockToMarkdown forall a b. (a -> b) -> a -> b
$ forall mod. DocH mod Identifier -> DocH mod String
H.toRegular forall a b. (a -> b) -> a -> b
$ forall mod id. MetaDoc mod id -> DocH mod id
H._doc forall a b. (a -> b) -> a -> b
$ forall mod. Maybe String -> String -> MetaDoc mod Identifier
H.parseParas forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_ghc(9,3,0)
                      renderHsDocStrings docs
#else
                      HsDocString -> String
unpackHDS HsDocString
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanDocUris -> [Text]
spanDocUrisToMarkdown SpanDocUris
uris
    go [Text]
txt SpanDocUris
uris = forall a. [a] -> [a]
init [Text]
txt forall a. Semigroup a => a -> a -> a
<> [Text -> Text
render (forall a. [a] -> a
last [Text]
txt)] forall a. Semigroup a => a -> a -> a
<> (Text -> Text
render 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
      | Text -> Char
T.last Text
txt forall a. Eq a => a -> a -> Bool
== Char
'\n' = Text
txt
      | Bool
otherwise = Text
txt forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
"\n"

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

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

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

haddockToMarkdown :: DocH String String -> String
haddockToMarkdown DocH String String
H.DocEmpty
  = String
""
haddockToMarkdown (H.DocAppend DocH String String
d1 DocH String String
d2)
  = DocH String String -> String
haddockToMarkdown DocH String String
d1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
d2
haddockToMarkdown (H.DocString String
s)
  = ShowS
escapeBackticks String
s
haddockToMarkdown (H.DocParagraph DocH String String
p)
  = String
"\n\n" forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
p
haddockToMarkdown (H.DocIdentifier String
i)
  = String
"`" forall a. [a] -> [a] -> [a]
++ String
i forall a. [a] -> [a] -> [a]
++ String
"`"
haddockToMarkdown (H.DocIdentifierUnchecked String
i)
  = String
"`" forall a. [a] -> [a] -> [a]
++ String
i forall a. [a] -> [a] -> [a]
++ String
"`"
#if MIN_VERSION_haddock_library(1,10,0)
haddockToMarkdown (H.DocModule (H.ModLink String
i Maybe (DocH String String)
Nothing))
  = String
"`" forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks String
i forall a. [a] -> [a] -> [a]
++ String
"`"
-- 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 String
i (Just DocH String String
label)))
  = DocH String String -> String
haddockToMarkdown DocH String String
label forall a. [a] -> [a] -> [a]
++ String
" ( `" forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks String
i forall a. [a] -> [a] -> [a]
++ String
"` )"
#else
haddockToMarkdown (H.DocModule i)
  = "`" ++ escapeBackticks i ++ "`"
#endif
haddockToMarkdown (H.DocWarning DocH String String
w)
  = DocH String String -> String
haddockToMarkdown DocH String String
w
haddockToMarkdown (H.DocEmphasis DocH String String
d)
  = String
"*" forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
d forall a. [a] -> [a] -> [a]
++ String
"*"
haddockToMarkdown (H.DocBold DocH String String
d)
  = String
"**" forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
d forall a. [a] -> [a] -> [a]
++ String
"**"
haddockToMarkdown (H.DocMonospaced DocH String String
d)
  = String
"`" forall a. [a] -> [a] -> [a]
++ ShowS
removeUnescapedBackticks (DocH String String -> String
haddockToMarkdown DocH String String
d) forall a. [a] -> [a] -> [a]
++ String
"`"
haddockToMarkdown (H.DocCodeBlock DocH String String
d)
  = String
"\n```haskell\n" forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
d forall a. [a] -> [a] -> [a]
++ String
"\n```\n"
haddockToMarkdown (H.DocExamples [Example]
es)
  = String
"\n```haskell\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map Example -> String
exampleToMarkdown [Example]
es) forall a. [a] -> [a] -> [a]
++ String
"\n```\n"
  where
    exampleToMarkdown :: Example -> String
exampleToMarkdown (H.Example String
expr [String]
result)
      = String
">>> " forall a. [a] -> [a] -> [a]
++ String
expr forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String]
result
haddockToMarkdown (H.DocHyperlink (H.Hyperlink String
url Maybe (DocH String String)
Nothing))
  = String
"<" forall a. [a] -> [a] -> [a]
++ String
url forall a. [a] -> [a] -> [a]
++ String
">"
haddockToMarkdown (H.DocHyperlink (H.Hyperlink String
url (Just DocH String String
label)))
  = String
"[" forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
label forall a. [a] -> [a] -> [a]
++ String
"](" forall a. [a] -> [a] -> [a]
++ String
url forall a. [a] -> [a] -> [a]
++ String
")"
haddockToMarkdown (H.DocPic (H.Picture String
url Maybe String
Nothing))
  = String
"![](" forall a. [a] -> [a] -> [a]
++ String
url forall a. [a] -> [a] -> [a]
++ String
")"
haddockToMarkdown (H.DocPic (H.Picture String
url (Just String
label)))
  = String
"![" forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
"](" forall a. [a] -> [a] -> [a]
++ String
url forall a. [a] -> [a] -> [a]
++ String
")"
haddockToMarkdown (H.DocAName String
aname)
  = String
"[" forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks String
aname forall a. [a] -> [a] -> [a]
++ String
"]:"
haddockToMarkdown (H.DocHeader (H.Header Int
level DocH String String
title))
  = forall a. Int -> a -> [a]
replicate Int
level Char
'#' forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
title

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

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

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

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

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

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

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