diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,26 @@ # Revision history for haskell-lsp +## 0.12.1.0 -- 2019-05-08 + +* Bring over functions from @mpickering's hie-bios. + So `LspFuncs` now includes + +```haskell + , persistVirtualFileFunc :: !(J.Uri -> IO FilePath) + , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) + ``` + +* Fix exception on empty filepaths + +* Migrate some utility functions from `haskell-ide-engine`, for the + benefit of other language servers. + - `rangeLinesFromVfs` + - `PosPrefixInfo(..)` + - `getCompletionPrefix` + +* Remove `HoverContentsEmpty`. It is unnecessary, and generated + illegal JSON on the wire. + ## 0.12.0.0 -- 2019-05-05 * Added A NFData instance for Diagnostics (@DavidM-D/@ndmitchell) diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -194,7 +194,7 @@ . J.uri mdoc <- liftIO $ Core.getVirtualFileFunc lf doc case mdoc of - Just (VirtualFile _version str) -> do + Just (VirtualFile _version str _) -> do liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf got:" ++ (show $ Rope.toString str) Nothing -> do liftIO $ U.logs "reactor:processing NotDidChangeTextDocument: vf returned Nothing" diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -1,5 +1,5 @@ name: haskell-lsp -version: 0.12.0.0 +version: 0.12.1.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -50,9 +50,10 @@ , mtl , network-uri , parsec - , rope-utf16-splay >= 0.2 + , rope-utf16-splay >= 0.3.1.0 , sorted-list == 0.2.1.* , stm + , temporary , text , time , unordered-containers @@ -123,6 +124,13 @@ , sorted-list == 0.2.1.* , stm , text + -- For GHCI tests + -- , async + -- , haskell-lsp-types + -- , hslogger + -- , temporary + -- , time + -- , unordered-containers build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -156,6 +156,8 @@ -- server-provided function. , sendFunc :: !SendFunc , getVirtualFileFunc :: !(J.Uri -> IO (Maybe VirtualFile)) + , persistVirtualFileFunc :: !(J.Uri -> IO FilePath) + , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) , publishDiagnosticsFunc :: !PublishDiagnosticsFunc , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc , getNextReqId :: !(IO J.LspId) @@ -417,6 +419,36 @@ getVirtualFile :: TVar (LanguageContextData c) -> J.Uri -> IO (Maybe VirtualFile) getVirtualFile tvarDat uri = Map.lookup uri . resVFS <$> readTVarIO tvarDat +-- | Dump the current text for a given VFS file to a temporary file, +-- and return the path to the file. +persistVirtualFile :: TVar (LanguageContextData c) -> J.Uri -> IO FilePath +persistVirtualFile tvarDat uri = do + st <- readTVarIO tvarDat + let vfs = resVFS st + revMap = reverseMap st + + (fn, new_vfs) <- persistFileVFS vfs uri + let revMap' = + -- TODO: Does the VFS make sense for URIs which are not files? + -- The reverse map should perhaps be (FilePath -> URI) + case J.uriToFilePath uri of + Just uri_fp -> Map.insert fn uri_fp revMap + Nothing -> revMap + + atomically $ modifyTVar' tvarDat (\d -> d { resVFS = new_vfs + , reverseMap = revMap' }) + return fn + +-- TODO: should this function return a URI? +-- | If the contents of a VFS has been dumped to a temporary file, map +-- the temporary file name back to the original one. +reverseFileMap :: TVar (LanguageContextData c) + -> IO (FilePath -> FilePath) +reverseFileMap tvarDat = do + revMap <- reverseMap <$> readTVarIO tvarDat + let f fp = fromMaybe fp $ Map.lookup fp revMap + return f + -- --------------------------------------------------------------------- getConfig :: TVar (LanguageContextData c) -> IO (Maybe c) @@ -691,6 +723,8 @@ (getConfig tvarCtx) (resSendResponse ctx0) (getVirtualFile tvarCtx) + (persistVirtualFile tvarCtx) + (reverseFileMap tvarCtx) (publishDiagnostics tvarCtx) (flushDiagnosticsBySource tvarCtx) (getLspId $ resLspId ctx0) diff --git a/src/Language/Haskell/LSP/Utility.hs b/src/Language/Haskell/LSP/Utility.hs --- a/src/Language/Haskell/LSP/Utility.hs +++ b/src/Language/Haskell/LSP/Utility.hs @@ -43,7 +43,6 @@ lbs2str :: LBS.ByteString -> String lbs2str = TL.unpack. TLE.decodeUtf8 - -- --------------------------------------------------------------------- logs :: String -> IO () @@ -51,4 +50,3 @@ logm :: B.ByteString -> IO () logm str = logs (lbs2str str) - diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -16,22 +16,31 @@ , openVFS , changeFromClientVFS , changeFromServerVFS + , persistFileVFS , closeVFS + -- * manipulating the file contents + , rangeLinesFromVfs + , PosPrefixInfo(..) + , getCompletionPrefix + -- * for tests , applyChanges , applyChange , changeChars ) where -import Control.Lens +import Control.Lens hiding ( parts ) import Control.Monad +import Data.Char (isUpper, isAlphaNum) import Data.Text ( Text ) +import qualified Data.Text as T import Data.List import Data.Ord #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif +import System.IO.Temp import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe @@ -50,6 +59,7 @@ VirtualFile { _version :: Int , _text :: Rope + , _tmp_file :: Maybe FilePath } deriving (Show) type VFS = Map.Map J.Uri VirtualFile @@ -60,7 +70,7 @@ openVFS vfs (J.NotificationMessage _ _ params) = do let J.DidOpenTextDocumentParams (J.TextDocumentItem uri _ version text) = params - return $ Map.insert uri (VirtualFile version (Rope.fromText text)) vfs + return $ Map.insert uri (VirtualFile version (Rope.fromText text) Nothing) vfs -- --------------------------------------------------------------------- @@ -70,10 +80,10 @@ J.DidChangeTextDocumentParams vid (J.List changes) = params J.VersionedTextDocumentIdentifier uri version = vid case Map.lookup uri vfs of - Just (VirtualFile _ str) -> do + Just (VirtualFile _ str _) -> do let str' = applyChanges str changes -- the client shouldn't be sending over a null version, only the server. - return $ Map.insert uri (VirtualFile (fromMaybe 0 version) str') vfs + return $ Map.insert uri (VirtualFile (fromMaybe 0 version) str' Nothing) vfs Nothing -> do logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri return vfs @@ -107,11 +117,24 @@ ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) notif = J.NotificationMessage "" J.TextDocumentDidChange ps changeFromClientVFS vfs notif - + editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text -- --------------------------------------------------------------------- +persistFileVFS :: VFS -> J.Uri -> IO (FilePath, VFS) +persistFileVFS vfs uri = + case Map.lookup uri vfs of + Nothing -> error ("File not found in VFS: " ++ show uri ++ show vfs) + Just (VirtualFile v txt tfile) -> + case tfile of + Just tfn -> return (tfn, vfs) + Nothing -> do + fn <- writeSystemTempFile "VFS.hs" (Rope.toString txt) + return (fn, Map.insert uri (VirtualFile v txt (Just fn)) vfs) + +-- --------------------------------------------------------------------- + closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> IO VFS closeVFS vfs (J.NotificationMessage _ _ params) = do let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params @@ -159,5 +182,60 @@ where (before, after) = Rope.splitAt start str after' = Rope.drop len after + +-- --------------------------------------------------------------------- + +-- TODO:AZ:move this to somewhere sane +-- | Describes the line at the current cursor position +data PosPrefixInfo = PosPrefixInfo + { fullLine :: T.Text + -- ^ The full contents of the line the cursor is at + + , prefixModule :: T.Text + -- ^ If any, the module name that was typed right before the cursor position. + -- For example, if the user has typed "Data.Maybe.from", then this property + -- will be "Data.Maybe" + + , prefixText :: T.Text + -- ^ The word right before the cursor position, after removing the module part. + -- For example if the user has typed "Data.Maybe.from", + -- then this property will be "from" + , cursorPos :: J.Position + -- ^ The cursor position + } deriving (Show,Eq) + +getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo) +getCompletionPrefix pos@(J.Position l c) (VirtualFile _ yitext _) = + return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad + let headMaybe [] = Nothing + headMaybe (x:_) = Just x + lastMaybe [] = Nothing + lastMaybe xs = Just $ last xs + + curLine <- headMaybe $ T.lines $ Rope.toText + $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine l yitext + let beforePos = T.take c curLine + curWord <- case T.last beforePos of + ' ' -> return "" -- don't count abc as the curword in 'abc ' + _ -> lastMaybe (T.words beforePos) + + let parts = T.split (=='.') + $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord + case reverse parts of + [] -> Nothing + (x:xs) -> do + let modParts = dropWhile (not . isUpper . T.head) + $ reverse $ filter (not .T.null) xs + modName = T.intercalate "." modParts + return $ PosPrefixInfo curLine modName x pos + +-- --------------------------------------------------------------------- + +rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text +rangeLinesFromVfs (VirtualFile _ yitext _) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r + where + (_ ,s1) = Rope.splitAtLine lf yitext + (s2, _) = Rope.splitAtLine (lt - lf) s1 + r = Rope.toText s2 -- --------------------------------------------------------------------- diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs --- a/test/JsonSpec.hs +++ b/test/JsonSpec.hs @@ -59,7 +59,7 @@ instance Arbitrary HoverContents where arbitrary = oneof [ HoverContentsMS <$> arbitrary , HoverContents <$> arbitrary - , pure HoverContentsEmpty] + ] -- | make lists of maximum length 3 for test performance smallList :: Gen a -> Gen [a] diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -6,6 +6,7 @@ import qualified Data.Rope.UTF16 as Rope import Language.Haskell.LSP.VFS import qualified Language.Haskell.LSP.Types as J +import qualified Data.Text as T import Test.Hspec @@ -29,6 +30,9 @@ mkRange :: Int -> Int -> Int -> Int -> Maybe J.Range mkRange ls cs le ce = Just $ J.Range (J.Position ls cs) (J.Position le ce) +vfsFromText :: T.Text -> VirtualFile +vfsFromText text = VirtualFile 0 (Rope.fromText text) Nothing + -- --------------------------------------------------------------------- vspSpec :: Spec @@ -266,3 +270,55 @@ [ "a𐐀b" , "𐐀𐐀b" ] + + -- --------------------------------- + + describe "LSP utilities" $ do + it "splits at a line" $ do + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + (left,right) = Rope.splitAtLine 4 (fromString orig) + + lines (Rope.toString left) `shouldBe` + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + lines (Rope.toString right) `shouldBe` + [ "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + + -- --------------------------------- + + it "getCompletionPrefix" $ do + let + orig = T.unlines + [ "{-# ings #-}" + , "import Data.List" + ] + pp4 <- getCompletionPrefix (J.Position 0 4) (vfsFromText orig) + pp4 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 4)) + + pp5 <- getCompletionPrefix (J.Position 0 5) (vfsFromText orig) + pp5 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "i" (J.Position 0 5)) + + pp6 <- getCompletionPrefix (J.Position 0 6) (vfsFromText orig) + pp6 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "in" (J.Position 0 6)) + + pp14 <- getCompletionPrefix (J.Position 1 14) (vfsFromText orig) + pp14 `shouldBe` Just (PosPrefixInfo "import Data.List" "Data" "Li" (J.Position 1 14))