module StaticLS.IDE.Hover.Info (hoverInfo) where

import Data.Array
import Data.List.Extra (dropEnd1, nubOrd)
import qualified Data.Map as M
import qualified Data.Text as T
import Development.IDE.GHC.Error (realSrcSpanToRange)
import GHC hiding (getDocs)
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
import GHC.Plugins hiding ((<>))
import Language.LSP.Protocol.Types
import StaticLS.HI
import StaticLS.SDoc

-------------------------------------------------------------------
-- The following code is taken partially from halfsp
-- See: https://github.com/masaeedu/halfsp/blob/master/lib/GhcideSteal.hs
-- for the original source
-------------------------------------------------------------------
hoverInfo :: Array TypeIndex HieTypeFlat -> [NameDocs] -> HieAST TypeIndex -> (Maybe Range, [T.Text])
hoverInfo :: Array TypeIndex HieTypeFlat
-> [NameDocs] -> HieAST TypeIndex -> (Maybe Range, [Text])
hoverInfo Array TypeIndex HieTypeFlat
typeLookup [NameDocs]
docs HieAST TypeIndex
ast = (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
spanRange, ((Identifier, IdentifierDetails TypeIndex) -> Text)
-> [(Identifier, IdentifierDetails TypeIndex)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, IdentifierDetails TypeIndex) -> Text
prettyIdent [(Identifier, IdentifierDetails TypeIndex)]
idents [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
pTypes [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [NameDocs] -> [Text]
prettyDocumentation [NameDocs]
docs)
  where
    pTypes :: [Text]
pTypes
        | [(Identifier, IdentifierDetails TypeIndex)
_] <- [(Identifier, IdentifierDetails TypeIndex)]
idents = [Text] -> [Text]
forall a. [a] -> [a]
dropEnd1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
wrapHaskell [Text]
prettyTypes
        | Bool
otherwise = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
wrapHaskell [Text]
prettyTypes

    spanRange :: Range
spanRange = RealSrcSpan -> Range
realSrcSpanToRange (RealSrcSpan -> Range) -> RealSrcSpan -> Range
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST TypeIndex
ast

    wrapHaskell :: a -> a
wrapHaskell a
x = a
"\n```haskell\n" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\n```\n"
    info :: SourcedNodeInfo TypeIndex
info = HieAST TypeIndex -> SourcedNodeInfo TypeIndex
forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo HieAST TypeIndex
ast
    idents :: [(Identifier, IdentifierDetails TypeIndex)]
idents = Map Identifier (IdentifierDetails TypeIndex)
-> [(Identifier, IdentifierDetails TypeIndex)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map Identifier (IdentifierDetails TypeIndex)
 -> [(Identifier, IdentifierDetails TypeIndex)])
-> Map Identifier (IdentifierDetails TypeIndex)
-> [(Identifier, IdentifierDetails TypeIndex)]
forall a b. (a -> b) -> a -> b
$ SourcedNodeInfo TypeIndex
-> Map Identifier (IdentifierDetails TypeIndex)
forall a. SourcedNodeInfo a -> NodeIdentifiers a
sourcedNodeIdents SourcedNodeInfo TypeIndex
info
    types :: [TypeIndex]
types = (NodeInfo TypeIndex -> [TypeIndex])
-> [NodeInfo TypeIndex] -> [TypeIndex]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NodeInfo TypeIndex -> [TypeIndex]
forall a. NodeInfo a -> [a]
nodeType (Map NodeOrigin (NodeInfo TypeIndex) -> [NodeInfo TypeIndex]
forall k a. Map k a -> [a]
M.elems (Map NodeOrigin (NodeInfo TypeIndex) -> [NodeInfo TypeIndex])
-> Map NodeOrigin (NodeInfo TypeIndex) -> [NodeInfo TypeIndex]
forall a b. (a -> b) -> a -> b
$ SourcedNodeInfo TypeIndex -> Map NodeOrigin (NodeInfo TypeIndex)
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo TypeIndex
info)

    prettyIdent :: (Identifier, IdentifierDetails TypeIndex) -> T.Text
    prettyIdent :: (Identifier, IdentifierDetails TypeIndex) -> Text
prettyIdent (Right Name
n, IdentifierDetails TypeIndex
dets) =
        [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            [Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
wrapHaskell (Name -> Text
forall a. Outputable a => a -> Text
showNameWithoutUniques Name
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (TypeIndex -> Text) -> Maybe TypeIndex -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (TypeIndex -> Text) -> TypeIndex -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIndex -> Text
prettyType) (IdentifierDetails TypeIndex -> Maybe TypeIndex
forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails TypeIndex
dets))]
                [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Name -> [Text]
definedAt Name
n
    prettyIdent (Left ModuleName
m, IdentifierDetails TypeIndex
_) = ModuleName -> Text
forall a. Outputable a => a -> Text
showGhc ModuleName
m

    prettyTypes :: [Text]
prettyTypes = (TypeIndex -> Text) -> [TypeIndex] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"_ :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (TypeIndex -> Text) -> TypeIndex -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIndex -> Text
prettyType) [TypeIndex]
types

    prettyType :: TypeIndex -> Text
prettyType TypeIndex
t = IfaceType -> Text
forall a. Outputable a => a -> Text
showGhc (IfaceType -> Text) -> IfaceType -> Text
forall a b. (a -> b) -> a -> b
$ HieTypeFix -> IfaceType
hieTypeToIface (HieTypeFix -> IfaceType) -> HieTypeFix -> IfaceType
forall a b. (a -> b) -> a -> b
$ TypeIndex -> Array TypeIndex HieTypeFlat -> HieTypeFix
recoverFullType TypeIndex
t Array TypeIndex HieTypeFlat
typeLookup

    definedAt :: Name -> [Text]
definedAt Name
name =
        -- do not show "at <no location info>" and similar messages
        -- see the code of 'pprNameDefnLoc' for more information
        case Name -> SrcLoc
nameSrcLoc Name
name of
            UnhelpfulLoc{} | Name -> Bool
isInternalName Name
name Bool -> Bool -> Bool
|| Name -> Bool
isSystemName Name
name -> []
            SrcLoc
_ -> [Text
"*Defined " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SDoc -> Text
showSD (Name -> SDoc
pprNameDefnLoc Name
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*"]

    -- TODO: pretify more
    prettyDocumentation :: [NameDocs] -> [Text]
prettyDocumentation [NameDocs]
docs' =
        let renderedDocs :: Text
renderedDocs = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ NameDocs -> Text
renderNameDocs (NameDocs -> Text) -> [NameDocs] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameDocs]
docs'
         in case Text
renderedDocs of
                Text
"" -> []
                Text
_ -> [Text
"\n", Text
"Documentation:\n"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Text]
forall a. Ord a => [a] -> [a]
nubOrd (NameDocs -> Text
renderNameDocs (NameDocs -> Text) -> [NameDocs] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameDocs]
docs')