{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
#include "ghc-api-version.h"
module Development.IDE.Spans.Common (
showGhc
, showName
, showNameWithoutUniques
, safeTyThingId
, safeTyThingType
, SpanDoc(..)
, SpanDocUris(..)
, emptySpanDoc
, spanDocToMarkdown
, spanDocToMarkdownForTest
, DocMap
, KindMap
) where
import Data.Maybe
import qualified Data.Text as T
import Data.List.Extra
import Control.DeepSeq
import GHC.Generics
import GHC
import Outputable hiding ((<>))
import ConLike
import DataCon
import Var
import NameEnv
import qualified Documentation.Haddock.Parser as H
import qualified Documentation.Haddock.Types as H
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Orphans ()
type DocMap = NameEnv SpanDoc
type KindMap = NameEnv TyThing
showGhc :: Outputable a => a -> String
showGhc :: a -> String
showGhc = DynFlags -> a -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
unsafeGlobalDynFlags
showName :: Outputable a => a -> T.Text
showName :: a -> Text
showName = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Outputable a => a -> String
prettyprint
where
prettyprint :: a -> String
prettyprint a
x = DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
unsafeGlobalDynFlags (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x) PprStyle
style
style :: PprStyle
style = DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle DynFlags
unsafeGlobalDynFlags PrintUnqualified
neverQualify Depth
AllTheWay
showNameWithoutUniques :: Outputable a => a -> T.Text
showNameWithoutUniques :: a -> Text
showNameWithoutUniques = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Outputable a => a -> String
prettyprint
where
dyn :: DynFlags
dyn = DynFlags
unsafeGlobalDynFlags DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_SuppressUniques
prettyprint :: a -> String
prettyprint a
x = DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
dyn (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x) PprStyle
style
style :: PprStyle
style = DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle DynFlags
dyn PrintUnqualified
neverQualify Depth
AllTheWay
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
dc)) = Id -> Maybe Id
forall a. a -> Maybe a
Just (Id -> Maybe Id) -> Id -> Maybe Id
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWrapId DataCon
dc
safeTyThingId TyThing
_ = Maybe Id
forall a. Maybe a
Nothing
data SpanDoc
= SpanDocString HsDocString SpanDocUris
| 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
/= :: SpanDoc -> SpanDoc -> Bool
$c/= :: SpanDoc -> SpanDoc -> Bool
== :: SpanDoc -> SpanDoc -> Bool
$c== :: SpanDoc -> SpanDoc -> Bool
Eq, Int -> SpanDoc -> ShowS
[SpanDoc] -> ShowS
SpanDoc -> String
(Int -> SpanDoc -> ShowS)
-> (SpanDoc -> String) -> ([SpanDoc] -> ShowS) -> Show SpanDoc
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. 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
$cto :: forall x. Rep SpanDoc x -> SpanDoc
$cfrom :: forall x. SpanDoc -> Rep SpanDoc x
Generic)
deriving anyclass SpanDoc -> ()
(SpanDoc -> ()) -> NFData SpanDoc
forall a. (a -> ()) -> NFData a
rnf :: SpanDoc -> ()
$crnf :: SpanDoc -> ()
NFData
data SpanDocUris =
SpanDocUris
{ SpanDocUris -> Maybe Text
spanDocUriDoc :: Maybe T.Text
, SpanDocUris -> Maybe Text
spanDocUriSrc :: Maybe T.Text
} deriving stock (SpanDocUris -> SpanDocUris -> Bool
(SpanDocUris -> SpanDocUris -> Bool)
-> (SpanDocUris -> SpanDocUris -> Bool) -> Eq SpanDocUris
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
(Int -> SpanDocUris -> ShowS)
-> (SpanDocUris -> String)
-> ([SpanDocUris] -> ShowS)
-> Show SpanDocUris
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. 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
$cto :: forall x. Rep SpanDocUris x -> SpanDocUris
$cfrom :: forall x. SpanDocUris -> Rep SpanDocUris x
Generic)
deriving anyclass SpanDocUris -> ()
(SpanDocUris -> ()) -> NFData 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 Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)
spanDocToMarkdown :: SpanDoc -> [T.Text]
spanDocToMarkdown :: SpanDoc -> [Text]
spanDocToMarkdown (SpanDocString HsDocString
docs SpanDocUris
uris)
= [String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DocH String String -> String
haddockToMarkdown (DocH String String -> String) -> DocH String String -> String
forall a b. (a -> b) -> a -> b
$ DocH String Identifier -> DocH String String
forall mod. DocH mod Identifier -> DocH mod String
H.toRegular (DocH String Identifier -> DocH String String)
-> DocH String Identifier -> DocH String String
forall a b. (a -> b) -> a -> b
$ MetaDoc String Identifier -> DocH String Identifier
forall mod id. MetaDoc mod id -> DocH mod id
H._doc (MetaDoc String Identifier -> DocH String Identifier)
-> MetaDoc String Identifier -> DocH String Identifier
forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> MetaDoc String Identifier
forall mod. Maybe String -> String -> MetaDoc mod Identifier
H.parseParas Maybe String
forall a. Maybe a
Nothing (String -> MetaDoc String Identifier)
-> String -> MetaDoc String Identifier
forall a b. (a -> b) -> a -> b
$ HsDocString -> String
unpackHDS HsDocString
docs]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"\n"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> SpanDocUris -> [Text]
spanDocUrisToMarkdown SpanDocUris
uris
spanDocToMarkdown (SpanDocText [Text]
txt SpanDocUris
uris) = [Text]
txt [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"\n"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> SpanDocUris -> [Text]
spanDocUrisToMarkdown SpanDocUris
uris
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 String String -> String
haddockToMarkdown (DocH String String -> String)
-> (String -> DocH String String) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH String Identifier -> DocH String String
forall mod. DocH mod Identifier -> DocH mod String
H.toRegular (DocH String Identifier -> DocH String String)
-> (String -> DocH String Identifier)
-> String
-> DocH String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaDoc String Identifier -> DocH String Identifier
forall mod id. MetaDoc mod id -> DocH mod id
H._doc (MetaDoc String Identifier -> DocH String Identifier)
-> (String -> MetaDoc String Identifier)
-> String
-> DocH String Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> String -> MetaDoc String Identifier
forall mod. Maybe String -> String -> MetaDoc mod Identifier
H.parseParas Maybe String
forall a. Maybe a
Nothing
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
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" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
p
haddockToMarkdown (H.DocIdentifier String
i)
= String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
haddockToMarkdown (H.DocIdentifierUnchecked String
i)
= String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
haddockToMarkdown (H.DocModule String
i)
= String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
haddockToMarkdown (H.DocWarning DocH String String
w)
= DocH String String -> String
haddockToMarkdown DocH String String
w
haddockToMarkdown (H.DocEmphasis DocH String String
d)
= String
"*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"*"
haddockToMarkdown (H.DocBold DocH String String
d)
= String
"**" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"**"
haddockToMarkdown (H.DocMonospaced DocH String String
d)
= String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
removeUnescapedBackticks (DocH String String -> String
haddockToMarkdown DocH String String
d) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
haddockToMarkdown (H.DocCodeBlock DocH String String
d)
= String
"\n```haskell\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n```\n"
haddockToMarkdown (H.DocExamples [Example]
es)
= String
"\n```haskell\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((Example -> String) -> [Example] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Example -> String
exampleToMarkdown [Example]
es) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n```\n"
where
exampleToMarkdown :: Example -> String
exampleToMarkdown (H.Example String
expr [String]
result)
= String
">>> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
expr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String]
result
haddockToMarkdown (H.DocHyperlink (H.Hyperlink String
url Maybe (DocH String String)
Nothing))
= String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
haddockToMarkdown (H.DocHyperlink (H.Hyperlink String
url (Just DocH String String
label)))
= String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"](" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
haddockToMarkdown (H.DocPic (H.Picture String
url Maybe String
Nothing))
= String
"![](" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
haddockToMarkdown (H.DocPic (H.Picture String
url (Just String
label)))
= String
"![" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"](" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
haddockToMarkdown (H.DocAName String
aname)
= String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escapeBackticks String
aname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]:"
haddockToMarkdown (H.DocHeader (H.Header Int
level DocH String String
title))
= Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
level Char
'#' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
title
haddockToMarkdown (H.DocUnorderedList [DocH String String]
things)
= Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (DocH String String -> String) -> [DocH String String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"+ " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (DocH String String -> String) -> DocH String String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trimStart ShowS
-> (DocH String String -> String) -> DocH String String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
splitForList ShowS
-> (DocH String String -> String) -> DocH String String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH String String -> String
haddockToMarkdown) [DocH String String]
things)
haddockToMarkdown (H.DocOrderedList [DocH String String]
things)
= Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (DocH String String -> String) -> [DocH String String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"1. " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (DocH String String -> String) -> DocH String String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trimStart ShowS
-> (DocH String String -> String) -> DocH String String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
splitForList ShowS
-> (DocH String String -> String) -> DocH String String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH String String -> String
haddockToMarkdown) [DocH String String]
things)
haddockToMarkdown (H.DocDefList [(DocH String String, DocH String String)]
things)
= Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((DocH String String, DocH String String) -> String)
-> [(DocH String String, DocH String String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(DocH String String
term, DocH String String
defn) -> String
"+ **" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
term String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"**: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DocH String String -> String
haddockToMarkdown DocH String String
defn) [(DocH String String, DocH String String)]
things)
haddockToMarkdown (H.DocMathInline String
_)
= String
"*cannot render inline math formula*"
haddockToMarkdown (H.DocMathDisplay String
_)
= String
"\n\n*cannot render display math formula*\n\n"
haddockToMarkdown (H.DocTable Table (DocH String String)
_t)
= String
"\n\n*tables are not yet supported*\n\n"
haddockToMarkdown (H.DocProperty String
_)
= String
""
escapeBackticks :: String -> String
escapeBackticks :: ShowS
escapeBackticks String
"" = String
""
escapeBackticks (Char
'`':String
ss) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'`'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escapeBackticks String
ss
escapeBackticks (Char
s :String
ss) = Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escapeBackticks String
ss
removeUnescapedBackticks :: String -> String
removeUnescapedBackticks :: ShowS
removeUnescapedBackticks = \case
Char
'\\' : Char
'`' : String
ss -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'`' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
removeUnescapedBackticks String
ss
Char
'`' : String
ss -> ShowS
removeUnescapedBackticks String
ss
String
"" -> String
""
Char
s : String
ss -> Char
s Char -> ShowS
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
first String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trimStart) [String]
rest