{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module HsInspect.LSP.Impl where
import Control.Monad (guard)
import Control.Monad.Extra (fromMaybeM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT(..))
import Control.Monad.Trans.Except (throwE)
import Data.Cache (Cache)
import qualified Data.Cache as C
import Data.List (nub)
import Data.List.Extra (firstJust)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Debug.Trace
import qualified FastString as GHC
import qualified GHC as GHC
import GHC.Paths (libdir)
import HsInspect.LSP.Context
import HsInspect.LSP.HsInspect
import qualified Lexer as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
import System.FilePath (takeDirectory)
data Caches = Caches
(Cache FilePath Context)
(Cache FilePath [Import])
(Cache FilePath [Package])
cachedContext :: Caches -> FilePath -> ExceptT String IO Context
cachedContext (Caches cache _ _) file = do
key <- takeDirectory <$> discoverGhcflags file
let work = do
ctx <- findContext file
liftIO $ C.insert cache key ctx
pure ctx
fromMaybeM work . liftIO $ C.lookup cache key
cachedImports :: Caches -> Context -> FilePath -> ExceptT String IO [Import]
cachedImports (Caches _ cache _) ctx file =
C.fetchWithCache cache file $ hsinspect_imports ctx
cachedIndex :: Caches -> Context -> ExceptT String IO [Package]
cachedIndex (Caches _ _ cache) ctx =
C.fetchWithCache cache (srcdir ctx) $ \_ -> hsinspect_index ctx
cachedIndex' :: Caches -> Context -> ExceptT String IO [Package]
cachedIndex' (Caches _ _ cache) ctx = liftIO $
fromMaybe [] <$> C.lookup cache (srcdir ctx)
data Span = Span Int Int Int Int
deriving Show
getFullModuleName :: Text -> [Import] -> Maybe Text
getFullModuleName query imports =
case results of
[] -> Nothing
result:_ -> Just result
where results = mapMaybe extractModule imports
extractModule imp = do
qualName <- _qual imp
guard $ T.isPrefixOf query qualName
let fullImport = _full imp
let (T.init -> module', _) =
T.breakOnEnd "." fullImport
return $ module'
findType :: Text -> [Package] -> Maybe Text
findType qual pkgs = listToMaybe $ do
let (T.init -> module', sym) = T.breakOnEnd "." qual
let flatten Nothing = []
flatten (Just as) = as
pkg <- pkgs
Module module'' entries <- flatten . _modules $ pkg
if module'' /= module'
then []
else do
e <- flatten entries
let matcher name typ = if name == sym && name /= typ then [typ] else []
case e of
Id _ name typ -> matcher name typ
Con _ name typ -> matcher name typ
Pat _ name typ -> matcher name typ
TyCon _ _ _ -> []
findNameAndTypes :: Text -> [Package] -> [(Text, Text, Text)]
findNameAndTypes qual pkgs = do
let (_, sym) = T.breakOnEnd "." qual
let flatten Nothing = []
flatten (Just as) = as
pkg <- pkgs
Module m entries <- flatten . _modules $ pkg
e <- flatten entries
let matcher name typ = if T.isPrefixOf sym name then [(name, typ, m)] else []
case traceShowId e of
Id _ name typ -> matcher name typ
Con _ name typ -> matcher name typ
Pat _ name typ -> matcher name typ
TyCon _ _ _ -> []
hoverProvider :: Caches -> FilePath -> (Int, Int) -> ExceptT String IO (Maybe (Span, Text))
hoverProvider caches file position = do
ctx <- cachedContext caches file
symbols <- cachedImports caches ctx file
index <- cachedIndex' caches ctx
found <- symbolAtPoint file position
pure $ case traceShow found found of
Nothing -> Nothing
Just (range, sym) ->
let matcher imp = if _local imp == Just sym || _qual imp == Just sym || _full imp == sym
then Just $ case findType (_full imp) index of
Just typ -> _full imp <> " :: " <> typ
Nothing -> _full imp
else Nothing
in (range,) <$> firstJust matcher symbols
completionProvider :: Caches -> FilePath -> Text -> (Int, Int) -> ExceptT String IO [(Text, Maybe Text)]
completionProvider caches file contents position = do
ctx <- cachedContext caches file
symbols <- cachedImports caches ctx file
index <- cachedIndex' caches ctx
found <- symbolAtVirtualPoint file contents position
pure $ case traceShow (found, symbols) found of
Nothing -> []
Just (_, sym) -> do
let findNameAndType :: Text -> Import -> (Text, Maybe Text)
findNameAndType name imp =
case findType (_full imp) index of
Just typ -> (name, Just typ)
Nothing -> (name, Nothing)
matcher :: (Import -> Maybe Text) -> Import -> Maybe (Text, Maybe Text)
matcher key imp = do
pref <- key imp
if T.isPrefixOf sym pref
then return $ findNameAndType pref imp
else Nothing
let localMatches = map (matcher _local) symbols
let qualMatches = map (matcher _qual) symbols
let fullMatches = map (matcher (Just . _full)) symbols
nub $ catMaybes $ localMatches <> qualMatches <> fullMatches
symbolAtPoint :: FilePath -> (Int, Int) -> ExceptT String IO (Maybe (Span, Text))
symbolAtPoint file (line, col) = do
buf' <- liftIO $ GHC.hGetStringBuffer file
buf <- maybe (throwE "line doesn't exist") pure $ GHC.atLine 1 buf'
let file' = GHC.mkFastString file
startLoc = GHC.mkRealSrcLoc file' 1 1
point = GHC.realSrcLocSpan $ GHC.mkRealSrcLoc file' line (col + 1)
dflags <- liftIO . GHC.runGhc (Just libdir) $ GHC.getSessionDynFlags
case GHC.lexTokenStream buf startLoc dflags of
GHC.POk _ ts ->
let containsPoint :: (GHC.Located GHC.Token, String) -> Maybe (Span, Text)
containsPoint ((GHC.L (GHC.UnhelpfulSpan _) _), _) = Nothing
containsPoint ((GHC.L (GHC.RealSrcSpan s) _), txt) =
if GHC.containsSpan s point then Just (toSpan s, T.pack txt) else Nothing
toSpan src = Span
(GHC.srcSpanStartLine src - 1)
(GHC.srcSpanStartCol src - 1)
(GHC.srcSpanEndLine src - 1)
(GHC.srcSpanEndCol src - 1)
in pure . firstJust containsPoint $ GHC.addSourceToTokens startLoc buf ts
_ -> throwE "lexer error"
symbolAtVirtualPoint :: FilePath -> Text -> (Int, Int) -> ExceptT String IO (Maybe (Span, Text))
symbolAtVirtualPoint file contents (line, col) = do
let buf' = GHC.stringToStringBuffer $ T.unpack contents
buf <- maybe (throwE "line doesn't exist") pure $ GHC.atLine 1 buf'
let file' = GHC.mkFastString file
startLoc = GHC.mkRealSrcLoc file' 1 1
point = GHC.realSrcLocSpan $ GHC.mkRealSrcLoc file' line col
dflags <- liftIO . GHC.runGhc (Just libdir) $ GHC.getSessionDynFlags
case GHC.lexTokenStream buf startLoc dflags of
GHC.POk _ ts ->
let containsPoint :: (GHC.Located GHC.Token, String) -> Maybe (Span, Text)
containsPoint ((GHC.L (GHC.UnhelpfulSpan _) _), _) = Nothing
containsPoint ((GHC.L (GHC.RealSrcSpan s) _), txt) =
if GHC.containsSpan s point then Just (toSpan s, T.pack txt) else Nothing
toSpan src = Span
(GHC.srcSpanStartLine src - 1)
(GHC.srcSpanStartCol src - 1)
(GHC.srcSpanEndLine src - 1)
(GHC.srcSpanEndCol src - 1)
in pure . firstJust containsPoint $ GHC.addSourceToTokens startLoc buf ts
_ -> throwE "lexer error"