{-# LANGUAGE RecordWildCards #-}

module StaticLS.IDE.Workspace.Symbol where

import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Text as T
import Development.IDE.GHC.Util (printOutputable)
import Development.IDE.Types.Location
import GHC.Plugins hiding ((<>))
import qualified HieDb
import Language.LSP.Protocol.Types
import StaticLS.HIE.File (hieFilePathToSrcFilePath)
import StaticLS.Maybe
import StaticLS.StaticEnv (HasStaticEnv, runHieDbMaybeT)

symbolInfo :: (HasCallStack, HasStaticEnv m, MonadIO m) => T.Text -> m [SymbolInformation]
symbolInfo :: forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Text -> m [SymbolInformation]
symbolInfo Text
query = do
    Maybe [Res DefRow]
mHiedbDefs <- MaybeT m [Res DefRow] -> m (Maybe [Res DefRow])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m [Res DefRow] -> m (Maybe [Res DefRow]))
-> ((HieDb -> IO [Res DefRow]) -> MaybeT m [Res DefRow])
-> (HieDb -> IO [Res DefRow])
-> m (Maybe [Res DefRow])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HieDb -> IO [Res DefRow]) -> MaybeT m [Res DefRow]
forall (m :: * -> *) a.
(HasStaticEnv m, MonadIO m) =>
(HieDb -> IO a) -> MaybeT m a
runHieDbMaybeT ((HieDb -> IO [Res DefRow]) -> m (Maybe [Res DefRow]))
-> (HieDb -> IO [Res DefRow]) -> m (Maybe [Res DefRow])
forall a b. (a -> b) -> a -> b
$ \HieDb
hieDb -> HieDb -> String -> IO [Res DefRow]
HieDb.searchDef HieDb
hieDb (Text -> String
T.unpack Text
query)
    let hiedbDefs :: [Res DefRow]
hiedbDefs = [Res DefRow] -> Maybe [Res DefRow] -> [Res DefRow]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Res DefRow]
mHiedbDefs
    [Maybe SymbolInformation]
symbols <- (Res DefRow -> m (Maybe SymbolInformation))
-> [Res DefRow] -> m [Maybe SymbolInformation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Res DefRow -> m (Maybe SymbolInformation)
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
Res DefRow -> m (Maybe SymbolInformation)
defRowToSymbolInfo [Res DefRow]
hiedbDefs
    [SymbolInformation] -> m [SymbolInformation]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Maybe SymbolInformation] -> [SymbolInformation]
forall a. [Maybe a] -> [a]
catMaybes [Maybe SymbolInformation]
symbols)

-- Copy from https://github.com/haskell/haskell-language-server/blob/c126332850d27abc8efa519f8437ff7ea28d4049/ghcide/src/Development/IDE/Spans/AtPoint.hs#L392
-- With following modification
-- a. instead of replying on `modInfoSrcFile` (which is only present when hiedb index with `--src-base-dir`)
--    we could find src file path from `hieFilePathToSrcFilePath`
defRowToSymbolInfo :: (HasStaticEnv m, MonadIO m) => HieDb.Res HieDb.DefRow -> m (Maybe SymbolInformation)
defRowToSymbolInfo :: forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
Res DefRow -> m (Maybe SymbolInformation)
defRowToSymbolInfo (HieDb.DefRow{Int
String
OccName
defSrc :: String
defNameOcc :: OccName
defSLine :: Int
defSCol :: Int
defELine :: Int
defECol :: Int
defSrc :: DefRow -> String
defNameOcc :: DefRow -> OccName
defSLine :: DefRow -> Int
defSCol :: DefRow -> Int
defELine :: DefRow -> Int
defECol :: DefRow -> Int
..} HieDb.:. ModuleInfo
_) = MaybeT m SymbolInformation -> m (Maybe SymbolInformation)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m SymbolInformation -> m (Maybe SymbolInformation))
-> MaybeT m SymbolInformation -> m (Maybe SymbolInformation)
forall a b. (a -> b) -> a -> b
$ do
    do
        String
srcFile <- String -> MaybeT m String
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
String -> MaybeT m String
hieFilePathToSrcFilePath String
defSrc
        let file :: Uri
file = String -> Uri
toUri String
srcFile
            loc :: Location
loc = Uri -> Range -> Location
Location Uri
file Range
range
        SymbolKind
kind <- Maybe SymbolKind -> MaybeT m SymbolKind
forall (f :: * -> *) (g :: * -> *) a.
(Functor f, Foldable f, Alternative g) =>
f a -> g a
toAlt Maybe SymbolKind
mKind
        SymbolInformation -> MaybeT m SymbolInformation
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SymbolInformation -> MaybeT m SymbolInformation)
-> SymbolInformation -> MaybeT m SymbolInformation
forall a b. (a -> b) -> a -> b
$
            SymbolInformation
                { $sel:_name:SymbolInformation :: Text
_name = OccName -> Text
forall a. Outputable a => a -> Text
printOutputable OccName
defNameOcc
                , $sel:_kind:SymbolInformation :: SymbolKind
_kind = SymbolKind
kind
                , $sel:_tags:SymbolInformation :: Maybe [SymbolTag]
_tags = Maybe [SymbolTag]
forall a. Maybe a
Nothing
                , $sel:_containerName:SymbolInformation :: Maybe Text
_containerName = Maybe Text
forall a. Maybe a
Nothing
                , $sel:_deprecated:SymbolInformation :: Maybe Bool
_deprecated = Maybe Bool
forall a. Maybe a
Nothing
                , $sel:_location:SymbolInformation :: Location
_location = Location
loc
                }
  where
    mKind :: Maybe SymbolKind
mKind
        | OccName -> Bool
isVarOcc OccName
defNameOcc = SymbolKind -> Maybe SymbolKind
forall a. a -> Maybe a
Just SymbolKind
SymbolKind_Variable
        | OccName -> Bool
isDataOcc OccName
defNameOcc = SymbolKind -> Maybe SymbolKind
forall a. a -> Maybe a
Just SymbolKind
SymbolKind_Constructor
        | OccName -> Bool
isTcOcc OccName
defNameOcc = SymbolKind -> Maybe SymbolKind
forall a. a -> Maybe a
Just SymbolKind
SymbolKind_Struct
        | Bool
otherwise = Maybe SymbolKind
forall a. Maybe a
Nothing
    range :: Range
range = Position -> Position -> Range
Range Position
start Position
end
    start :: Position
start = UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
defSLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
defSCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    end :: Position
end = UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
defELine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
defECol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

toUri :: FilePath -> Uri
toUri :: String -> Uri
toUri = NormalizedUri -> Uri
fromNormalizedUri (NormalizedUri -> Uri)
-> (String -> NormalizedUri) -> String -> Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> NormalizedUri
filePathToUri' (NormalizedFilePath -> NormalizedUri)
-> (String -> NormalizedFilePath) -> String -> NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NormalizedFilePath
toNormalizedFilePath'