static-ls (empty) → 0.1.0
raw patch · 25 files changed
+1298/−0 lines, 25 filesdep +arraydep +basedep +containers
Dependencies added: array, base, containers, directory, errors, extra, filepath, ghc, ghc-paths, ghcide, hiedb, hspec, lsp, lsp-types, mtl, sqlite-simple, static-ls, template-haskell, text, transformers, unliftio-core
Files
- CHANGELOG.md +8/−0
- LICENSE +20/−0
- app/Main.hs +8/−0
- src/StaticLS/Except.hs +7/−0
- src/StaticLS/HIE.hs +61/−0
- src/StaticLS/HIE/File.hs +178/−0
- src/StaticLS/HIE/File/Except.hs +13/−0
- src/StaticLS/IDE/Definition.hs +125/−0
- src/StaticLS/IDE/Hover.hs +48/−0
- src/StaticLS/IDE/Hover/Info.hs +68/−0
- src/StaticLS/IDE/References.hs +52/−0
- src/StaticLS/Maybe.hs +19/−0
- src/StaticLS/Server.hs +111/−0
- src/StaticLS/StaticEnv.hs +105/−0
- src/StaticLS/StaticEnv/Options.hs +21/−0
- static-ls.cabal +164/−0
- test/Spec.hs +2/−0
- test/StaticLS/HIE/FileSpec.hs +78/−0
- test/StaticLS/IDE/DefinitionSpec.hs +56/−0
- test/StaticLS/IDE/HoverSpec.hs +18/−0
- test/TestData/Mod1.hs +11/−0
- test/TestData/Mod2.hs +5/−0
- test/TestImport.hs +38/−0
- test/TestImport/Assert.hs +30/−0
- test/TestImport/TestData.hs +52/−0
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# Revision history for static-ls++## 0.1.0.0 -- 2023-04-13++* Initial release supporting+ * find references globally when hie files and hiedb are available+ * type on hover when hie files are available+ * find definition locally and globally when hie files and hiedb are available
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Joseph Sumabat++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified StaticLS.Server as StaticLS++main :: IO ()+main = do+ _ <- StaticLS.runServer+ pure ()
+ src/StaticLS/Except.hs view
@@ -0,0 +1,7 @@+module StaticLS.Except where++import Control.Error.Util+import Control.Monad.Trans.Except++exceptToMaybe :: Except a b -> Maybe b+exceptToMaybe = hush . runExcept
+ src/StaticLS/HIE.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TypeApplications #-}++module StaticLS.HIE (+ hieAstNodeToIdentifiers,+ identifiersToNames,+ hieAstToNames,+ hieAstsAtPoint,+ hiedbCoordsToLspPosition,+ lspPositionToHieDbCoords,+)+where++import Control.Error.Util (hush)+import Control.Exception (Exception)+import Control.Monad ((<=<))+import Control.Monad.Trans.Except (ExceptT, throwE)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import qualified GHC+import qualified GHC.Iface.Ext.Types as GHC+import HieDb (pointCommand)+import qualified Language.LSP.Types as LSP++type HieDbCoords = (Int, Int)++data UIntConversionException = UIntConversionException+ deriving (Show)++instance Exception UIntConversionException++hieAstNodeToIdentifiers :: GHC.HieAST a -> [GHC.Identifier]+hieAstNodeToIdentifiers =+ (Set.toList . Map.keysSet) <=< fmap GHC.nodeIdentifiers . Map.elems . GHC.getSourcedNodeInfo . GHC.sourcedNodeInfo++identifiersToNames :: [GHC.Identifier] -> [GHC.Name]+identifiersToNames =+ mapMaybe hush++hieAstToNames :: GHC.HieAST a -> [GHC.Name]+hieAstToNames =+ identifiersToNames . hieAstNodeToIdentifiers++hieAstsAtPoint :: GHC.HieFile -> HieDbCoords -> Maybe HieDbCoords -> [GHC.HieAST GHC.TypeIndex]+hieAstsAtPoint hiefile start end = pointCommand hiefile start end id++hiedbCoordsToLspPosition :: (Monad m) => HieDbCoords -> ExceptT UIntConversionException m LSP.Position+hiedbCoordsToLspPosition (line, col) = LSP.Position <$> intToUInt (line - 1) <*> intToUInt (col - 1)++lspPositionToHieDbCoords :: LSP.Position -> HieDbCoords+lspPositionToHieDbCoords position = (fromIntegral position._line + 1, fromIntegral position._character + 1)++-- | Use 'fromIntegral' when it is safe to do so+intToUInt :: (Monad m) => Int -> ExceptT UIntConversionException m LSP.UInt+intToUInt x =+ if minBoundAsInt <= x && x <= maxBoundAsInt+ then pure $ fromIntegral x+ else throwE UIntConversionException+ where+ minBoundAsInt = fromIntegral $ minBound @LSP.UInt+ maxBoundAsInt = fromIntegral $ maxBound @LSP.UInt
+ src/StaticLS/HIE/File.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE ScopedTypeVariables #-}++module StaticLS.HIE.File (+ getHieFileFromTdi,+ getHieFile,+ modToHieFile,+ modToSrcFile,+ srcFilePathToHieFilePath,+ hieFilePathToSrcFilePath,+ -- | An alternate way of getting file information by pre-indexing hie files -+ -- far slower on startup and currently unused+ getHieFileMap,+ hieFileMapToSrcMap,+)+where++import Control.Applicative ((<|>))+import Control.Exception (SomeException, catch)+import Control.Monad ((<=<))+import Control.Monad.IO.Unlift (MonadIO, liftIO)+import Control.Monad.Trans.Except (ExceptT (..))+import Control.Monad.Trans.Maybe (MaybeT (..), exceptToMaybeT, runMaybeT)+import Data.Bifunctor (first, second)+import qualified Data.List as List+import qualified Data.List.Extra as List+import qualified Data.Map as Map+import qualified GHC+import qualified GHC.Iface.Ext.Binary as GHC+import qualified GHC.Iface.Ext.Types as GHC+import GHC.Stack (HasCallStack)+import qualified GHC.Types.Name.Cache as GHC+import qualified HieDb+import qualified Language.LSP.Types as LSP+import StaticLS.HIE.File.Except+import StaticLS.Maybe (flatMaybeT, toAlt)+import StaticLS.StaticEnv+import qualified System.Directory as Dir+import System.FilePath ((-<.>), (</>))++type SrcFilePath = FilePath++-- | Retrieve a hie info from a lsp text document identifier+getHieFileFromTdi :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m GHC.HieFile+getHieFileFromTdi = exceptToMaybeT . getHieFile <=< tdiToHieFilePath++tdiToHieFilePath :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m HieFilePath+tdiToHieFilePath = srcFilePathToHieFilePath <=< (MaybeT . pure . LSP.uriToFilePath . (._uri))++-- | Retrieve an hie file from a module name+modToHieFile :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> MaybeT m GHC.HieFile+modToHieFile = exceptToMaybeT . getHieFile <=< modToHieFilePath++-- | Retrieve a src file from a module name+modToSrcFile :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> MaybeT m SrcFilePath+modToSrcFile = hieFilePathToSrcFilePath <=< modToHieFilePath++{- | Fetch a src file from an hie file, checking hiedb but falling back on a file manipulation method+if not indexed+-}+srcFilePathToHieFilePath :: (HasStaticEnv m, MonadIO m) => SrcFilePath -> MaybeT m HieFilePath+srcFilePathToHieFilePath srcPath =+ srcFilePathToHieFilePathHieDb srcPath+ <|> srcFilePathToHieFilePathFromFile srcPath++-- | Fetch an hie file from a src file+hieFilePathToSrcFilePath :: (HasStaticEnv m, MonadIO m) => HieFilePath -> MaybeT m SrcFilePath+hieFilePathToSrcFilePath = hieFilePathToSrcFilePathFromFile++-----------------------------------------------------------------------------------+-- Primitive functions for looking up hie information+-----------------------------------------------------------------------------------++-- | Retrieve an hie file from a hie filepath+getHieFile :: (HasCallStack, HasStaticEnv m, MonadIO m) => HieFilePath -> ExceptT HieFileReadException m GHC.HieFile+getHieFile hieFilePath = do+ staticEnv <- getStaticEnv+ -- Attempt to read any hie file version+ -- TODO: specify supported versions to read?+ result <-+ liftIO+ ( fmap+ (first HieFileVersionException)+ (GHC.readHieFileWithVersion (const True) staticEnv.nameCache hieFilePath)+ `catch` (\(_ :: SomeException) -> pure . Left $ HieFileReadException)+ )+ ExceptT $ pure (second GHC.hie_file_result result)++-----------------------------------------------------------------------------------+-- HieDb Method of file lookups - requires hiedb to be indexed using --src-base-dirs from 0.4.4.0+-----------------------------------------------------------------------------------++srcFilePathToHieFilePathHieDb :: (HasStaticEnv m, MonadIO m) => SrcFilePath -> MaybeT m HieFilePath+srcFilePathToHieFilePathHieDb srcPath = do+ absSrcPath <- liftIO $ Dir.makeAbsolute srcPath+ Just hieModRow <- runHieDbMaybeT $ \hieDb -> do+ HieDb.lookupHieFileFromSource hieDb absSrcPath+ pure $ HieDb.hieModuleHieFile hieModRow++modToHieFilePath :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> MaybeT m HieFilePath+modToHieFilePath modName =+ flatMaybeT $ runHieDbMaybeT $ \hieDb ->+ runMaybeT $ do+ Right unitId <- liftIO (HieDb.resolveUnitId hieDb modName)+ Just hieModRow <- liftIO $ HieDb.lookupHieFile hieDb modName unitId+ pure $ hieModRow.hieModuleHieFile++-----------------------------------------------------------------------------------+-- File/Directory method for getting hie files - faster but somewhat "hacky"+-- Useful as a fallback+-----------------------------------------------------------------------------------++-- TODO: make this configurable (use cabal?)+srcDirs :: [FilePath]+srcDirs = ["src/", "lib/", "app/", "test/"]++hieFilePathToSrcFilePathFromFile :: (HasStaticEnv m, MonadIO m) => HieFilePath -> MaybeT m SrcFilePath+hieFilePathToSrcFilePathFromFile hiePath = do+ hieFile <- exceptToMaybeT $ getHieFile hiePath+ liftIO $ Dir.makeAbsolute hieFile.hie_hs_file++{- | Retrieve a hie file path from a src path++Substitutes the src directory with the hie directory and the src file extension with+the hie file extension. Fragile, but works well in practice.++Presently necessary because hiedb does not currently index the hs_src file location+in the `mods` table+-}+srcFilePathToHieFilePathFromFile :: (HasStaticEnv m, MonadIO m) => SrcFilePath -> MaybeT m HieFilePath+srcFilePathToHieFilePathFromFile srcPath = do+ staticEnv <- getStaticEnv+ absoluteRoot <- liftIO $ Dir.makeAbsolute staticEnv.wsRoot+ hieDir <- toAlt staticEnv.hieFilesPath+ let absoluteHieDir = absoluteRoot </> hieDir+ absoluteSrcDirs = (absoluteRoot </>) <$> srcDirs+ absoluteSrcPath <- liftIO $ Dir.makeAbsolute srcPath++ -- Drop all src directory prefixes+ let noPrefixSrcPath =+ List.foldl' (flip List.dropPrefix) absoluteSrcPath absoluteSrcDirs+ -- Set the hie directory path and substitute the file extension+ hiePath = absoluteHieDir </> noPrefixSrcPath -<.> ".hie"+ True <- liftIO $ Dir.doesFileExist hiePath+ pure hiePath++-----------------------------------------------------------------------------------+-- Map index method for getting hie files - too slow in practice on startup but makes+-- finding references for functions that are used a lot much faster+-----------------------------------------------------------------------------------+data HieInfo = HieInfo+ { hieFilePath :: HieFilePath+ , hieFile :: GHC.HieFile+ }++getHieFileMap :: FilePath -> HieFilePath -> IO (Map.Map SrcFilePath HieInfo)+getHieFileMap wsroot hieDir = do+ let hieFullPath = wsroot </> hieDir+ hieFilePaths <- HieDb.getHieFilesIn hieFullPath+ nameCache <- GHC.initNameCache 'a' []+ srcPathHieInfoPairs <- mapM (srcFileToHieFileInfo nameCache) hieFilePaths++ pure $ Map.fromList srcPathHieInfoPairs+ where+ srcFileToHieFileInfo :: GHC.NameCache -> HieFilePath -> IO (SrcFilePath, HieInfo)+ srcFileToHieFileInfo nameCache hieFilePath = do+ hieFileResult <- GHC.readHieFile nameCache hieFilePath+ absSrcFilePath <- Dir.makeAbsolute hieFileResult.hie_file_result.hie_hs_file+ absHieFilePath <- Dir.makeAbsolute hieFilePath+ let hieInfo =+ HieInfo+ { hieFilePath = absHieFilePath+ , hieFile = hieFileResult.hie_file_result+ }+ pure (absSrcFilePath, hieInfo)++hieFileMapToSrcMap :: Map.Map SrcFilePath HieInfo -> Map.Map HieFilePath SrcFilePath+hieFileMapToSrcMap =+ Map.fromList . fmap (\(srcPath, hieInfo) -> (hieInfo.hieFilePath, srcPath)) . Map.toList
+ src/StaticLS/HIE/File/Except.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DerivingStrategies #-}++module StaticLS.HIE.File.Except where++import Control.Exception+import qualified GHC.Iface.Ext.Binary as GHC++data HieFileReadException+ = HieFileReadException+ | HieFileVersionException GHC.HieHeader+ deriving stock (Show)++instance Exception HieFileReadException
+ src/StaticLS/IDE/Definition.hs view
@@ -0,0 +1,125 @@+module StaticLS.IDE.Definition (getDefinition)+where++import Control.Monad (guard, join)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.List (isSuffixOf)+import Data.Maybe (fromMaybe, maybeToList)+import Development.IDE.GHC.Error (+ srcSpanToFilename,+ srcSpanToRange,+ )+import qualified GHC.Data.FastString as GHC+import qualified GHC.Iface.Ext.Types as GHC+import qualified GHC.Plugins as GHC+import GHC.Stack (HasCallStack)+import GHC.Utils.Monad (mapMaybeM)+import qualified HieDb+import qualified Language.LSP.Types as LSP+import StaticLS.Except+import StaticLS.HIE+import StaticLS.HIE.File+import StaticLS.Maybe+import StaticLS.StaticEnv+import System.Directory (doesFileExist)+import System.FilePath ((</>))++getDefinition ::+ (HasCallStack, HasStaticEnv m, MonadIO m) =>+ LSP.TextDocumentIdentifier ->+ LSP.Position ->+ m [LSP.Location]+getDefinition tdi pos = do+ mLocs <- runMaybeT $ do+ hieFile <- getHieFileFromTdi tdi+ let identifiersAtPoint =+ join $+ HieDb.pointCommand+ hieFile+ (lspPositionToHieDbCoords pos)+ Nothing+ hieAstNodeToIdentifiers+ join <$> mapM (lift . identifierToLocation) identifiersAtPoint+ pure $ fromMaybe [] mLocs+ where+ identifierToLocation :: (HasStaticEnv m, MonadIO m) => GHC.Identifier -> m [LSP.Location]+ identifierToLocation =+ either+ (fmap maybeToList . modToLocation)+ nameToLocation++ modToLocation :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> m (Maybe LSP.Location)+ modToLocation modName =+ let zeroPos = LSP.Position 0 0+ zeroRange = LSP.Range zeroPos zeroPos+ in runMaybeT $ do+ srcFile <- modToSrcFile modName+ pure $ LSP.Location (LSP.filePathToUri srcFile) zeroRange++---------------------------------------------------------------------+-- The following code is largely taken from ghcide with slight modifications+-- to use the HasStaticEnv monad instead of the module map that ghcide indexes+-- See: https://hackage.haskell.org/package/ghcide-1.10.0.0/docs/src/Development.IDE.Spans.AtPoint.html+-- for the original code+---------------------------------------------------------------------++{- | Given a 'Name' attempt to find the location where it is defined.+See: https://hackage.haskell.org/package/ghcide-1.10.0.0/docs/src/Development.IDE.Spans.AtPoint.html#nameToLocation+for original code+-}+nameToLocation :: (HasCallStack, HasStaticEnv m, MonadIO m) => GHC.Name -> m [LSP.Location]+nameToLocation name = fmap (fromMaybe []) <$> runMaybeT $+ case GHC.nameSrcSpan name of+ sp@(GHC.RealSrcSpan rsp _)+ -- Lookup in the db if we got a location in a boot file+ | fs <- GHC.unpackFS (GHC.srcSpanFile rsp)+ , not $ "boot" `isSuffixOf` fs ->+ do+ itExists <- liftIO $ doesFileExist fs+ if itExists+ then MaybeT $ pure . maybeToList <$> (runMaybeT . srcSpanToLocation) sp+ else -- When reusing .hie files from a cloud cache,+ -- the paths may not match the local file system.+ -- Let's fall back to the hiedb in case it contains local paths+ fallbackToDb sp+ sp -> fallbackToDb sp+ where+ fallbackToDb :: (HasCallStack, HasStaticEnv m, MonadIO m) => GHC.SrcSpan -> MaybeT m [LSP.Location]+ fallbackToDb sp = do+ guard (sp /= GHC.wiredInSrcSpan)+ -- This case usually arises when the definition is in an external package.+ -- In this case the interface files contain garbage source spans+ -- so we instead read the .hie files to get useful source spans.+ mod' <- MaybeT $ return $ GHC.nameModule_maybe name+ erow <- runHieDbMaybeT (\hieDb -> HieDb.findDef hieDb (GHC.nameOccName name) (Just $ GHC.moduleName mod') (Just $ GHC.moduleUnit mod'))+ case erow of+ [] -> do+ -- If the lookup failed, try again without specifying a unit-id.+ -- This is a hack to make find definition work better with ghcide's nascent multi-component support,+ -- where names from a component that has been indexed in a previous session but not loaded in this+ -- session may end up with different unit ids+ erow' <- runHieDbMaybeT (\hieDb -> HieDb.findDef hieDb (GHC.nameOccName name) (Just $ GHC.moduleName mod') Nothing)+ case erow' of+ [] -> MaybeT $ pure Nothing+ xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation) xs+ xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation) xs++srcSpanToLocation :: (HasCallStack, HasStaticEnv m) => GHC.SrcSpan -> MaybeT m LSP.Location+srcSpanToLocation src = do+ staticEnv <- lift getStaticEnv+ fs <- toAlt $ (staticEnv.wsRoot </>) <$> srcSpanToFilename src+ rng <- toAlt $ srcSpanToRange src+ -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code+ pure $ LSP.Location (LSP.fromNormalizedUri $ LSP.normalizedFilePathToUri $ LSP.toNormalizedFilePath fs) rng++defRowToLocation :: (HasCallStack, HasStaticEnv m, MonadIO m) => HieDb.Res HieDb.DefRow -> MaybeT m LSP.Location+defRowToLocation (defRow HieDb.:. _) = do+ let start = exceptToMaybe $ hiedbCoordsToLspPosition (defRow.defSLine, defRow.defSCol)+ end = exceptToMaybe $ hiedbCoordsToLspPosition (defRow.defELine, defRow.defECol)+ range = LSP.Range <$> start <*> end+ hieFilePath = defRow.defSrc+ file <- hieFilePathToSrcFilePath hieFilePath+ let lspUri = LSP.filePathToUri file+ MaybeT . pure $ LSP.Location lspUri <$> range
+ src/StaticLS/IDE/Hover.hs view
@@ -0,0 +1,48 @@+module StaticLS.IDE.Hover (+ retrieveHover,+)+where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Maybe (listToMaybe)+import Data.Text (Text, intercalate)+import qualified GHC.Iface.Ext.Types as GHC+import GHC.Stack (HasCallStack)+import HieDb (pointCommand)+import Language.LSP.Types (+ Hover (..),+ HoverContents (..),+ MarkupContent (..),+ MarkupKind (..),+ Position,+ Range (..),+ TextDocumentIdentifier,+ sectionSeparator,+ )+import StaticLS.HIE+import StaticLS.HIE.File+import StaticLS.IDE.Hover.Info+import StaticLS.Maybe+import StaticLS.StaticEnv++-- | Retrive hover information. Incomplete+retrieveHover :: (HasCallStack, HasStaticEnv m, MonadIO m) => TextDocumentIdentifier -> Position -> m (Maybe Hover)+retrieveHover identifier position = do+ runMaybeT $ do+ hieFile <- getHieFileFromTdi identifier+ let info =+ listToMaybe $+ pointCommand+ hieFile+ (lspPositionToHieDbCoords position)+ Nothing+ (hoverInfo (GHC.hie_types hieFile))+ toAlt $ hoverInfoToHover <$> info+ where+ hoverInfoToHover :: (Maybe Range, [Text]) -> Hover+ hoverInfoToHover (mRange, contents) =+ Hover+ { _range = mRange+ , _contents = HoverContents $ MarkupContent MkMarkdown $ intercalate sectionSeparator contents+ }
+ src/StaticLS/IDE/Hover/Info.hs view
@@ -0,0 +1,68 @@+module StaticLS.IDE.Hover.Info (hoverInfo) where++import Data.Array+import Data.List.Extra (dropEnd1)+import qualified Data.Map as M+import qualified Data.Text as T+import Development.IDE.GHC.Error (realSrcSpanToRange)+import GHC+import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Utils+import GHC.Plugins hiding ((<>))+import Language.LSP.Types++-------------------------------------------------------------------+-- The following code is taken from halfsp+-- See: https://github.com/masaeedu/halfsp/blob/master/lib/GhcideSteal.hs+-- for the original source+-------------------------------------------------------------------+hoverInfo :: Array TypeIndex HieTypeFlat -> HieAST TypeIndex -> (Maybe Range, [T.Text])+hoverInfo typeLookup ast = (Just spanRange, map prettyName names ++ pTypes)+ where+ pTypes+ | [_] <- names = dropEnd1 $ map wrapHaskell prettyTypes+ | otherwise = map wrapHaskell prettyTypes++ spanRange = realSrcSpanToRange $ nodeSpan ast++ wrapHaskell x = "\n```haskell\n" <> x <> "\n```\n"+ info = sourcedNodeInfo ast+ names = M.assocs $ sourcedNodeIdents info+ types = concatMap nodeType (M.elems $ getSourcedNodeInfo info)++ prettyName :: (Identifier, IdentifierDetails TypeIndex) -> T.Text+ prettyName (Right n, dets) =+ T.unlines $+ wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets))+ : definedAt n+ prettyName (Left m, _) = showGhc m++ prettyTypes = map (("_ :: " <>) . prettyType) types++ prettyType t = showGhc $ hieTypeToIface $ recoverFullType t typeLookup++ definedAt name =+ -- do not show "at <no location info>" and similar messages+ -- see the code of 'pprNameDefnLoc' for more information+ case nameSrcLoc name of+ UnhelpfulLoc{} | isInternalName name || isSystemName name -> []+ _ -> ["*Defined " <> showSD (pprNameDefnLoc name) <> "*"]++showGhc :: (Outputable a) => a -> T.Text+showGhc = showSD . ppr++showSD :: SDoc -> T.Text+showSD = T.pack . printSDocSimple++printSDocSimple :: SDoc -> String+printSDocSimple = renderWithContext sdocContext+ where+ sdocContext = pprStyleToSDocContext $ mkUserStyle neverQualify AllTheWay++pprStyleToSDocContext :: PprStyle -> SDocContext+pprStyleToSDocContext pprStyle = defaultSDocContext{sdocStyle = pprStyle}++showNameWithoutUniques :: (Outputable a) => a -> T.Text+showNameWithoutUniques outputable = T.pack $ renderWithContext sdocContext (ppr outputable)+ where+ sdocContext = pprStyleToSDocContext $ mkUserStyle neverQualify AllTheWay
+ src/StaticLS/IDE/References.hs view
@@ -0,0 +1,52 @@+module StaticLS.IDE.References (findRefs) where++import Control.Monad (join)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Maybe (catMaybes, fromMaybe)+import qualified GHC.Plugins as GHC+import qualified HieDb+import qualified Language.LSP.Types as LSP+import StaticLS.Except+import StaticLS.HIE+import StaticLS.HIE.File+import StaticLS.Maybe+import StaticLS.StaticEnv++findRefs :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> LSP.Position -> m [LSP.Location]+findRefs tdi position = do+ mLocList <- runMaybeT $ do+ hieFile <- getHieFileFromTdi tdi+ let identifiersAtPoint =+ join+ ( HieDb.pointCommand+ hieFile+ (lspPositionToHieDbCoords position)+ Nothing+ hieAstNodeToIdentifiers+ )+ namesAtPoint = identifiersToNames identifiersAtPoint+ occNamesAndModNamesAtPoint =+ (\name -> (GHC.occName name, fmap GHC.moduleName . GHC.nameModule_maybe $ name))+ <$> namesAtPoint+ refResRows <-+ lift $ fmap (fromMaybe []) $ runMaybeT $ runHieDbMaybeT $ \hieDb -> do+ join+ <$> mapM+ ( \(occ, mModName) -> do+ HieDb.findReferences hieDb False occ mModName Nothing []+ )+ occNamesAndModNamesAtPoint+ lift $ catMaybes <$> mapM (runMaybeT . refRowToLocation) refResRows+ pure $ fromMaybe [] mLocList++refRowToLocation :: (HasStaticEnv m, MonadIO m) => HieDb.Res HieDb.RefRow -> MaybeT m LSP.Location+refRowToLocation (refRow HieDb.:. _) = do+ let start = exceptToMaybe $ hiedbCoordsToLspPosition (refRow.refSLine, refRow.refSCol)+ end = exceptToMaybe $ hiedbCoordsToLspPosition (refRow.refELine, refRow.refECol)+ range = LSP.Range <$> start <*> end+ hieFilePath = refRow.refSrc+ file <- hieFilePathToSrcFilePath hieFilePath+ let lspUri = LSP.fromNormalizedUri . LSP.normalizedFilePathToUri . LSP.toNormalizedFilePath $ file+ toAlt $ LSP.Location lspUri <$> range
+ src/StaticLS/Maybe.hs view
@@ -0,0 +1,19 @@+module StaticLS.Maybe where++import Control.Applicative+import Control.Error.Util (maybeT)+import Control.Monad+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Control.Monad.Trans.Maybe++flatMaybeT :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a+flatMaybeT = MaybeT . fmap join . runMaybeT++toAlt :: (Functor f, Foldable f, Alternative g) => f a -> g a+toAlt as = asum (fmap pure as)++orDie :: (Monad m) => Maybe a -> e -> ExceptT e m a+x `orDie` e = maybe (throwE e) pure x++orDieT :: (Monad m) => MaybeT m a -> e -> ExceptT e m a+x `orDieT` e = ExceptT $ maybeT (pure . Left $ e) (pure . Right) x
+ src/StaticLS/Server.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}++module StaticLS.Server where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Language.LSP.Server (+ Handlers,+ LanguageContextEnv,+ LspT,+ ServerDefinition (..),+ type (<~>) (Iso),+ )+import qualified Language.LSP.Server as LSP+import Language.LSP.Types+import StaticLS.IDE.Definition+import StaticLS.IDE.Hover+import StaticLS.IDE.References+import StaticLS.StaticEnv+import StaticLS.StaticEnv.Options++data LspEnv config = LspEnv+ { staticEnv :: StaticEnv+ , config :: LanguageContextEnv config+ }++handleChangeConfiguration :: Handlers (LspT c StaticLs)+handleChangeConfiguration = LSP.notificationHandler SWorkspaceDidChangeConfiguration $ pure $ pure ()++handleInitialized :: Handlers (LspT c StaticLs)+handleInitialized = LSP.notificationHandler SInitialized $ pure $ pure ()++handleTextDocumentHoverRequest :: Handlers (LspT c StaticLs)+handleTextDocumentHoverRequest = LSP.requestHandler STextDocumentHover $ \req resp -> do+ let hoverParams = req._params+ hover <- lift $ retrieveHover hoverParams._textDocument hoverParams._position+ resp (Right hover)++handleDefinitionRequest :: Handlers (LspT c StaticLs)+handleDefinitionRequest = LSP.requestHandler STextDocumentDefinition $ \req res -> do+ let defParams = req._params+ defs <- lift $ getDefinition defParams._textDocument defParams._position+ res $ Right . InR . InL . List $ defs++handleReferencesRequest :: Handlers (LspT c StaticLs)+handleReferencesRequest = LSP.requestHandler STextDocumentReferences $ \req res -> do+ let refParams = req._params+ refs <- lift $ findRefs refParams._textDocument refParams._position+ res $ Right . List $ refs++handleCancelNotification :: Handlers (LspT c StaticLs)+handleCancelNotification = LSP.notificationHandler SCancelRequest $ \_ -> pure ()++handleDidOpen :: Handlers (LspT c StaticLs)+handleDidOpen = LSP.notificationHandler STextDocumentDidOpen $ \_ -> pure ()++handleDidChange :: Handlers (LspT c StaticLs)+handleDidChange = LSP.notificationHandler STextDocumentDidChange $ \_ -> pure ()++handleDidClose :: Handlers (LspT c StaticLs)+handleDidClose = LSP.notificationHandler STextDocumentDidClose $ \_ -> pure ()++handleDidSave :: Handlers (LspT c StaticLs)+handleDidSave = LSP.notificationHandler STextDocumentDidSave $ \_ -> pure ()++initServer :: LanguageContextEnv config -> Message 'Initialize -> IO (Either ResponseError (LspEnv config))+initServer serverConfig _ = do+ runExceptT $ do+ wsRoot <- ExceptT $ LSP.runLspT serverConfig getWsRoot+ serverStaticEnv <- ExceptT $ Right <$> initStaticEnv wsRoot defaultStaticEnvOptions+ pure $+ LspEnv+ { staticEnv = serverStaticEnv+ , config = serverConfig+ }+ where+ getWsRoot :: LSP.LspM config (Either ResponseError FilePath)+ getWsRoot = do+ mRootPath <- LSP.getRootPath+ pure $ case mRootPath of+ Nothing -> Left $ ResponseError InvalidRequest "No root workspace was found" Nothing+ Just p -> Right p++serverDef :: ServerDefinition ()+serverDef =+ ServerDefinition+ { onConfigurationChange = \conf _ -> Right conf+ , doInitialize = initServer+ , staticHandlers =+ mconcat+ [ handleInitialized+ , handleChangeConfiguration+ , handleTextDocumentHoverRequest+ , handleDefinitionRequest+ , handleReferencesRequest+ , handleCancelNotification+ , handleDidOpen+ , handleDidChange+ , handleDidClose+ , handleDidSave+ ]+ , interpretHandler = \env -> Iso (runStaticLs env.staticEnv . LSP.runLspT env.config) liftIO+ , options = LSP.defaultOptions+ , defaultConfig = ()+ }++runServer :: IO Int+runServer = do+ LSP.runServer serverDef
+ src/StaticLS/StaticEnv.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++module StaticLS.StaticEnv (+ initStaticEnv,+ runStaticLs,+ getStaticEnv,+ runHieDbExceptT,+ runHieDbMaybeT,+ StaticEnv (..),+ StaticLs,+ HieDbPath,+ HieFilePath,+ HasStaticEnv,+)+where++import Control.Exception (Exception, IOException, SomeException, catch)+import Control.Monad.IO.Unlift (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader (..))+import Control.Monad.Trans.Except (ExceptT (..))+import Control.Monad.Trans.Maybe (MaybeT (..), exceptToMaybeT)+import Control.Monad.Trans.Reader (ReaderT (..))+import Database.SQLite.Simple (SQLError)+import qualified GHC+import qualified GHC.Paths as GHC+import qualified GHC.Types.Name.Cache as GHC+import qualified HieDb+import StaticLS.StaticEnv.Options (StaticEnvOptions (..))+import System.FilePath ((</>))++runStaticLs :: StaticEnv -> StaticLs a -> IO a+runStaticLs = flip runReaderT++type HieDbPath = FilePath+type HieFilePath = FilePath++data HieDbException+ = HieDbIOException IOException+ | HieDbSqlException SQLError+ | HieDbNoHieDbSourceException+ | HieDbOtherException+ deriving (Show)++instance Exception HieDbException++-- | Static environment used to fetch data+data StaticEnv = StaticEnv+ { hieDbPath :: Maybe HieDbPath+ -- ^ Path to the hiedb file+ , hieFilesPath :: Maybe HieFilePath+ , hscEnv :: GHC.HscEnv+ -- ^ static ghc compiler environment+ , nameCache :: GHC.NameCache+ -- ^ name cache - used for reading hie files+ , wsRoot :: FilePath+ -- ^ workspace root+ }++type StaticLs = ReaderT StaticEnv IO++type HasStaticEnv = MonadReader StaticEnv++getStaticEnv :: (HasStaticEnv m) => m StaticEnv+getStaticEnv = ask++initStaticEnv :: FilePath -> StaticEnvOptions -> IO StaticEnv+initStaticEnv wsRoot staticEnvOptions =+ do+ let databasePath = fmap (wsRoot </>) staticEnvOptions.optionHieDbPath+ hieFilesPath = fmap (wsRoot </>) staticEnvOptions.optionHieFilesPath+ -- TODO: find out if this is safe to do or if we should just use GhcT+ hscEnv <- GHC.runGhc (Just GHC.libdir) GHC.getSession+ -- TODO: not sure what the first parameter to name cache is - find out+ nameCache <- GHC.initNameCache 'a' []++ let serverStaticEnv =+ StaticEnv+ { hieDbPath = databasePath+ , hieFilesPath = hieFilesPath+ , hscEnv = hscEnv+ , nameCache = nameCache+ , wsRoot = wsRoot+ }+ pure serverStaticEnv++-- | Run an hiedb action in an exceptT+runHieDbExceptT :: (HasStaticEnv m, MonadIO m) => (HieDb.HieDb -> IO a) -> ExceptT HieDbException m a+runHieDbExceptT hieDbFn =+ getStaticEnv+ >>= \staticEnv ->+ maybe+ (ExceptT . pure . Left $ HieDbNoHieDbSourceException)+ ( \hiedbPath ->+ ExceptT . liftIO $+ HieDb.withHieDb hiedbPath (fmap Right . hieDbFn)+ `catch` (pure . Left . HieDbIOException)+ `catch` (pure . Left . HieDbSqlException)+ `catch` (\(_ :: SomeException) -> pure . Left $ HieDbOtherException)+ )+ staticEnv.hieDbPath++-- | Run an hiedb action with the MaybeT Monad+runHieDbMaybeT :: (HasStaticEnv m, MonadIO m) => (HieDb.HieDb -> IO a) -> MaybeT m a+runHieDbMaybeT = exceptToMaybeT . runHieDbExceptT
+ src/StaticLS/StaticEnv/Options.hs view
@@ -0,0 +1,21 @@+module StaticLS.StaticEnv.Options (+ defaultStaticEnvOptions,+ StaticEnvOptions (..),+)+where++data StaticEnvOptions = StaticEnvOptions+ { optionHieDbPath :: Maybe FilePath+ -- ^ Relative path to hiedb file+ -- hiedb is required for find references and go to definition to work correctly+ , optionHieFilesPath :: Maybe FilePath+ -- ^ Relative path to hie files directory+ -- hie files are required for all functionality+ }++defaultStaticEnvOptions :: StaticEnvOptions+defaultStaticEnvOptions =+ StaticEnvOptions+ { optionHieDbPath = Just ".hiedb"+ , optionHieFilesPath = Just ".hiefiles"+ }
+ static-ls.cabal view
@@ -0,0 +1,164 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name: static-ls+version: 0.1.0+synopsis: See README on Github for more information+description: static-ls ("static language server") reads static project information to provide IDE functionality through the language server protocol. static-ls will not generate this information on its own and instead will rely on the user to generate this information via separate programs+category: Development+homepage: https://github.com/josephsumabat/static-ls#readme+bug-reports: https://github.com/josephsumabat/static-ls/issues+author: Joseph Sumabat+maintainer: josephrsumabat@gmail.com+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/josephsumabat/static-ls++flag dev+ description: Defer type errors for development+ manual: True+ default: False++library+ exposed-modules:+ StaticLS.Except+ StaticLS.HIE+ StaticLS.HIE.File+ StaticLS.HIE.File.Except+ StaticLS.IDE.Definition+ StaticLS.IDE.Hover+ StaticLS.IDE.Hover.Info+ StaticLS.IDE.References+ StaticLS.Maybe+ StaticLS.Server+ StaticLS.StaticEnv+ StaticLS.StaticEnv.Options+ other-modules:+ Paths_static_ls+ hs-source-dirs:+ src+ default-extensions:+ FlexibleContexts+ OverloadedRecordDot+ OverloadedStrings+ NoFieldSelectors+ LambdaCase+ ghc-options: -fwrite-ide-info -hiedir test/TestData/.hiefiles+ build-depends:+ array >=0.5.4 && <0.6+ , base >=4.17.0 && <4.19+ , containers >=0.6.0 && <0.7+ , directory >=1.3.7 && <1.4+ , errors >=2.3.0 && <2.4+ , extra >=1.7.12 && <1.8+ , filepath >=1.4.1 && <1.5+ , ghc >=9.4.4 && <9.7+ , ghc-paths >=0.1.0 && <0.2+ , ghcide >=1.9.1 && <1.11+ , hiedb >=0.4.2 && <0.5+ , lsp >=1.6.0 && <1.7+ , lsp-types >=1.6.0 && <1.7+ , mtl >=2.2.2 && <2.4+ , sqlite-simple >=0.4.18 && <0.5+ , template-haskell >=2.19.0 && <2.21+ , text >=2.0.1 && <2.1+ , transformers >=0.5.6.2 && <0.7+ , unliftio-core >=0.2.1 && <0.3+ default-language: Haskell2010+ if flag(dev)+ ghc-options: -fwrite-ide-info -hiedir .hiefiles -fdefer-type-errors -fno-defer-typed-holes -Werror=deferred-type-errors -Werror=deferred-out-of-scope-variables++executable static-ls+ main-is: Main.hs+ other-modules:+ Paths_static_ls+ hs-source-dirs:+ app+ default-extensions:+ FlexibleContexts+ OverloadedRecordDot+ OverloadedStrings+ NoFieldSelectors+ LambdaCase+ build-depends:+ array >=0.5.4 && <0.6+ , base >=4.17.0 && <4.19+ , containers >=0.6.0 && <0.7+ , directory >=1.3.7 && <1.4+ , errors >=2.3.0 && <2.4+ , extra >=1.7.12 && <1.8+ , filepath >=1.4.1 && <1.5+ , ghc >=9.4.4 && <9.7+ , ghc-paths >=0.1.0 && <0.2+ , ghcide >=1.9.1 && <1.11+ , hiedb >=0.4.2 && <0.5+ , lsp >=1.6.0 && <1.7+ , lsp-types >=1.6.0 && <1.7+ , mtl >=2.2.2 && <2.4+ , sqlite-simple >=0.4.18 && <0.5+ , static-ls+ , template-haskell >=2.19.0 && <2.21+ , text >=2.0.1 && <2.1+ , transformers >=0.5.6.2 && <0.7+ , unliftio-core >=0.2.1 && <0.3+ default-language: Haskell2010+ if flag(dev)+ ghc-options: -fwrite-ide-info -hiedir .hiefiles -fdefer-type-errors -fno-defer-typed-holes -Werror=deferred-type-errors -Werror=deferred-out-of-scope-variables++test-suite static-ls-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ StaticLS.HIE.FileSpec+ StaticLS.IDE.DefinitionSpec+ StaticLS.IDE.HoverSpec+ TestData.Mod1+ TestData.Mod2+ TestImport+ TestImport.Assert+ TestImport.TestData+ Paths_static_ls+ hs-source-dirs:+ test+ default-extensions:+ FlexibleContexts+ OverloadedRecordDot+ OverloadedStrings+ NoFieldSelectors+ LambdaCase+ ghc-options: -fwrite-ide-info -hiedir test/TestData/.hiefiles+ build-tool-depends: hspec-discover:hspec-discover == 2.*+ build-depends:+ array >=0.5.4 && <0.6+ , base >=4.17.0 && <4.19+ , containers >=0.6.0 && <0.7+ , directory >=1.3.7 && <1.4+ , errors >=2.3.0 && <2.4+ , extra >=1.7.12 && <1.8+ , filepath >=1.4.1 && <1.5+ , ghc >=9.4.4 && <9.7+ , ghc-paths >=0.1.0 && <0.2+ , ghcide >=1.9.1 && <1.11+ , hiedb >=0.4.2 && <0.5+ , hspec ==2.*+ , lsp >=1.6.0 && <1.7+ , lsp-types >=1.6.0 && <1.7+ , mtl >=2.2.2 && <2.4+ , sqlite-simple >=0.4.18 && <0.5+ , static-ls+ , template-haskell >=2.19.0 && <2.21+ , text >=2.0.1 && <2.1+ , transformers >=0.5.6.2 && <0.7+ , unliftio-core >=0.2.1 && <0.3+ default-language: Haskell2010+ if flag(dev)+ ghc-options: -fwrite-ide-info -hiedir .hiefiles -fdefer-type-errors -fno-defer-typed-holes -Werror=deferred-type-errors -Werror=deferred-out-of-scope-variables
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- file test/Spec.hs+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/StaticLS/HIE/FileSpec.hs view
@@ -0,0 +1,78 @@+module StaticLS.HIE.FileSpec (spec) where++import Control.Monad.Trans.Except (runExceptT)+import Control.Monad.Trans.Maybe (runMaybeT)+import StaticLS.HIE.File+import StaticLS.StaticEnv+import StaticLS.StaticEnv.Options+import System.Directory+import System.FilePath+import Test.Hspec+import qualified TestImport as Test+import qualified TestImport.Assert as Test++spec :: Spec+spec = do+ describe "Can convert from src to hie file" $ do+ describe "src file to hie file" $ do+ it "returns a valid hie file when called on a src file" $ do+ staticEnv <- Test.initStaticEnv+ hieFile <-+ runStaticLs staticEnv $+ runMaybeT $+ srcFilePathToHieFilePath "src/StaticLS/HIE/File.hs"+ let relativeHieFile = makeRelative staticEnv.wsRoot <$> hieFile+ hieFileExists <- maybe (pure False) doesFileExist relativeHieFile++ relativeHieFile `shouldBe` Just "test/TestData/.hiefiles/StaticLS/HIE/File.hie"+ hieFileExists `shouldBe` True++ it "returns a valid hie file when called on a test/ file" $ do+ staticEnv <- Test.initStaticEnv+ hieFile <-+ runStaticLs staticEnv $+ runMaybeT $+ srcFilePathToHieFilePath "test/TestData/Mod1.hs"+ let relativeHieFile = makeRelative staticEnv.wsRoot <$> hieFile+ hieFileExists <- maybe (pure False) doesFileExist relativeHieFile++ relativeHieFile `shouldBe` Just "test/TestData/.hiefiles/TestData/Mod1.hie"+ hieFileExists `shouldBe` True++ describe "getHieFile" $ do+ it "Returns a valid hie file" $ do+ staticEnv <- Test.initStaticEnv+ hieFile <-+ runStaticLs staticEnv $+ runExceptT $+ getHieFile "test/TestData/.hiefiles/TestData/Mod1.hie"+ _ <- Test.assertRight "expected succesful read" hieFile+ pure ()++ it "Does not crash when given an invalid hie file to read " $ do+ let emptyOpts =+ StaticEnvOptions+ { optionHieDbPath = Nothing+ , optionHieFilesPath = Nothing+ }+ staticEnv <- Test.initStaticEnvOpts emptyOpts+ hieFile <-+ runStaticLs staticEnv $+ runExceptT $+ getHieFile "./test/TestData/Mod1.hs"+ _ <- Test.assertLeft "expected failure" hieFile+ pure ()++ it "Does not crash when given no file to read" $ do+ let emptyOpts =+ StaticEnvOptions+ { optionHieDbPath = Nothing+ , optionHieFilesPath = Nothing+ }+ staticEnv <- Test.initStaticEnvOpts emptyOpts+ hieFile <-+ runStaticLs staticEnv $+ runExceptT $+ getHieFile ""+ _ <- Test.assertLeft "expected failure" hieFile+ pure ()
+ test/StaticLS/IDE/DefinitionSpec.hs view
@@ -0,0 +1,56 @@+module StaticLS.IDE.DefinitionSpec (spec) where++import StaticLS.IDE.Definition+import StaticLS.StaticEnv+import StaticLS.StaticEnv.Options+import Test.Hspec+import qualified TestImport as Test+import qualified TestImport.Assert as Test+import qualified TestImport.TestData as Test++spec :: Spec+spec =+ describe "Correctly retrieves definitions" $ do+ describe "All available sources" $ do+ it "retrieves the myFun definition from a different module" $ do+ staticEnv <- Test.initStaticEnv+ locs <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition+ defnLoc <- Test.assertHead "no definition loc found" locs+ expectedLoc <- Test.myFunDefLocation+ defnLoc `shouldBe` expectedLoc++ describe "Missing sources" $ do+ describe "Finding sources with only hie files" $ do+ it "Missing hiedb" $ do+ let emptyOpts =+ StaticEnvOptions+ { optionHieDbPath = Nothing+ , optionHieFilesPath = Just "test/TestData/.hiefiles"+ }+ staticEnv <- Test.initStaticEnvOpts emptyOpts+ locs <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition+ defnLoc <- Test.assertHead "no definition loc found" locs+ expectedLoc <- Test.myFunDefLocation+ defnLoc `shouldBe` expectedLoc++ it "empty hiedb" $ do+ let emptyOpts =+ StaticEnvOptions+ { optionHieDbPath = Just "./TestData/not-a-real-hiedb-file"+ , optionHieFilesPath = Just "test/TestData/.hiefiles"+ }+ staticEnv <- Test.initStaticEnvOpts emptyOpts+ locs <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition+ defnLoc <- Test.assertHead "no definition loc found" locs+ expectedLoc <- Test.myFunDefLocation+ defnLoc `shouldBe` expectedLoc++ it "does not crash with missing all sources" $ do+ let emptyOpts =+ StaticEnvOptions+ { optionHieDbPath = Nothing+ , optionHieFilesPath = Nothing+ }+ staticEnv <- Test.initStaticEnvOpts emptyOpts+ locs <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition+ locs `shouldBe` []
+ test/StaticLS/IDE/HoverSpec.hs view
@@ -0,0 +1,18 @@+module StaticLS.IDE.HoverSpec where++import StaticLS.IDE.Hover+import StaticLS.StaticEnv+import Test.Hspec+import qualified TestImport as Test+import qualified TestImport.Assert as Test+import qualified TestImport.TestData as Test++spec :: Spec+spec =+ describe "Correctly retrieves hover information" $ do+ describe "All available sources" $ do+ it "retrieves the myFun definition from a different module" $ do+ staticEnv <- Test.initStaticEnv+ mHoverInfo <- runStaticLs staticEnv $ uncurry retrieveHover Test.myFunRef1TdiAndPosition+ _ <- Test.assertJust "no definition loc found" mHoverInfo+ pure ()
+ test/TestData/Mod1.hs view
@@ -0,0 +1,11 @@+module TestData.Mod1 where++import TestData.Mod2++main :: IO ()+main = do+ let _ = myFun 1 3+ print ("hello" :: String)++someDefinition1 :: Int+someDefinition1 = myFun 2 4 -- myFun Position: line 10 char 18
+ test/TestData/Mod2.hs view
@@ -0,0 +1,5 @@+module TestData.Mod2 where++-- | Position line: 3, character: 0+myFun :: Int -> Int -> Int+myFun n m = n + m
+ test/TestImport.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}++module TestImport where++import StaticLS.StaticEnv as StaticEnv+import StaticLS.StaticEnv.Options as StaticEnv+import System.Directory (makeAbsolute)+import System.FilePath ((</>))++initStaticEnv :: IO StaticEnv+initStaticEnv = do+ wsRoot <- makeAbsolute "."+ StaticEnv.initStaticEnv wsRoot defaultTestStaticEnvOptions++#if __GLASGOW_HASKELL__ >= 906+ghcVerDir :: FilePath+ghcVerDir =+ "ghc961/"+#else+ghcVerDir :: FilePath+ghcVerDir =+ "ghc944/"+#endif++testHieDir :: FilePath+testHieDir = "test/TestData/.hiefiles"++defaultTestStaticEnvOptions :: StaticEnvOptions+defaultTestStaticEnvOptions =+ StaticEnvOptions+ { optionHieDbPath = Just ("test/TestData/" </> ghcVerDir </> ".hiedb")+ , optionHieFilesPath = Just testHieDir+ }++initStaticEnvOpts :: StaticEnvOptions -> IO StaticEnv+initStaticEnvOpts options = do+ wsRoot <- makeAbsolute "."+ StaticEnv.initStaticEnv wsRoot options
+ test/TestImport/Assert.hs view
@@ -0,0 +1,30 @@+module TestImport.Assert where++import Data.Maybe (listToMaybe)+import GHC.Stack (HasCallStack)++assertHead :: (HasCallStack, MonadFail m) => String -> [a] -> m a+assertHead msg = maybe (fail $ assertionFailureMsg msg) pure . listToMaybe++assertJust :: (MonadFail m) => String -> Maybe a -> m a+assertJust msg =+ \case+ Just a -> pure a+ Nothing -> fail $ assertionFailureMsg msg++assertLeft :: (MonadFail m) => String -> Either a b -> m a+assertLeft msg =+ \case+ Right _ ->+ fail $ assertionFailureMsg msg+ Left e -> pure e++assertRight :: (MonadFail m) => String -> Either a b -> m b+assertRight msg =+ \case+ Left _ -> fail $ assertionFailureMsg msg+ Right v -> pure v++assertionFailureMsg :: String -> String+assertionFailureMsg msg =+ "An assertion failed with msg: " <> msg
+ test/TestImport/TestData.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DuplicateRecordFields #-}++module TestImport.TestData where++import qualified Language.LSP.Types as LSP+import qualified System.Directory as Dir++myFunDefTdiAndPosition :: (LSP.TextDocumentIdentifier, LSP.Position)+myFunDefTdiAndPosition =+ let pos =+ LSP.Position+ { LSP._line = unsafeIntToUInt 4+ , LSP._character = unsafeIntToUInt 0+ }+ tdi =+ LSP.TextDocumentIdentifier $ LSP.filePathToUri "test/TestData/Mod2.hs"+ in (tdi, pos)++myFunDefLocation :: IO LSP.Location+myFunDefLocation = do+ absDir <- Dir.makeAbsolute "test/TestData/Mod2.hs"+ pure $+ LSP.Location+ { LSP._uri = LSP.filePathToUri absDir+ , LSP._range =+ LSP.Range+ { _start =+ LSP.Position+ { LSP._line = 4+ , LSP._character = 0+ }+ , LSP._end =+ LSP.Position+ { LSP._line = 4+ , LSP._character = 5+ }+ }+ }++myFunRef1TdiAndPosition :: (LSP.TextDocumentIdentifier, LSP.Position)+myFunRef1TdiAndPosition =+ let pos =+ LSP.Position+ { LSP._line = unsafeIntToUInt 10+ , LSP._character = unsafeIntToUInt 18+ }+ tdi =+ LSP.TextDocumentIdentifier $ LSP.filePathToUri "test/TestData/Mod1.hs"+ in (tdi, pos)++unsafeIntToUInt :: Int -> LSP.UInt+unsafeIntToUInt = fromIntegral