static-ls 0.1.0 → 0.1.2
raw patch · 32 files changed
+1151/−230 lines, 32 filesdep +optparse-applicativedep +parsecdep ~ghcdep ~ghcidedep ~lsp
Dependencies added: optparse-applicative, parsec
Dependency ranges changed: ghc, ghcide, lsp, lsp-types
Files
- CHANGELOG.md +21/−1
- LICENSE +16/−1
- README.md +151/−0
- app/App/Arguments.hs +106/−0
- app/Main.hs +3/−1
- src/StaticLS/FilePath.hs +29/−0
- src/StaticLS/HI.hs +91/−0
- src/StaticLS/HI/File.hs +64/−0
- src/StaticLS/HIE.hs +8/−2
- src/StaticLS/HIE/File.hs +26/−32
- src/StaticLS/HieDb.hs +23/−0
- src/StaticLS/IDE/Definition.hs +84/−19
- src/StaticLS/IDE/Hover.hs +20/−8
- src/StaticLS/IDE/Hover/Info.hs +21/−31
- src/StaticLS/IDE/References.hs +4/−11
- src/StaticLS/IDE/Workspace/Symbol.hs +56/−0
- src/StaticLS/SDoc.hs +23/−0
- src/StaticLS/Server.hs +72/−31
- src/StaticLS/SrcFiles.hs +10/−0
- src/StaticLS/StaticEnv.hs +22/−26
- src/StaticLS/StaticEnv/Options.hs +26/−4
- static-ls.cabal +54/−21
- test/SpecHook.hs +22/−0
- test/StaticLS/HI/FileSpec.hs +56/−0
- test/StaticLS/HIE/FileSpec.hs +8/−4
- test/StaticLS/HISpec.hs +39/−0
- test/StaticLS/IDE/DefinitionSpec.hs +24/−18
- test/TestData/Mod2.hs +9/−2
- test/TestImport.hs +13/−15
- test/TestImport/Assert.hs +6/−0
- test/TestImport/HieDb.hs +30/−0
- test/TestImport/TestData.hs +14/−3
CHANGELOG.md view
@@ -1,6 +1,26 @@ # Revision history for static-ls -## 0.1.0.0 -- 2023-04-13+## 0.2.0 -- TBD++* Add support for arguments+ * Support user specified hiedb file via argument+ * Support user specified hiefiles path via argument+ * Support user specified hifiles path via argument+ * Support user specified src base directories+ * Add version command+ * Add help command++* Bugfixes+ * Correctly terminate hie file read attempt on bad version header+ * Generate static information for tests rather than relying on hard-coded information++* Support reading interface files for haddock comments (https://github.com/josephsumabat/static-ls/pull/30)++* Support goto typedef (https://github.com/josephsumabat/static-ls/pull/31)++* Support workspace symbol (https://github.com/josephsumabat/static-ls/pull/18)++## 0.1.0 -- 2023-04-13 * Initial release supporting * find references globally when hie files and hiedb are available
LICENSE view
@@ -17,4 +17,19 @@ 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.++The following license is also included for code taken from ghcide:++Copyright 2019 Digital Asset (Switzerland) GmbH and/or its affiliates++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.OFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,151 @@+# static-ls++static-ls ("static language server") is a [hie files](https://gitlab.haskell.org/ghc/ghc/-/wikis/hie-files) and+[hiedb](https://github.com/wz1000/HieDb/) based language server heavily+inspired by [halfsp](https://github.com/masaeedu/halfsp), which 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++Supported static sources of information currently include:+- hiefiles+- hiedb++The goal of `static-ls` is to provide a high-speed, low-memory solution for large+projects for which+[haskell-language-server](https://github.com/haskell/haskell-language-server)+tends to take up too much memory on recompilation.+[Haskell-language-server](https://github.com/haskell/haskell-language-server)+is recommended if you are not experiencing these issues. `static-ls` is meant+to work on enterprise size projects where aforementioned constraints can be an+issue. `static-ls` tends to work better standalone as a code navigation tool+since project edits require re-indexing of hie files but also works reasonably+well for editing with a program such as+[ghcid](https://github.com/ndmitchell/ghcid) to watch files for compilation and+the `-fdefer-type-errors flag`.++In the future we plan to use more sources of static information such as interface files+to fetch documentation or ghcid's output to fetch diagnostics++Currently only ghc 9.4.4 and 9.6.1 are explicitly supported but I'm happy to add support for other versions of ghc if desired++## Usage++1. Compile your project with ide info `-fwrite-ide-info` and `-hiedir .hiefiles`+ + For a better UX, the following flags are *strongly* recommended.++ ```+ - -fdefer-type-errors+ - -Werror=deferred-type-errors+ - -Werror=deferred-out-of-scope-variables+ - -fno-defer-typed-holes+ ```+ + These flags will allow hie files to be refreshed even if compilation fails to+ type check and will ensure that type check failures are still thrown as+ errors.++ - If you're using hpack you can add:+ ```+ ghc-options:+ - -fwrite-ide-info+ - -hiedir .hiefiles+ - -fdefer-type-errors+ - -Werror=deferred-type-errors+ - -Werror=deferred-out-of-scope-variables+ - -fno-defer-typed-holes+ ```+ to your `package.yaml`. See this project's `package.yaml` or `static-ls.cabal` for examples+ - You may instead add the following to your `cabal.project.local` file:+ ```+ ignore-project: False+ program-options:+ ghc-options:+ -fdefer-type-errors+ -Werror=deferred-type-errors+ -Werror=deferred-out-of-scope-variables+ -fno-defer-typed-holes+ ```+ +2. Index your project in hiedb running:+ ```+ hiedb -D .hiedb index .hiefiles --src-base-dir .+ ```++ from your workspace root. If you're on an older version of `hiedb` where the `--src-base-dir` argument is not available use:+ + ```+ hiedb -D .hiedb index .hiefiles+ ```+ + `entr` is also recommended if you want file watching functionality:+ ```+ find -L .hiefiles | entr hiedb -D .hiedb index /_ + ```++3. Point your language client to the `static-ls` binary and begin editing!+ (See [Editor Setup](#editor-setup) for instructions if you're not sure how)++[ghcid](https://github.com/ndmitchell/ghcid) is recommended to refresh hie files but compiling with `cabal build` should work as well++## Features++`static-ls` supports the following lsp methods:+- `textDocument/references`+ - Note that find references only works on top level definitions and can be+ slow for functions which are used frequently++++- `textDocument/hover`+ - Provides type information and definition location on hover++++- `textDocument/definition`+ - Works on both local and top level definitions++++## Limitations+- Must be compiled on the same version of ghc as the project+- You will need to re-index your hie files once you edit your project++## Editor setup+Instructions for editor setup++### neovim - coc.nvim+call `:CocConfig` and copy the following in:+```+{+ "languageserver": {+ "static-ls": {+ "command": "static-ls",+ "rootPatterns": ["*.cabal", "stack.yaml", "cabal.project", "package.yaml", "hie.yaml"],+ "filetypes": ["haskell"]+ },+ },+}+```++### Visual Studio Code++1. Install the Haskell language extension+ ++2. Open the extension settings+ ++3. Scroll down until you see "Server Executable Path" and set the path to the path of your `static-ls` binary+ ++Alternatively you can also in your workspace's `./vscode/settings.json` you can use the following:+```+{+ "haskell.manageHLS": "PATH",+ "haskell.serverExecutablePath": "static-ls",+ "haskell.serverExtraArgs": ""+}+```+(Note `haskell.serverExecutablePath` should be the path to your binary).
+ app/App/Arguments.hs view
@@ -0,0 +1,106 @@+module App.Arguments (execArgParser) where++import Data.Version (showVersion)+import Options.Applicative+import Paths_static_ls (version)+import StaticLS.StaticEnv.Options+import System.Environment+import System.Exit+import Text.Parsec hiding (many, option)++currVersion :: String+currVersion = showVersion version++data PrgOptions = PrgOptions+ { staticEnvOpts :: StaticEnvOptions+ , showVer :: Bool+ , showHelp :: Bool+ }++{- | Run an argument parser but suppress invalid arguments (simply running the server instead)+Helpful for people on emacs or whose default configurations from HLS pass in+unsupported arguments to static-ls+-}+execArgParser :: IO StaticEnvOptions+execArgParser =+ getArgs >>= handleParseResultWithSuppression . execParserPure defaultPrefs progParseInfo+ where+ handleParseResultWithSuppression :: ParserResult PrgOptions -> IO StaticEnvOptions+ handleParseResultWithSuppression (Success (PrgOptions{showHelp = True})) =+ -- Get the help text (optparse-applicative usually shows the help text on error)+ handleParseResult . Failure $+ parserFailure defaultPrefs progParseInfo (ShowHelpText Nothing) mempty+ handleParseResultWithSuppression (Success (PrgOptions{showVer = True})) = do+ -- Show version info+ putStrLn $ "static-ls, version " <> currVersion+ exitSuccess+ handleParseResultWithSuppression (Success a) = return a.staticEnvOpts+ -- Ignore if invalid arguments are input+ handleParseResultWithSuppression (Failure _) = return defaultStaticEnvOptions+ handleParseResultWithSuppression (CompletionInvoked compl) = do+ progn <- getProgName+ msg <- execCompletion compl progn+ putStr msg+ exitSuccess++progParseInfo :: ParserInfo PrgOptions+progParseInfo =+ info+ (argParser <**> helper)+ ( fullDesc+ <> progDesc "Run static-ls as a language server for a client to talk to"+ <> header "static-ls - a lightweight language server for haskell"+ )++argParser :: Parser PrgOptions+argParser =+ PrgOptions+ <$> staticEnvOptParser+ <*> flag+ False+ True+ ( long "version"+ <> short 'v'+ <> help "Show the program version"+ )+ <*> flag+ False+ True+ ( long "help"+ <> short 'h'+ )++staticEnvOptParser :: Parser StaticEnvOptions+staticEnvOptParser =+ StaticEnvOptions+ <$> strOption+ ( long "hiedb"+ <> metavar "TARGET"+ <> value defaultHieDb+ <> help "Path to hiedb file produced by hiedb indexing hiefiles"+ <> showDefault+ )+ <*> strOption+ ( long "hiefiles"+ <> metavar "TARGET"+ <> value defaultHieFiles+ <> help "Path to hiefiles generated by -fwrite-ide-info and specified by -hiedir in ghc"+ <> showDefault+ )+ <*> strOption+ ( long "hifiles"+ <> metavar "TARGET"+ <> value defaultHiFiles+ <> help "Path to hifiles specified by -hidir in ghc"+ <> showDefault+ )+ <*> listOption+ ( long "srcDirs"+ <> metavar "TARGET1,TARGET2,TARGET3..."+ <> value defaultSrcDirs+ <> help "Path to directories containing source code. Comma delimited strings"+ <> showDefault+ )+ where+ -- Parse a list of comma delimited strings+ listOption = option $ eitherReader (either (Left . show) Right . runParser (sepEndBy (many alphaNum) (char ',')) () "")
app/Main.hs view
@@ -1,8 +1,10 @@ module Main where +import qualified App.Arguments as App import qualified StaticLS.Server as StaticLS main :: IO () main = do- _ <- StaticLS.runServer+ staticEnvOpts <- App.execArgParser+ _ <- StaticLS.runServer staticEnvOpts pure ()
+ src/StaticLS/FilePath.hs view
@@ -0,0 +1,29 @@+module StaticLS.FilePath (modToFilePath, subRootExtensionFilepath) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import qualified Data.List as List+import qualified Data.List.Extra as List+import qualified GHC.Plugins as GHC+import StaticLS.SrcFiles+import qualified System.Directory as Dir+import System.FilePath ((-<.>), (</>))++modToFilePath :: GHC.ModuleName -> String -> FilePath+modToFilePath modName ext =+ GHC.moduleNameSlashes modName -<.> ext++-- | Substitute a filepath extension and parent directory starting from some root+subRootExtensionFilepath :: (MonadIO m) => FilePath -> FilePath -> String -> FilePath -> MaybeT m FilePath+subRootExtensionFilepath wsRoot parent extension srcPath =+ do+ absoluteRoot <- liftIO $ Dir.makeAbsolute wsRoot+ let absoluteSrcDirs = (absoluteRoot </>) <$> srcDirs+ absoluteSrcPath <- liftIO $ Dir.makeAbsolute srcPath+ -- Normalize to absolute paths to drop the prefix+ let noPrefixSrcPath =+ List.foldl' (flip List.dropPrefix) absoluteSrcPath absoluteSrcDirs+ -- Set the directory path and substitute the file extension+ newPath = absoluteRoot </> parent </> noPrefixSrcPath -<.> extension+ True <- liftIO $ Dir.doesFileExist newPath+ pure newPath
+ src/StaticLS/HI.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}++module StaticLS.HI (+ getDocs,+ getDocsBatch,+ renderNameDocs,+ NameDocs (..),+)+where++import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import Data.Maybe+import Data.Text as T+import qualified GHC+import qualified GHC.Plugins as GHC+import qualified GHC.Types.Unique.Map as GHC+import StaticLS.SDoc++data NameDocs = NameDocs+ { declComment :: Maybe [GHC.HsDoc GHC.GhcRn]+ , argComments :: IntMap.IntMap (GHC.HsDoc GHC.GhcRn)+ }++instance GHC.Outputable NameDocs where+ ppr nameDoc = GHC.ppr nameDoc.declComment++renderNameDocs :: NameDocs -> Text+renderNameDocs nameDocs =+ T.drop 1 $ -- Drop the leading space from haddock comments+ maybe "" (T.concat . fmap showGhc) nameDocs.declComment++getDocsBatch :: [GHC.Name] -> GHC.ModIface -> [NameDocs]+getDocsBatch names iface =+ case GHC.mi_docs iface of+ Nothing -> []+ Just+ GHC.Docs+ { GHC.docs_decls = decls+ , GHC.docs_args = args+ } ->+ -- Lifted out compared to `getDocs` - probably slightly+ -- more efficient though the compiler may just optimize this+ let declMap = uniqNameMapToMap decls+ argsMap = uniqNameMapToMap args+ in ( \name ->+ NameDocs+ { declComment =+ Map.lookup (GHC.nameStableString name) declMap+ , argComments =+ fromMaybe mempty $+ Map.lookup (GHC.nameStableString name) argsMap+ }+ )+ <$> names++getDocs :: GHC.Name -> GHC.ModIface -> Maybe NameDocs+getDocs name iface =+ case GHC.mi_docs iface of+ Nothing -> Nothing+ Just+ GHC.Docs+ { GHC.docs_decls = decls+ , GHC.docs_args = args+ } ->+ Just $+ NameDocs+ { declComment = normalizeNameLookup name decls+ , argComments = fromMaybe mempty $ normalizeNameLookup name args+ }++normalizeNameLookup :: GHC.Name -> GHC.UniqMap GHC.Name v -> Maybe v+normalizeNameLookup name uMap =+ Map.lookup (GHC.nameStableString name) (uniqNameMapToMap uMap)++uniqNameMapToMap :: GHC.UniqMap GHC.Name v -> Map.Map String v+uniqNameMapToMap =+ Map.fromList+ . fmap stringifyNameKeys+ . IntMap.elems+ . GHC.ufmToIntMap+ . getUniqMap+ where+ stringifyNameKeys (nameKey, v) = (GHC.nameStableString nameKey, v)++getUniqMap :: GHC.UniqMap k a -> GHC.UniqFM k (k, a)+#if MIN_VERSION_base(4,18,0)+getUniqMap = GHC.getUniqMap+#else+getUniqMap (GHC.UniqMap m) = m+#endif
+ src/StaticLS/HI/File.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}++module StaticLS.HI.File (+ readHiFile,+ srcFilePathToHiFilePath,+ getModIfaceFromTdi,+ tdiToHiFilePath,+ modToHiFile,+) where++import Control.Exception+import Control.Monad+import Control.Monad.IO.Unlift (MonadIO, liftIO)+import Control.Monad.Trans.Maybe (MaybeT (..))+import qualified Data.Set as Set+import qualified GHC+import qualified GHC.Iface.Binary as GHC+import qualified GHC.Platform as GHC+import qualified GHC.Platform.Profile as GHC+import qualified GHC.Types.Name.Cache as GHC+import qualified Language.LSP.Protocol.Types as LSP+import StaticLS.FilePath+import StaticLS.SrcFiles+import StaticLS.StaticEnv+import System.FilePath ((</>))++getModIfaceFromTdi :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m GHC.ModIface+getModIfaceFromTdi = MaybeT . readHiFile <=< tdiToHiFilePath++tdiToHiFilePath :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m HiFilePath+tdiToHiFilePath = srcFilePathToHiFilePath <=< (MaybeT . pure . LSP.uriToFilePath . (._uri))++modToHiFile :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> MaybeT m HiFilePath+modToHiFile modName = do+ staticEnv <- getStaticEnv+ let hiFiles = staticEnv.hiFilesPath+ pure $ staticEnv.wsRoot </> hiFiles </> modToFilePath modName ".hi"++-- | Only supports 64 bit platforms+readHiFile :: (MonadIO m) => FilePath -> m (Maybe GHC.ModIface)+readHiFile filePath = do+ nameCache <- liftIO $ GHC.initNameCache 'a' []+ liftIO $+ ( Just+ <$> GHC.readBinIface+ GHC.Profile+ { GHC.profilePlatform = GHC.genericPlatform+ , GHC.profileWays = Set.empty+ }+ nameCache+ GHC.IgnoreHiWay+ GHC.QuietBinIFace+ filePath+ )+ `catch` (\(_ :: IOException) -> pure Nothing)+ `catch` (\(_ :: GHC.GhcException) -> pure Nothing)+ `catch` (\(_ :: SomeException) -> pure Nothing)++srcFilePathToHiFilePath :: (HasStaticEnv m, MonadIO m) => SrcFilePath -> MaybeT m HiFilePath+srcFilePathToHiFilePath srcPath = do+ staticEnv <- getStaticEnv+ let hiFiles = staticEnv.hiFilesPath+ hiDir = staticEnv.wsRoot </> hiFiles+ subRootExtensionFilepath staticEnv.wsRoot hiDir ".hi" srcPath
src/StaticLS/HIE.hs view
@@ -7,12 +7,13 @@ hieAstsAtPoint, hiedbCoordsToLspPosition, lspPositionToHieDbCoords,+ namesAtPoint, ) where import Control.Error.Util (hush) import Control.Exception (Exception)-import Control.Monad ((<=<))+import Control.Monad (join, (<=<)) import Control.Monad.Trans.Except (ExceptT, throwE) import qualified Data.Map as Map import Data.Maybe (mapMaybe)@@ -20,14 +21,19 @@ import qualified GHC import qualified GHC.Iface.Ext.Types as GHC import HieDb (pointCommand)-import qualified Language.LSP.Types as LSP+import qualified Language.LSP.Protocol.Types as LSP +-- | Note HieDbCoords are 1 indexed type HieDbCoords = (Int, Int) data UIntConversionException = UIntConversionException deriving (Show) instance Exception UIntConversionException++namesAtPoint :: GHC.HieFile -> HieDbCoords -> [GHC.Name]+namesAtPoint hieFile position =+ identifiersToNames $ join (pointCommand hieFile position Nothing hieAstNodeToIdentifiers) hieAstNodeToIdentifiers :: GHC.HieAST a -> [GHC.Identifier] hieAstNodeToIdentifiers =
src/StaticLS/HIE/File.hs view
@@ -21,8 +21,6 @@ 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@@ -30,14 +28,15 @@ import GHC.Stack (HasCallStack) import qualified GHC.Types.Name.Cache as GHC import qualified HieDb-import qualified Language.LSP.Types as LSP+import qualified Language.LSP.Protocol.Types as LSP+import StaticLS.FilePath import StaticLS.HIE.File.Except+import qualified StaticLS.HieDb as HieDb import StaticLS.Maybe (flatMaybeT, toAlt)+import StaticLS.SrcFiles import StaticLS.StaticEnv import qualified System.Directory as Dir-import System.FilePath ((-<.>), (</>))--type SrcFilePath = FilePath+import System.FilePath ((</>)) -- | Retrieve a hie info from a lsp text document identifier getHieFileFromTdi :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m GHC.HieFile@@ -59,28 +58,31 @@ -} srcFilePathToHieFilePath :: (HasStaticEnv m, MonadIO m) => SrcFilePath -> MaybeT m HieFilePath srcFilePathToHieFilePath srcPath =- srcFilePathToHieFilePathHieDb srcPath- <|> srcFilePathToHieFilePathFromFile srcPath+ srcFilePathToHieFilePathFromFile srcPath+ <|> srcFilePathToHieFilePathHieDb srcPath -- | Fetch an hie file from a src file hieFilePathToSrcFilePath :: (HasStaticEnv m, MonadIO m) => HieFilePath -> MaybeT m SrcFilePath-hieFilePathToSrcFilePath = hieFilePathToSrcFilePathFromFile+hieFilePathToSrcFilePath hiePath = do+ hieFilePathToSrcFilePathHieDb hiePath+ <|> hieFilePathToSrcFilePathFromFile hiePath ----------------------------------------------------------------------------------- -- 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 :: (HasCallStack, 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?+ -- Attempt to read valid hie file version+ -- NOTE: attempting to override an incorrect header and read an hie file+ -- seems to cause infinite hangs. TODO: explore why?+ nameCache <- liftIO $ GHC.initNameCache 'a' [] result <- liftIO ( fmap (first HieFileVersionException)- (GHC.readHieFileWithVersion (const True) staticEnv.nameCache hieFilePath)+ (GHC.readHieFileWithVersion ((== GHC.hieVersion) . fst) nameCache hieFilePath) `catch` (\(_ :: SomeException) -> pure . Left $ HieFileReadException) ) ExceptT $ pure (second GHC.hie_file_result result)@@ -96,23 +98,26 @@ HieDb.lookupHieFileFromSource hieDb absSrcPath pure $ HieDb.hieModuleHieFile hieModRow +hieFilePathToSrcFilePathHieDb :: (HasStaticEnv m, MonadIO m) => SrcFilePath -> MaybeT m HieFilePath+hieFilePathToSrcFilePathHieDb hiePath = do+ absHiePath <- liftIO $ Dir.makeAbsolute hiePath+ Just hieModRow <- runHieDbMaybeT $ \hieDb -> do+ HieDb.lookupHieFileFromHie hieDb absHiePath+ toAlt . HieDb.modInfoSrcFile $ HieDb.hieModInfo 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+ 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@@ -129,19 +134,8 @@ 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+ let hieDir = staticEnv.wsRoot </> staticEnv.hieFilesPath+ subRootExtensionFilepath staticEnv.wsRoot hieDir ".hie" srcPath ----------------------------------------------------------------------------------- -- Map index method for getting hie files - too slow in practice on startup but makes
+ src/StaticLS/HieDb.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE ViewPatterns #-}++module StaticLS.HieDb (lookupHieFileFromHie) where++import Data.List (intercalate)+import Database.SQLite.Simple+import HieDb++{- | Lookup 'HieModule' row from 'HieDb' given the path to the Haskell hie file+A temporary function until this is supported in hiedb proper+-}+lookupHieFileFromHie :: HieDb -> FilePath -> IO (Maybe HieModuleRow)+lookupHieFileFromHie (getConn -> conn) fp = do+ files <- query conn "SELECT * FROM mods WHERE hieFile = ?" (Only fp)+ case files of+ [] -> return Nothing+ [x] -> return $ Just x+ xs ->+ error $+ "DB invariant violated, hieFile in mods not unique: "+ ++ show fp+ ++ ". Entries: "+ ++ intercalate ", " (map (show . toRow) xs)
src/StaticLS/IDE/Definition.hs view
@@ -1,4 +1,4 @@-module StaticLS.IDE.Definition (getDefinition)+module StaticLS.IDE.Definition (getDefinition, getTypeDefinition) where import Control.Monad (guard, join)@@ -6,18 +6,22 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.List (isSuffixOf)-import Data.Maybe (fromMaybe, maybeToList)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)+import qualified Data.Set as Set 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.Iface.Ext.Utils as GHC+import qualified GHC.Iface.Type 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 qualified Language.LSP.Protocol.Types as LSP import StaticLS.Except import StaticLS.HIE import StaticLS.HIE.File@@ -30,9 +34,9 @@ (HasCallStack, HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> LSP.Position ->- m [LSP.Location]+ m [LSP.DefinitionLink] getDefinition tdi pos = do- mLocs <- runMaybeT $ do+ mLocationLinks <- runMaybeT $ do hieFile <- getHieFileFromTdi tdi let identifiersAtPoint = join $@@ -42,22 +46,67 @@ Nothing hieAstNodeToIdentifiers join <$> mapM (lift . identifierToLocation) identifiersAtPoint- pure $ fromMaybe [] mLocs++ pure $ maybe [] (map LSP.DefinitionLink) mLocationLinks where- identifierToLocation :: (HasStaticEnv m, MonadIO m) => GHC.Identifier -> m [LSP.Location]+ identifierToLocation :: (HasStaticEnv m, MonadIO m) => GHC.Identifier -> m [LSP.LocationLink] 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+ modToLocation :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> m (Maybe LSP.LocationLink)+ modToLocation modName = runMaybeT $ do+ srcFile <- modToSrcFile modName+ pure $ locationToLocationLink $ LSP.Location (LSP.filePathToUri srcFile) zeroRange +getTypeDefinition ::+ (HasCallStack, HasStaticEnv m, MonadIO m) =>+ LSP.TextDocumentIdentifier ->+ LSP.Position ->+ m [LSP.DefinitionLink]+getTypeDefinition tdi pos = do+ mLocationLinks <- runMaybeT $ do+ hieFile <- getHieFileFromTdi tdi+ let types' =+ join $+ HieDb.pointCommand+ hieFile+ (lspPositionToHieDbCoords pos)+ Nothing+ (GHC.nodeType . nodeInfo')+ types = map (flip GHC.recoverFullType $ GHC.hie_types hieFile) types'+ join <$> mapM (lift . nameToLocation) (mapMaybe typeToName types)+ pure $ maybe [] (map LSP.DefinitionLink) mLocationLinks+ where+ typeToName :: GHC.HieTypeFix -> Maybe GHC.Name+ typeToName = \case+ GHC.Roll (GHC.HTyVarTy name) -> Just name+ GHC.Roll (GHC.HAppTy ty _args) -> typeToName ty+ GHC.Roll (GHC.HTyConApp (GHC.IfaceTyCon name _info) _args) -> Just name+ GHC.Roll (GHC.HForAllTy ((name, _ty1), _forallFlag) _ty2) -> Just name+ GHC.Roll (GHC.HFunTy ty1 _ty2 _ty3) -> typeToName ty1+ GHC.Roll (GHC.HQualTy _constraint ty) -> typeToName ty+ GHC.Roll (GHC.HLitTy _ifaceTyLit) -> Nothing+ GHC.Roll (GHC.HCastTy ty) -> typeToName ty+ GHC.Roll GHC.HCoercionTy -> Nothing++ -- pulled from https://github.com/wz1000/HieDb/blob/6905767fede641747f5c24ce02f1ea73fc8c26e5/src/HieDb/Compat.hs#L147+ nodeInfo' :: GHC.HieAST GHC.TypeIndex -> GHC.NodeInfo GHC.TypeIndex+ nodeInfo' = Map.foldl' combineNodeInfo' GHC.emptyNodeInfo . GHC.getSourcedNodeInfo . GHC.sourcedNodeInfo++ combineNodeInfo' :: GHC.NodeInfo GHC.TypeIndex -> GHC.NodeInfo GHC.TypeIndex -> GHC.NodeInfo GHC.TypeIndex+ GHC.NodeInfo as ai ad `combineNodeInfo'` GHC.NodeInfo bs bi bd =+ GHC.NodeInfo (Set.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd)++ mergeSorted :: [GHC.TypeIndex] -> [GHC.TypeIndex] -> [GHC.TypeIndex]+ mergeSorted la@(a : as0) lb@(b : bs0) = case compare a b of+ LT -> a : mergeSorted as0 lb+ EQ -> a : mergeSorted as0 bs0+ GT -> b : mergeSorted la bs0+ mergeSorted as0 [] = as0+ mergeSorted [] bs0 = bs0+ --------------------------------------------------------------------- -- The following code is largely taken from ghcide with slight modifications -- to use the HasStaticEnv monad instead of the module map that ghcide indexes@@ -69,7 +118,7 @@ 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 :: (HasCallStack, HasStaticEnv m, MonadIO m) => GHC.Name -> m [LSP.LocationLink] nameToLocation name = fmap (fromMaybe []) <$> runMaybeT $ case GHC.nameSrcSpan name of sp@(GHC.RealSrcSpan rsp _)@@ -79,14 +128,14 @@ do itExists <- liftIO $ doesFileExist fs if itExists- then MaybeT $ pure . maybeToList <$> (runMaybeT . srcSpanToLocation) sp+ then MaybeT $ pure . maybeToList <$> (runMaybeT . fmap locationToLocationLink . 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 :: (HasCallStack, HasStaticEnv m, MonadIO m) => GHC.SrcSpan -> MaybeT m [LSP.LocationLink] fallbackToDb sp = do guard (sp /= GHC.wiredInSrcSpan) -- This case usually arises when the definition is in an external package.@@ -103,8 +152,8 @@ 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+ xs -> lift $ mapMaybeM (runMaybeT . fmap locationToLocationLink . defRowToLocation) xs+ xs -> lift $ mapMaybeM (runMaybeT . fmap locationToLocationLink . defRowToLocation) xs srcSpanToLocation :: (HasCallStack, HasStaticEnv m) => GHC.SrcSpan -> MaybeT m LSP.Location srcSpanToLocation src = do@@ -123,3 +172,19 @@ file <- hieFilePathToSrcFilePath hieFilePath let lspUri = LSP.filePathToUri file MaybeT . pure $ LSP.Location lspUri <$> range++-- TODO: Instead of calling this function the callers should directly construct a `LocationLink` with more information at hand.+locationToLocationLink :: LSP.Location -> LSP.LocationLink+locationToLocationLink LSP.Location{..} =+ LSP.LocationLink+ { _originSelectionRange = Nothing+ , _targetUri = _uri+ , _targetRange = _range+ , _targetSelectionRange = _range+ }++zeroPos :: LSP.Position+zeroPos = LSP.Position 0 0++zeroRange :: LSP.Range+zeroRange = LSP.Range zeroPos zeroPos
src/StaticLS/IDE/Hover.hs view
@@ -3,46 +3,58 @@ ) where -import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Maybe (listToMaybe)+import Data.Maybe import Data.Text (Text, intercalate) import qualified GHC.Iface.Ext.Types as GHC-import GHC.Stack (HasCallStack)+import GHC.Plugins as GHC import HieDb (pointCommand)-import Language.LSP.Types (+import Language.LSP.Protocol.Types ( Hover (..),- HoverContents (..), MarkupContent (..), MarkupKind (..), Position, Range (..), TextDocumentIdentifier, sectionSeparator,+ type (|?) (..), )+import StaticLS.HI+import StaticLS.HI.File import StaticLS.HIE import StaticLS.HIE.File import StaticLS.IDE.Hover.Info import StaticLS.Maybe import StaticLS.StaticEnv --- | Retrive hover information. Incomplete+-- | Retrieve hover information. retrieveHover :: (HasCallStack, HasStaticEnv m, MonadIO m) => TextDocumentIdentifier -> Position -> m (Maybe Hover) retrieveHover identifier position = do runMaybeT $ do hieFile <- getHieFileFromTdi identifier+ docs <- docsAtPoint hieFile position let info = listToMaybe $ pointCommand hieFile (lspPositionToHieDbCoords position) Nothing- (hoverInfo (GHC.hie_types hieFile))+ (hoverInfo (GHC.hie_types hieFile) docs) toAlt $ hoverInfoToHover <$> info where hoverInfoToHover :: (Maybe Range, [Text]) -> Hover hoverInfoToHover (mRange, contents) = Hover { _range = mRange- , _contents = HoverContents $ MarkupContent MkMarkdown $ intercalate sectionSeparator contents+ , _contents = InL $ MarkupContent MarkupKind_Markdown $ intercalate sectionSeparator contents }++docsAtPoint :: (HasCallStack, HasStaticEnv m, MonadIO m) => GHC.HieFile -> Position -> m [NameDocs]+docsAtPoint hieFile position = do+ let names = namesAtPoint hieFile (lspPositionToHieDbCoords position)+ modNames = fmap GHC.moduleName . mapMaybe GHC.nameModule_maybe $ names+ modIfaceFiles <- fromMaybe [] <$> runMaybeT (mapM modToHiFile modNames)+ modIfaces <- catMaybes <$> mapM readHiFile modIfaceFiles+ let docs = getDocsBatch names =<< modIfaces+ pure docs
src/StaticLS/IDE/Hover/Info.hs view
@@ -1,41 +1,43 @@ module StaticLS.IDE.Hover.Info (hoverInfo) where import Data.Array-import Data.List.Extra (dropEnd1)+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+import GHC hiding (getDocs) import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils import GHC.Plugins hiding ((<>))-import Language.LSP.Types+import Language.LSP.Protocol.Types+import StaticLS.HI+import StaticLS.SDoc ---------------------------------------------------------------------- The following code is taken from halfsp+-- 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 -> HieAST TypeIndex -> (Maybe Range, [T.Text])-hoverInfo typeLookup ast = (Just spanRange, map prettyName names ++ pTypes)+hoverInfo :: Array TypeIndex HieTypeFlat -> [NameDocs] -> HieAST TypeIndex -> (Maybe Range, [T.Text])+hoverInfo typeLookup docs ast = (Just spanRange, map prettyIdent idents ++ pTypes ++ prettyDocumentation docs) where pTypes- | [_] <- names = dropEnd1 $ map wrapHaskell prettyTypes+ | [_] <- idents = 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+ idents = M.assocs $ sourcedNodeIdents info types = concatMap nodeType (M.elems $ getSourcedNodeInfo info) - prettyName :: (Identifier, IdentifierDetails TypeIndex) -> T.Text- prettyName (Right n, dets) =+ prettyIdent :: (Identifier, IdentifierDetails TypeIndex) -> T.Text+ prettyIdent (Right n, dets) = T.unlines $- wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets))- : definedAt n- prettyName (Left m, _) = showGhc m+ [wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets))]+ <> definedAt n+ prettyIdent (Left m, _) = showGhc m prettyTypes = map (("_ :: " <>) . prettyType) types @@ -48,21 +50,9 @@ 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+ -- TODO: pretify more+ prettyDocumentation docs' =+ let renderedDocs = T.concat $ renderNameDocs <$> docs'+ in case renderedDocs of+ "" -> []+ _ -> ["\n", "Documentation:\n"] <> nubOrd (renderNameDocs <$> docs')
src/StaticLS/IDE/References.hs view
@@ -7,7 +7,7 @@ import Data.Maybe (catMaybes, fromMaybe) import qualified GHC.Plugins as GHC import qualified HieDb-import qualified Language.LSP.Types as LSP+import qualified Language.LSP.Protocol.Types as LSP import StaticLS.Except import StaticLS.HIE import StaticLS.HIE.File@@ -18,18 +18,11 @@ findRefs tdi position = do mLocList <- runMaybeT $ do hieFile <- getHieFileFromTdi tdi- let identifiersAtPoint =- join- ( HieDb.pointCommand- hieFile- (lspPositionToHieDbCoords position)- Nothing- hieAstNodeToIdentifiers- )- namesAtPoint = identifiersToNames identifiersAtPoint+ let hiedbPosition = lspPositionToHieDbCoords position+ names = namesAtPoint hieFile hiedbPosition occNamesAndModNamesAtPoint = (\name -> (GHC.occName name, fmap GHC.moduleName . GHC.nameModule_maybe $ name))- <$> namesAtPoint+ <$> names refResRows <- lift $ fmap (fromMaybe []) $ runMaybeT $ runHieDbMaybeT $ \hieDb -> do join
+ src/StaticLS/IDE/Workspace/Symbol.hs view
@@ -0,0 +1,56 @@+{-# 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 query = do+ mHiedbDefs <- runMaybeT . runHieDbMaybeT $ \hieDb -> HieDb.searchDef hieDb (T.unpack query)+ let hiedbDefs = fromMaybe [] mHiedbDefs+ symbols <- mapM defRowToSymbolInfo hiedbDefs+ pure (catMaybes 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 (HieDb.DefRow{..} HieDb.:. _) = runMaybeT $ do+ do+ srcFile <- hieFilePathToSrcFilePath defSrc+ let file = toUri srcFile+ loc = Location file range+ kind <- toAlt mKind+ pure $+ SymbolInformation+ { _name = printOutputable defNameOcc+ , _kind = kind+ , _tags = Nothing+ , _containerName = Nothing+ , _deprecated = Nothing+ , _location = loc+ }+ where+ mKind+ | isVarOcc defNameOcc = Just SymbolKind_Variable+ | isDataOcc defNameOcc = Just SymbolKind_Constructor+ | isTcOcc defNameOcc = Just SymbolKind_Struct+ | otherwise = Nothing+ range = Range start end+ start = Position (fromIntegral $ defSLine - 1) (fromIntegral $ defSCol - 1)+ end = Position (fromIntegral $ defELine - 1) (fromIntegral $ defECol - 1)++toUri :: FilePath -> Uri+toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath'
+ src/StaticLS/SDoc.hs view
@@ -0,0 +1,23 @@+module StaticLS.SDoc where++import qualified Data.Text as T+import GHC.Plugins hiding ((<>))++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/Server.hs view
@@ -1,11 +1,19 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE ScopedTypeVariables #-} -module StaticLS.Server where+module StaticLS.Server (+ runServer,+) where +--- Standard imports+ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Except++--- Uncommon 3rd-party imports+ import Language.LSP.Server ( Handlers, LanguageContextEnv,@@ -13,63 +21,91 @@ ServerDefinition (..), type (<~>) (Iso), )++import Language.LSP.Protocol.Message (Method (..), ResponseError (..), SMethod (..), TMessage, TRequestMessage (..))+import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP-import Language.LSP.Types++---- Local imports+ import StaticLS.IDE.Definition import StaticLS.IDE.Hover import StaticLS.IDE.References+import StaticLS.IDE.Workspace.Symbol import StaticLS.StaticEnv import StaticLS.StaticEnv.Options -data LspEnv config = LspEnv- { staticEnv :: StaticEnv- , config :: LanguageContextEnv config- }+------------------------------------------------------------------------- +-----------------------------------------------------------------+--------------------- LSP event handlers ------------------------+-----------------------------------------------------------------+ handleChangeConfiguration :: Handlers (LspT c StaticLs)-handleChangeConfiguration = LSP.notificationHandler SWorkspaceDidChangeConfiguration $ pure $ pure ()+handleChangeConfiguration = LSP.notificationHandler SMethod_WorkspaceDidChangeConfiguration $ pure $ pure () handleInitialized :: Handlers (LspT c StaticLs)-handleInitialized = LSP.notificationHandler SInitialized $ pure $ pure ()+handleInitialized = LSP.notificationHandler SMethod_Initialized $ pure $ pure () handleTextDocumentHoverRequest :: Handlers (LspT c StaticLs)-handleTextDocumentHoverRequest = LSP.requestHandler STextDocumentHover $ \req resp -> do+handleTextDocumentHoverRequest = LSP.requestHandler SMethod_TextDocumentHover $ \req resp -> do let hoverParams = req._params hover <- lift $ retrieveHover hoverParams._textDocument hoverParams._position- resp (Right hover)+ resp $ Right $ maybeToNull hover handleDefinitionRequest :: Handlers (LspT c StaticLs)-handleDefinitionRequest = LSP.requestHandler STextDocumentDefinition $ \req res -> do+handleDefinitionRequest = LSP.requestHandler SMethod_TextDocumentDefinition $ \req resp -> do let defParams = req._params defs <- lift $ getDefinition defParams._textDocument defParams._position- res $ Right . InR . InL . List $ defs+ resp $ Right . InR . InL $ defs +handleTypeDefinitionRequest :: Handlers (LspT c StaticLs)+handleTypeDefinitionRequest = LSP.requestHandler SMethod_TextDocumentTypeDefinition $ \req resp -> do+ let typeDefParams = req._params+ defs <- lift $ getTypeDefinition typeDefParams._textDocument typeDefParams._position+ resp $ Right . InR . InL $ defs+ handleReferencesRequest :: Handlers (LspT c StaticLs)-handleReferencesRequest = LSP.requestHandler STextDocumentReferences $ \req res -> do+handleReferencesRequest = LSP.requestHandler SMethod_TextDocumentReferences $ \req res -> do let refParams = req._params refs <- lift $ findRefs refParams._textDocument refParams._position- res $ Right . List $ refs+ res $ Right . InL $ refs handleCancelNotification :: Handlers (LspT c StaticLs)-handleCancelNotification = LSP.notificationHandler SCancelRequest $ \_ -> pure ()+handleCancelNotification = LSP.notificationHandler SMethod_CancelRequest $ \_ -> pure () handleDidOpen :: Handlers (LspT c StaticLs)-handleDidOpen = LSP.notificationHandler STextDocumentDidOpen $ \_ -> pure ()+handleDidOpen = LSP.notificationHandler SMethod_TextDocumentDidOpen $ \_ -> pure () handleDidChange :: Handlers (LspT c StaticLs)-handleDidChange = LSP.notificationHandler STextDocumentDidChange $ \_ -> pure ()+handleDidChange = LSP.notificationHandler SMethod_TextDocumentDidChange $ \_ -> pure () handleDidClose :: Handlers (LspT c StaticLs)-handleDidClose = LSP.notificationHandler STextDocumentDidClose $ \_ -> pure ()+handleDidClose = LSP.notificationHandler SMethod_TextDocumentDidClose $ \_ -> pure () handleDidSave :: Handlers (LspT c StaticLs)-handleDidSave = LSP.notificationHandler STextDocumentDidSave $ \_ -> pure ()+handleDidSave = LSP.notificationHandler SMethod_TextDocumentDidSave $ \_ -> pure () -initServer :: LanguageContextEnv config -> Message 'Initialize -> IO (Either ResponseError (LspEnv config))-initServer serverConfig _ = do+handleWorkspaceSymbol :: Handlers (LspT c StaticLs)+handleWorkspaceSymbol = LSP.requestHandler SMethod_WorkspaceSymbol $ \req res -> do+ -- https://hackage.haskell.org/package/lsp-types-1.6.0.0/docs/Language-LSP-Types.html#t:WorkspaceSymbolParams+ symbols <- lift (symbolInfo req._params._query)+ res $ Right . InL $ symbols++-----------------------------------------------------------------+----------------------- Server definition -----------------------+-----------------------------------------------------------------++data LspEnv config = LspEnv+ { staticEnv :: StaticEnv+ , config :: LanguageContextEnv config+ }++initServer :: StaticEnvOptions -> LanguageContextEnv config -> TMessage 'Method_Initialize -> IO (Either ResponseError (LspEnv config))+initServer staticEnvOptions serverConfig _ = do runExceptT $ do wsRoot <- ExceptT $ LSP.runLspT serverConfig getWsRoot- serverStaticEnv <- ExceptT $ Right <$> initStaticEnv wsRoot defaultStaticEnvOptions+ serverStaticEnv <- ExceptT $ Right <$> initStaticEnv wsRoot staticEnvOptions pure $ LspEnv { staticEnv = serverStaticEnv@@ -80,32 +116,37 @@ getWsRoot = do mRootPath <- LSP.getRootPath pure $ case mRootPath of- Nothing -> Left $ ResponseError InvalidRequest "No root workspace was found" Nothing+ Nothing -> Left $ ResponseError (InR ErrorCodes_InvalidRequest) "No root workspace was found" Nothing Just p -> Right p -serverDef :: ServerDefinition ()-serverDef =+serverDef :: StaticEnvOptions -> ServerDefinition ()+serverDef argOptions = ServerDefinition- { onConfigurationChange = \conf _ -> Right conf- , doInitialize = initServer- , staticHandlers =+ { onConfigChange = \_conf -> pure ()+ , configSection = ""+ , parseConfig = \_conf _value -> Right ()+ , doInitialize = initServer argOptions+ , -- TODO: Do handlers need to inspect clientCapabilities?+ staticHandlers = \_clientCapabilities -> mconcat [ handleInitialized , handleChangeConfiguration , handleTextDocumentHoverRequest , handleDefinitionRequest+ , handleTypeDefinitionRequest , handleReferencesRequest , handleCancelNotification , handleDidOpen , handleDidChange , handleDidClose , handleDidSave+ , handleWorkspaceSymbol ] , interpretHandler = \env -> Iso (runStaticLs env.staticEnv . LSP.runLspT env.config) liftIO , options = LSP.defaultOptions , defaultConfig = () } -runServer :: IO Int-runServer = do- LSP.runServer serverDef+runServer :: StaticEnvOptions -> IO Int+runServer argOptions = do+ LSP.runServer (serverDef argOptions)
+ src/StaticLS/SrcFiles.hs view
@@ -0,0 +1,10 @@+module StaticLS.SrcFiles (+ SrcFilePath,+ srcDirs,+) where++type SrcFilePath = FilePath++-- TODO: make this configurable (use cabal?)+srcDirs :: [FilePath]+srcDirs = ["src/", "lib/", "app/", "test/"]
src/StaticLS/StaticEnv.hs view
@@ -11,6 +11,7 @@ StaticLs, HieDbPath, HieFilePath,+ HiFilePath, HasStaticEnv, ) where@@ -22,9 +23,6 @@ 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 ((</>))@@ -34,6 +32,7 @@ type HieDbPath = FilePath type HieFilePath = FilePath+type HiFilePath = FilePath data HieDbException = HieDbIOException IOException@@ -46,16 +45,16 @@ -- | Static environment used to fetch data data StaticEnv = StaticEnv- { hieDbPath :: Maybe HieDbPath+ { hieDbPath :: 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+ , hieFilesPath :: HieFilePath+ , hiFilesPath :: HiFilePath , wsRoot :: FilePath -- ^ workspace root+ , srcDirs :: [FilePath]+ -- ^ directories to search for source code in order of priority }+ deriving (Eq, Show) type StaticLs = ReaderT StaticEnv IO @@ -67,21 +66,20 @@ 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 databasePath = wsRoot </> staticEnvOptions.optionHieDbPath+ hieFilesPath = wsRoot </> staticEnvOptions.optionHieFilesPath+ srcDirs = fmap (wsRoot </>) staticEnvOptions.optionSrcDirs+ hiFilesPath = wsRoot </> staticEnvOptions.optionHiFilesPath let serverStaticEnv = StaticEnv { hieDbPath = databasePath , hieFilesPath = hieFilesPath- , hscEnv = hscEnv- , nameCache = nameCache+ , hiFilesPath = hiFilesPath , wsRoot = wsRoot+ , srcDirs = srcDirs }+ pure serverStaticEnv -- | Run an hiedb action in an exceptT@@ -89,15 +87,13 @@ 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)- )+ ( \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
src/StaticLS/StaticEnv/Options.hs view
@@ -1,21 +1,43 @@ module StaticLS.StaticEnv.Options ( defaultStaticEnvOptions,+ defaultHieDb,+ defaultHieFiles,+ defaultSrcDirs,+ defaultHiFiles, StaticEnvOptions (..), ) where data StaticEnvOptions = StaticEnvOptions- { optionHieDbPath :: Maybe FilePath+ { optionHieDbPath :: FilePath -- ^ Relative path to hiedb file -- hiedb is required for find references and go to definition to work correctly- , optionHieFilesPath :: Maybe FilePath+ , optionHieFilesPath :: FilePath -- ^ Relative path to hie files directory -- hie files are required for all functionality+ , optionHiFilesPath :: FilePath+ -- ^ Relative path to hi files directory+ , optionSrcDirs :: [FilePath] }+ deriving (Show, Eq) +defaultHieDb :: FilePath+defaultHieDb = ".hiedb"++defaultHieFiles :: FilePath+defaultHieFiles = ".hiefiles"++defaultSrcDirs :: [FilePath]+defaultSrcDirs = ["src/", "lib/", "app/", "test/"]++defaultHiFiles :: FilePath+defaultHiFiles = ".hifiles"+ defaultStaticEnvOptions :: StaticEnvOptions defaultStaticEnvOptions = StaticEnvOptions- { optionHieDbPath = Just ".hiedb"- , optionHieFilesPath = Just ".hiefiles"+ { optionHieDbPath = defaultHieDb+ , optionHieFilesPath = defaultHieFiles+ , optionSrcDirs = defaultSrcDirs+ , optionHiFilesPath = defaultHiFiles }
static-ls.cabal view
@@ -1,11 +1,11 @@-cabal-version: 1.12+cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: static-ls-version: 0.1.0+version: 0.1.2 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@@ -16,7 +16,11 @@ license: MIT license-file: LICENSE build-type: Simple-extra-source-files:+tested-with:+ GHC == 9.4.4+ , GHC == 9.6.3+extra-doc-files:+ README.md CHANGELOG.md source-repository head@@ -31,28 +35,39 @@ library exposed-modules: StaticLS.Except+ StaticLS.FilePath+ StaticLS.HI+ StaticLS.HI.File StaticLS.HIE StaticLS.HIE.File StaticLS.HIE.File.Except+ StaticLS.HieDb StaticLS.IDE.Definition StaticLS.IDE.Hover StaticLS.IDE.Hover.Info StaticLS.IDE.References+ StaticLS.IDE.Workspace.Symbol StaticLS.Maybe+ StaticLS.SDoc StaticLS.Server+ StaticLS.SrcFiles StaticLS.StaticEnv StaticLS.StaticEnv.Options other-modules: Paths_static_ls+ autogen-modules:+ Paths_static_ls hs-source-dirs: src default-extensions:+ ExplicitNamespaces FlexibleContexts OverloadedRecordDot OverloadedStrings NoFieldSelectors LambdaCase- ghc-options: -fwrite-ide-info -hiedir test/TestData/.hiefiles+ RecordWildCards+ ghc-options: -Wall -fwrite-ide-info -hiedir test/TestData/.hiefiles -haddock build-depends: array >=0.5.4 && <0.6 , base >=4.17.0 && <4.19@@ -61,13 +76,14 @@ , 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 >=9.4.3 && <9.7 , ghc-paths >=0.1.0 && <0.2- , ghcide >=1.9.1 && <1.11+ , ghcide >=2.5.0 && <2.6.0 , hiedb >=0.4.2 && <0.5- , lsp >=1.6.0 && <1.7- , lsp-types >=1.6.0 && <1.7+ , lsp ==2.3.*+ , lsp-types ==2.1.* , mtl >=2.2.2 && <2.4+ , parsec >=3.1.0 && <3.2 , sqlite-simple >=0.4.18 && <0.5 , template-haskell >=2.19.0 && <2.21 , text >=2.0.1 && <2.1@@ -75,20 +91,26 @@ , 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+ ghc-options: -fwrite-ide-info -hiedir .hiefiles -hidir .hifiles -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:+ App.Arguments Paths_static_ls+ autogen-modules:+ Paths_static_ls hs-source-dirs: app default-extensions:+ ExplicitNamespaces FlexibleContexts OverloadedRecordDot OverloadedStrings NoFieldSelectors LambdaCase+ RecordWildCards+ ghc-options: -Wall build-depends: array >=0.5.4 && <0.6 , base >=4.17.0 && <4.19@@ -97,13 +119,15 @@ , 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 >=9.4.3 && <9.7 , ghc-paths >=0.1.0 && <0.2- , ghcide >=1.9.1 && <1.11+ , ghcide >=2.5.0 && <2.6.0 , hiedb >=0.4.2 && <0.5- , lsp >=1.6.0 && <1.7- , lsp-types >=1.6.0 && <1.7+ , lsp ==2.3.*+ , lsp-types ==2.1.* , mtl >=2.2.2 && <2.4+ , optparse-applicative >=0.17.0.0 && <0.19+ , parsec >=3.1.0 && <3.2 , sqlite-simple >=0.4.18 && <0.5 , static-ls , template-haskell >=2.19.0 && <2.21@@ -112,30 +136,38 @@ , 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+ ghc-options: -fwrite-ide-info -hiedir .hiefiles -hidir .hifiles -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:+ SpecHook+ StaticLS.HI.FileSpec StaticLS.HIE.FileSpec+ StaticLS.HISpec StaticLS.IDE.DefinitionSpec StaticLS.IDE.HoverSpec TestData.Mod1 TestData.Mod2 TestImport TestImport.Assert+ TestImport.HieDb TestImport.TestData Paths_static_ls+ autogen-modules:+ Paths_static_ls hs-source-dirs: test default-extensions:+ ExplicitNamespaces FlexibleContexts OverloadedRecordDot OverloadedStrings NoFieldSelectors LambdaCase- ghc-options: -fwrite-ide-info -hiedir test/TestData/.hiefiles+ RecordWildCards+ ghc-options: -Wall -fwrite-ide-info -fwrite-interface -hiedir test/TestData/.hiefiles -hidir test/TestData/.hifiles -haddock build-tool-depends: hspec-discover:hspec-discover == 2.* build-depends: array >=0.5.4 && <0.6@@ -145,14 +177,15 @@ , 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 >=9.4.3 && <9.7 , ghc-paths >=0.1.0 && <0.2- , ghcide >=1.9.1 && <1.11+ , ghcide >=2.5.0 && <2.6.0 , hiedb >=0.4.2 && <0.5 , hspec ==2.*- , lsp >=1.6.0 && <1.7- , lsp-types >=1.6.0 && <1.7+ , lsp ==2.3.*+ , lsp-types ==2.1.* , mtl >=2.2.2 && <2.4+ , parsec >=3.1.0 && <3.2 , sqlite-simple >=0.4.18 && <0.5 , static-ls , template-haskell >=2.19.0 && <2.21@@ -161,4 +194,4 @@ , 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+ ghc-options: -fwrite-ide-info -hiedir .hiefiles -hidir .hifiles -fdefer-type-errors -fno-defer-typed-holes -Werror=deferred-type-errors -Werror=deferred-out-of-scope-variables
+ test/SpecHook.hs view
@@ -0,0 +1,22 @@+module SpecHook where++import Control.Exception+import System.Directory+import System.IO.Error+import Test.Hspec+import TestImport+import TestImport.HieDb+import Prelude++hook :: Spec -> Spec+hook = do+ beforeAll+ ( removeIfExists testHieDbDir >> indexHieFiles >> removeIfExists testHieDbDir+ )+ where+ removeIfExists :: FilePath -> IO ()+ removeIfExists fileName = removeFile fileName `catch` handleExists+ where+ handleExists e+ | isDoesNotExistError e = return ()+ | otherwise = throwIO e
+ test/StaticLS/HI/FileSpec.hs view
@@ -0,0 +1,56 @@+module StaticLS.HI.FileSpec (spec)+where++import Control.Monad.Trans.Maybe (runMaybeT)+import StaticLS.HI.File+import StaticLS.StaticEnv+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 hi file" $ do+ describe "src file to hi file" $ do+ it "returns a valid hi file when called on a src file" $ do+ staticEnv <- Test.initStaticEnv+ hiFile <-+ runStaticLs staticEnv $+ runMaybeT $+ srcFilePathToHiFilePath "test/TestData/Mod1.hs"+ print hiFile+ let relativeHiFile = makeRelative staticEnv.wsRoot <$> hiFile+ hiFileExists <- maybe (pure False) doesFileExist relativeHiFile++ relativeHiFile `shouldBe` Just "test/TestData/.hifiles/TestData/Mod1.hi"+ hiFileExists `shouldBe` True++ it "returns a valid hi file when called on a test/ file" $ do+ staticEnv <- Test.initStaticEnv+ hiFile <-+ runStaticLs staticEnv $+ runMaybeT $+ srcFilePathToHiFilePath "test/TestData/Mod1.hs"+ let relativeHiFile = makeRelative staticEnv.wsRoot <$> hiFile+ hiFileExists <- maybe (pure False) doesFileExist relativeHiFile++ relativeHiFile `shouldBe` Just "test/TestData/.hifiles/TestData/Mod1.hi"+ hiFileExists `shouldBe` True++ describe "readHiFile" $ do+ it "Returns a valid hie file" $ do+ hiFile <- readHiFile "test/TestData/.hifiles/TestData/Mod1.hi"+ _ <- Test.assertJust "expected succesful read" hiFile+ (pure () :: IO ())++ it "Does not crash when given an invalid hie file to read " $ do+ hiFile <- readHiFile "./test/TestData/Mod1.hs"+ _ <- Test.assertNothing "expected failure" hiFile+ (pure () :: IO ())++ it "Does not crash when given no file to read" $ do+ hiFile <- readHiFile ""+ _ <- Test.assertNothing "expected failure" hiFile+ (pure () :: IO ())
test/StaticLS/HIE/FileSpec.hs view
@@ -52,8 +52,10 @@ it "Does not crash when given an invalid hie file to read " $ do let emptyOpts = StaticEnvOptions- { optionHieDbPath = Nothing- , optionHieFilesPath = Nothing+ { optionHieDbPath = ""+ , optionHieFilesPath = ""+ , optionSrcDirs = []+ , optionHiFilesPath = "" } staticEnv <- Test.initStaticEnvOpts emptyOpts hieFile <-@@ -66,8 +68,10 @@ it "Does not crash when given no file to read" $ do let emptyOpts = StaticEnvOptions- { optionHieDbPath = Nothing- , optionHieFilesPath = Nothing+ { optionHieDbPath = ""+ , optionHieFilesPath = ""+ , optionSrcDirs = []+ , optionHiFilesPath = "" } staticEnv <- Test.initStaticEnvOpts emptyOpts hieFile <-
+ test/StaticLS/HISpec.hs view
@@ -0,0 +1,39 @@+module StaticLS.HISpec (spec)+where++import Control.Monad.Trans.Except+import Language.LSP.Protocol.Types+import StaticLS.HI+import StaticLS.HI.File+import StaticLS.HIE+import StaticLS.HIE.File+import Test.Hspec+import qualified TestImport.Assert as Test+import TestImport.TestData++spec :: Spec+spec = do+ describe "getDocs" $ do+ it "Returns a valid hie file" $ do+ hiFile <- readHiFile "test/TestData/.hifiles/TestData/Mod2.hi"+ eHieFile <- runExceptT $ getHieFile "test/TestData/.hiefiles/TestData/Mod2.hie"+ hieFile <- Test.assertRight "expected hie file" eHieFile+ modiface <- Test.assertJust "expected succesful read" hiFile+ fnLocation <- myFunDefLocation+ let position = lspPositionToHieDbCoords fnLocation._range._start+ names = namesAtPoint hieFile position+ expectedDocs = ["Lsp Position line: 11, character: 0\nanother line of comments\n"]+ readDocs = renderNameDocs <$> getDocsBatch names modiface++ _ <- readDocs `shouldBe` expectedDocs+ (pure () :: IO ())++ it "Does not crash when given an invalid hie file to read " $ do+ hiFile <- readHiFile "./test/TestData/Mod1.hs"+ _ <- Test.assertNothing "expected failure" hiFile+ (pure () :: IO ())++ it "Does not crash when given no file to read" $ do+ hiFile <- readHiFile ""+ _ <- Test.assertNothing "expected failure" hiFile+ (pure () :: IO ())
test/StaticLS/IDE/DefinitionSpec.hs view
@@ -14,42 +14,48 @@ 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+ defnLinks <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition+ defnLink <- Test.assertHead "no definition link found" defnLinks+ expectedDefnLink <- Test.myFunDefDefinitionLink+ defnLink `shouldBe` expectedDefnLink 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"+ { optionHieDbPath = ""+ , optionHieFilesPath = "test/TestData/.hiefiles"+ , optionSrcDirs = defaultSrcDirs+ , optionHiFilesPath = "test/TestData/.hifiles" } 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+ defnLinks <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition+ defnLink <- Test.assertHead "no definition link found" defnLinks+ expectedDefnLink <- Test.myFunDefDefinitionLink+ defnLink `shouldBe` expectedDefnLink it "empty hiedb" $ do let emptyOpts = StaticEnvOptions- { optionHieDbPath = Just "./TestData/not-a-real-hiedb-file"- , optionHieFilesPath = Just "test/TestData/.hiefiles"+ { optionHieDbPath = "./TestData/not-a-real-hiedb-file"+ , optionHieFilesPath = "test/TestData/.hiefiles"+ , optionSrcDirs = defaultSrcDirs+ , optionHiFilesPath = "test/TestData/.hifiles" } 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+ defnLinks <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition+ defnLink <- Test.assertHead "no definition link found" defnLinks+ expectedDefnLink <- Test.myFunDefDefinitionLink+ defnLink `shouldBe` expectedDefnLink it "does not crash with missing all sources" $ do let emptyOpts = StaticEnvOptions- { optionHieDbPath = Nothing- , optionHieFilesPath = Nothing+ { optionHieDbPath = ""+ , optionHieFilesPath = ""+ , optionSrcDirs = []+ , optionHiFilesPath = "" } staticEnv <- Test.initStaticEnvOpts emptyOpts locs <- runStaticLs staticEnv $ uncurry getDefinition Test.myFunRef1TdiAndPosition
test/TestData/Mod2.hs view
@@ -1,5 +1,12 @@ module TestData.Mod2 where --- | Position line: 3, character: 0-myFun :: Int -> Int -> Int+{- | Lsp Position line: 11, character: 0+another line of comments+-}+myFun ::+ -- | First int+ Int ->+ -- | Second int+ Int ->+ Int myFun n m = n + m
test/TestImport.hs view
@@ -1,35 +1,33 @@-{-# 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" +testHiDir :: FilePath+testHiDir = "test/TestData/.hifiles"++testHieDbDir :: FilePath+testHieDbDir = "test/TestData/.hiedb"++testSrcDirs :: [FilePath]+testSrcDirs = StaticEnv.defaultSrcDirs+ defaultTestStaticEnvOptions :: StaticEnvOptions defaultTestStaticEnvOptions = StaticEnvOptions- { optionHieDbPath = Just ("test/TestData/" </> ghcVerDir </> ".hiedb")- , optionHieFilesPath = Just testHieDir+ { optionHieDbPath = testHieDbDir+ , optionHieFilesPath = testHieDir+ , optionSrcDirs = testSrcDirs+ , optionHiFilesPath = testHiDir } initStaticEnvOpts :: StaticEnvOptions -> IO StaticEnv
test/TestImport/Assert.hs view
@@ -12,6 +12,12 @@ Just a -> pure a Nothing -> fail $ assertionFailureMsg msg +assertNothing :: (MonadFail m) => String -> Maybe a -> m ()+assertNothing msg =+ \case+ Nothing -> pure ()+ Just _ -> fail $ assertionFailureMsg msg+ assertLeft :: (MonadFail m) => String -> Either a b -> m a assertLeft msg = \case
+ test/TestImport/HieDb.hs view
@@ -0,0 +1,30 @@+module TestImport.HieDb where++import qualified GHC.Paths as GHC+import HieDb.Create+import HieDb.Run+import HieDb.Types+import HieDb.Utils+import System.IO+import TestImport++indexHieFiles :: IO ()+indexHieFiles =+ withHieDbAndFlags (LibDir GHC.libdir) (database testOpts) $ \_ conn -> do+ initConn conn+ files <- concat <$> mapM getHieFilesIn [testHieDir]+ doIndex conn testOpts stderr files+ pure ()++testOpts :: Options+testOpts =+ Options+ { database = testHieDbDir+ , trace = False+ , quiet = True+ , colour = False+ , context = Nothing+ , reindex = False+ , keepMissing = False+ , srcBaseDir = Nothing+ }
test/TestImport/TestData.hs view
@@ -2,7 +2,7 @@ module TestImport.TestData where -import qualified Language.LSP.Types as LSP+import qualified Language.LSP.Protocol.Types as LSP import qualified System.Directory as Dir myFunDefTdiAndPosition :: (LSP.TextDocumentIdentifier, LSP.Position)@@ -16,6 +16,17 @@ LSP.TextDocumentIdentifier $ LSP.filePathToUri "test/TestData/Mod2.hs" in (tdi, pos) +myFunDefDefinitionLink :: IO LSP.DefinitionLink+myFunDefDefinitionLink = do+ LSP.Location{..} <- myFunDefLocation+ pure . LSP.DefinitionLink $+ LSP.LocationLink+ { _originSelectionRange = Nothing+ , _targetUri = _uri+ , _targetRange = _range+ , _targetSelectionRange = _range+ }+ myFunDefLocation :: IO LSP.Location myFunDefLocation = do absDir <- Dir.makeAbsolute "test/TestData/Mod2.hs"@@ -26,12 +37,12 @@ LSP.Range { _start = LSP.Position- { LSP._line = 4+ { LSP._line = 11 , LSP._character = 0 } , LSP._end = LSP.Position- { LSP._line = 4+ { LSP._line = 11 , LSP._character = 5 } }