diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified StaticLS.Server as StaticLS + +main :: IO () +main = do + _ <- StaticLS.runServer + pure () diff --git a/src/StaticLS/Except.hs b/src/StaticLS/Except.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/Except.hs @@ -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 diff --git a/src/StaticLS/HIE.hs b/src/StaticLS/HIE.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/HIE.hs @@ -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 diff --git a/src/StaticLS/HIE/File.hs b/src/StaticLS/HIE/File.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/HIE/File.hs @@ -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 diff --git a/src/StaticLS/HIE/File/Except.hs b/src/StaticLS/HIE/File/Except.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/HIE/File/Except.hs @@ -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 diff --git a/src/StaticLS/IDE/Definition.hs b/src/StaticLS/IDE/Definition.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/IDE/Definition.hs @@ -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 diff --git a/src/StaticLS/IDE/Hover.hs b/src/StaticLS/IDE/Hover.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/IDE/Hover.hs @@ -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 + } diff --git a/src/StaticLS/IDE/Hover/Info.hs b/src/StaticLS/IDE/Hover/Info.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/IDE/Hover/Info.hs @@ -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 " 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 diff --git a/src/StaticLS/IDE/References.hs b/src/StaticLS/IDE/References.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/IDE/References.hs @@ -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 diff --git a/src/StaticLS/Maybe.hs b/src/StaticLS/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/Maybe.hs @@ -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 diff --git a/src/StaticLS/Server.hs b/src/StaticLS/Server.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/Server.hs @@ -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 diff --git a/src/StaticLS/StaticEnv.hs b/src/StaticLS/StaticEnv.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/StaticEnv.hs @@ -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 diff --git a/src/StaticLS/StaticEnv/Options.hs b/src/StaticLS/StaticEnv/Options.hs new file mode 100644 --- /dev/null +++ b/src/StaticLS/StaticEnv/Options.hs @@ -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" + } diff --git a/static-ls.cabal b/static-ls.cabal new file mode 100644 --- /dev/null +++ b/static-ls.cabal @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/StaticLS/HIE/FileSpec.hs b/test/StaticLS/HIE/FileSpec.hs new file mode 100644 --- /dev/null +++ b/test/StaticLS/HIE/FileSpec.hs @@ -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 () diff --git a/test/StaticLS/IDE/DefinitionSpec.hs b/test/StaticLS/IDE/DefinitionSpec.hs new file mode 100644 --- /dev/null +++ b/test/StaticLS/IDE/DefinitionSpec.hs @@ -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` [] diff --git a/test/StaticLS/IDE/HoverSpec.hs b/test/StaticLS/IDE/HoverSpec.hs new file mode 100644 --- /dev/null +++ b/test/StaticLS/IDE/HoverSpec.hs @@ -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 () diff --git a/test/TestData/Mod1.hs b/test/TestData/Mod1.hs new file mode 100644 --- /dev/null +++ b/test/TestData/Mod1.hs @@ -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 diff --git a/test/TestData/Mod2.hs b/test/TestData/Mod2.hs new file mode 100644 --- /dev/null +++ b/test/TestData/Mod2.hs @@ -0,0 +1,5 @@ +module TestData.Mod2 where + +-- | Position line: 3, character: 0 +myFun :: Int -> Int -> Int +myFun n m = n + m diff --git a/test/TestImport.hs b/test/TestImport.hs new file mode 100644 --- /dev/null +++ b/test/TestImport.hs @@ -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 diff --git a/test/TestImport/Assert.hs b/test/TestImport/Assert.hs new file mode 100644 --- /dev/null +++ b/test/TestImport/Assert.hs @@ -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 diff --git a/test/TestImport/TestData.hs b/test/TestImport/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestImport/TestData.hs @@ -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