{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module Language.LSP.VFS
(
VFS(..)
, VirtualFile(..)
, virtualFileText
, virtualFileVersion
, initVFS
, openVFS
, changeFromClientVFS
, changeFromServerVFS
, persistFileVFS
, closeVFS
, updateVFS
, rangeLinesFromVfs
, PosPrefixInfo(..)
, getCompletionPrefix
, applyChanges
, applyChange
, changeChars
) where
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.Int (Int32)
import Data.List
import Data.Ord
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Rope.UTF16 ( Rope )
import qualified Data.Rope.UTF16 as Rope
import qualified Language.LSP.Types as J
import qualified Language.LSP.Types.Lens as J
import System.FilePath
import Data.Hashable
import System.Directory
import System.IO
import System.IO.Temp
import System.Log.Logger
{-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
{-# ANN module ("hlint: ignore Redundant do" :: String) #-}
data VirtualFile =
VirtualFile {
VirtualFile -> Int32
_lsp_version :: !Int32
, VirtualFile -> Int
_file_version :: !Int
, VirtualFile -> Rope
_text :: !Rope
} deriving (Int -> VirtualFile -> ShowS
[VirtualFile] -> ShowS
VirtualFile -> String
(Int -> VirtualFile -> ShowS)
-> (VirtualFile -> String)
-> ([VirtualFile] -> ShowS)
-> Show VirtualFile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VirtualFile] -> ShowS
$cshowList :: [VirtualFile] -> ShowS
show :: VirtualFile -> String
$cshow :: VirtualFile -> String
showsPrec :: Int -> VirtualFile -> ShowS
$cshowsPrec :: Int -> VirtualFile -> ShowS
Show)
type VFSMap = Map.Map J.NormalizedUri VirtualFile
data VFS = VFS { VFS -> Map NormalizedUri VirtualFile
vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)
, VFS -> String
vfsTempDir :: !FilePath
} deriving Int -> VFS -> ShowS
[VFS] -> ShowS
VFS -> String
(Int -> VFS -> ShowS)
-> (VFS -> String) -> ([VFS] -> ShowS) -> Show VFS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VFS] -> ShowS
$cshowList :: [VFS] -> ShowS
show :: VFS -> String
$cshow :: VFS -> String
showsPrec :: Int -> VFS -> ShowS
$cshowsPrec :: Int -> VFS -> ShowS
Show
virtualFileText :: VirtualFile -> Text
virtualFileText :: VirtualFile -> Text
virtualFileText VirtualFile
vf = Rope -> Text
Rope.toText (VirtualFile -> Rope
_text VirtualFile
vf)
virtualFileVersion :: VirtualFile -> Int32
virtualFileVersion :: VirtualFile -> Int32
virtualFileVersion VirtualFile
vf = VirtualFile -> Int32
_lsp_version VirtualFile
vf
initVFS :: (VFS -> IO r) -> IO r
initVFS :: (VFS -> IO r) -> IO r
initVFS VFS -> IO r
k = String -> (String -> IO r) -> IO r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"haskell-lsp" ((String -> IO r) -> IO r) -> (String -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \String
temp_dir -> VFS -> IO r
k (Map NormalizedUri VirtualFile -> String -> VFS
VFS Map NormalizedUri VirtualFile
forall a. Monoid a => a
mempty String
temp_dir)
openVFS :: VFS -> J.Message 'J.TextDocumentDidOpen -> (VFS, [String])
openVFS :: VFS -> Message 'TextDocumentDidOpen -> (VFS, [String])
openVFS VFS
vfs (J.NotificationMessage _ _ params) =
let J.DidOpenTextDocumentParams
(J.TextDocumentItem Uri
uri Text
_ Int32
version Text
text) = DidOpenTextDocumentParams
MessageParams 'TextDocumentDidOpen
params
in ((Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS (NormalizedUri
-> VirtualFile
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Uri -> NormalizedUri
J.toNormalizedUri Uri
uri) (Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
version Int
0 (Text -> Rope
Rope.fromText Text
text))) VFS
vfs
, [])
changeFromClientVFS :: VFS -> J.Message 'J.TextDocumentDidChange -> (VFS,[String])
changeFromClientVFS :: VFS -> Message 'TextDocumentDidChange -> (VFS, [String])
changeFromClientVFS VFS
vfs (J.NotificationMessage _ _ params) =
let
J.DidChangeTextDocumentParams VersionedTextDocumentIdentifier
vid (J.List [TextDocumentContentChangeEvent]
changes) = DidChangeTextDocumentParams
MessageParams 'TextDocumentDidChange
params
J.VersionedTextDocumentIdentifier (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) TextDocumentVersion
version = VersionedTextDocumentIdentifier
vid
in
case NormalizedUri -> Map NormalizedUri VirtualFile -> Maybe VirtualFile
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalizedUri
uri (VFS -> Map NormalizedUri VirtualFile
vfsMap VFS
vfs) of
Just (VirtualFile Int32
_ Int
file_ver Rope
str) ->
let str' :: Rope
str' = Rope -> [TextDocumentContentChangeEvent] -> Rope
applyChanges Rope
str [TextDocumentContentChangeEvent]
changes
in ((Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS (NormalizedUri
-> VirtualFile
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NormalizedUri
uri (Int32 -> Int -> Rope -> VirtualFile
VirtualFile (Int32 -> TextDocumentVersion -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 TextDocumentVersion
version) (Int
file_ver Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Rope
str')) VFS
vfs, [])
Maybe VirtualFile
Nothing ->
(VFS
vfs, [String
"haskell-lsp:changeVfs:can't find uri:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedUri -> String
forall a. Show a => a -> String
show NormalizedUri
uri])
updateVFS :: (VFSMap -> VFSMap) -> VFS -> VFS
updateVFS :: (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile
f vfs :: VFS
vfs@VFS{Map NormalizedUri VirtualFile
vfsMap :: Map NormalizedUri VirtualFile
$sel:vfsMap:VFS :: VFS -> Map NormalizedUri VirtualFile
vfsMap} = VFS
vfs { $sel:vfsMap:VFS :: Map NormalizedUri VirtualFile
vfsMap = Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile
f Map NormalizedUri VirtualFile
vfsMap }
applyCreateFile :: J.CreateFile -> VFS -> VFS
applyCreateFile :: CreateFile -> VFS -> VFS
applyCreateFile (J.CreateFile Uri
uri Maybe CreateFileOptions
options Maybe ChangeAnnotationIdentifier
_ann) =
(Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS ((Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS)
-> (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS
-> VFS
forall a b. (a -> b) -> a -> b
$ (VirtualFile -> VirtualFile -> VirtualFile)
-> NormalizedUri
-> VirtualFile
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith
(\ VirtualFile
new VirtualFile
old -> if Bool
shouldOverwrite then VirtualFile
new else VirtualFile
old)
(Uri -> NormalizedUri
J.toNormalizedUri Uri
uri)
(Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
0 Int
0 (Text -> Rope
Rope.fromText Text
""))
where
shouldOverwrite :: Bool
shouldOverwrite :: Bool
shouldOverwrite = case Maybe CreateFileOptions
options of
Maybe CreateFileOptions
Nothing -> Bool
False
Just (J.CreateFileOptions Maybe Bool
Nothing Maybe Bool
Nothing ) -> Bool
False
Just (J.CreateFileOptions Maybe Bool
Nothing (Just Bool
True) ) -> Bool
False
Just (J.CreateFileOptions Maybe Bool
Nothing (Just Bool
False)) -> Bool
True
Just (J.CreateFileOptions (Just Bool
True) Maybe Bool
Nothing ) -> Bool
True
Just (J.CreateFileOptions (Just Bool
True) (Just Bool
True) ) -> Bool
True
Just (J.CreateFileOptions (Just Bool
True) (Just Bool
False)) -> Bool
True
Just (J.CreateFileOptions (Just Bool
False) Maybe Bool
Nothing ) -> Bool
False
Just (J.CreateFileOptions (Just Bool
False) (Just Bool
True) ) -> Bool
False
Just (J.CreateFileOptions (Just Bool
False) (Just Bool
False)) -> Bool
False
applyRenameFile :: J.RenameFile -> VFS -> VFS
applyRenameFile :: RenameFile -> VFS -> VFS
applyRenameFile (J.RenameFile Uri
oldUri' Uri
newUri' Maybe RenameFileOptions
options Maybe ChangeAnnotationIdentifier
_ann) VFS
vfs =
let oldUri :: NormalizedUri
oldUri = Uri -> NormalizedUri
J.toNormalizedUri Uri
oldUri'
newUri :: NormalizedUri
newUri = Uri -> NormalizedUri
J.toNormalizedUri Uri
newUri'
in case NormalizedUri -> Map NormalizedUri VirtualFile -> Maybe VirtualFile
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalizedUri
oldUri (VFS -> Map NormalizedUri VirtualFile
vfsMap VFS
vfs) of
Maybe VirtualFile
Nothing -> VFS
vfs
Just VirtualFile
file -> case NormalizedUri -> Map NormalizedUri VirtualFile -> Maybe VirtualFile
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalizedUri
newUri (VFS -> Map NormalizedUri VirtualFile
vfsMap VFS
vfs) of
Maybe VirtualFile
Nothing -> (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS (NormalizedUri
-> VirtualFile
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NormalizedUri
newUri VirtualFile
file (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri
-> Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NormalizedUri
oldUri) VFS
vfs
Just VirtualFile
_ -> if Bool
shouldOverwrite
then (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS (NormalizedUri
-> VirtualFile
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NormalizedUri
newUri VirtualFile
file (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri
-> Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NormalizedUri
oldUri) VFS
vfs
else VFS
vfs
where
shouldOverwrite :: Bool
shouldOverwrite :: Bool
shouldOverwrite = case Maybe RenameFileOptions
options of
Maybe RenameFileOptions
Nothing -> Bool
False
Just (J.RenameFileOptions Maybe Bool
Nothing Maybe Bool
Nothing ) -> Bool
False
Just (J.RenameFileOptions Maybe Bool
Nothing (Just Bool
True) ) -> Bool
False
Just (J.RenameFileOptions Maybe Bool
Nothing (Just Bool
False)) -> Bool
True
Just (J.RenameFileOptions (Just Bool
True) Maybe Bool
Nothing ) -> Bool
True
Just (J.RenameFileOptions (Just Bool
True) (Just Bool
True) ) -> Bool
True
Just (J.RenameFileOptions (Just Bool
True) (Just Bool
False)) -> Bool
True
Just (J.RenameFileOptions (Just Bool
False) Maybe Bool
Nothing ) -> Bool
False
Just (J.RenameFileOptions (Just Bool
False) (Just Bool
True) ) -> Bool
False
Just (J.RenameFileOptions (Just Bool
False) (Just Bool
False)) -> Bool
False
applyDeleteFile :: J.DeleteFile -> VFS -> VFS
applyDeleteFile :: DeleteFile -> VFS -> VFS
applyDeleteFile (J.DeleteFile Uri
uri Maybe DeleteFileOptions
_options Maybe ChangeAnnotationIdentifier
_ann) =
(Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS ((Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS)
-> (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS
-> VFS
forall a b. (a -> b) -> a -> b
$ NormalizedUri
-> Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Uri -> NormalizedUri
J.toNormalizedUri Uri
uri)
applyTextDocumentEdit :: J.TextDocumentEdit -> VFS -> IO VFS
applyTextDocumentEdit :: TextDocumentEdit -> VFS -> IO VFS
applyTextDocumentEdit (J.TextDocumentEdit VersionedTextDocumentIdentifier
vid (J.List [TextEdit |? AnnotatedTextEdit]
edits)) VFS
vfs = do
let sortedEdits :: [TextEdit |? AnnotatedTextEdit]
sortedEdits = ((TextEdit |? AnnotatedTextEdit) -> Down Range)
-> [TextEdit |? AnnotatedTextEdit]
-> [TextEdit |? AnnotatedTextEdit]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Range -> Down Range
forall a. a -> Down a
Down (Range -> Down Range)
-> ((TextEdit |? AnnotatedTextEdit) -> Range)
-> (TextEdit |? AnnotatedTextEdit)
-> Down Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextEdit |? AnnotatedTextEdit) -> Range
editRange) [TextEdit |? AnnotatedTextEdit]
edits
changeEvents :: [TextDocumentContentChangeEvent]
changeEvents = ((TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent)
-> [TextEdit |? AnnotatedTextEdit]
-> [TextDocumentContentChangeEvent]
forall a b. (a -> b) -> [a] -> [b]
map (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent [TextEdit |? AnnotatedTextEdit]
sortedEdits
ps :: DidChangeTextDocumentParams
ps = VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> DidChangeTextDocumentParams
J.DidChangeTextDocumentParams VersionedTextDocumentIdentifier
vid ([TextDocumentContentChangeEvent]
-> List TextDocumentContentChangeEvent
forall a. [a] -> List a
J.List [TextDocumentContentChangeEvent]
changeEvents)
notif :: NotificationMessage 'TextDocumentDidChange
notif = Text
-> SMethod 'TextDocumentDidChange
-> MessageParams 'TextDocumentDidChange
-> NotificationMessage 'TextDocumentDidChange
forall (f :: From) (m :: Method f 'Notification).
Text -> SMethod m -> MessageParams m -> NotificationMessage m
J.NotificationMessage Text
"" SMethod 'TextDocumentDidChange
J.STextDocumentDidChange DidChangeTextDocumentParams
MessageParams 'TextDocumentDidChange
ps
let (VFS
vfs',[String]
ls) = VFS -> Message 'TextDocumentDidChange -> (VFS, [String])
changeFromClientVFS VFS
vfs NotificationMessage 'TextDocumentDidChange
Message 'TextDocumentDidChange
notif
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> IO ()
debugM String
"haskell-lsp.applyTextDocumentEdit") [String]
ls
VFS -> IO VFS
forall (m :: * -> *) a. Monad m => a -> m a
return VFS
vfs'
where
editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range
editRange :: (TextEdit |? AnnotatedTextEdit) -> Range
editRange (J.InR AnnotatedTextEdit
e) = AnnotatedTextEdit
e AnnotatedTextEdit -> Getting Range AnnotatedTextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range AnnotatedTextEdit Range
forall s a. HasRange s a => Lens' s a
J.range
editRange (J.InL TextEdit
e) = TextEdit
e TextEdit -> Getting Range TextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range TextEdit Range
forall s a. HasRange s a => Lens' s a
J.range
editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent
editToChangeEvent :: (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent (J.InR AnnotatedTextEdit
e) = Maybe Range -> Maybe UInt -> Text -> TextDocumentContentChangeEvent
J.TextDocumentContentChangeEvent (Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ AnnotatedTextEdit
e AnnotatedTextEdit -> Getting Range AnnotatedTextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range AnnotatedTextEdit Range
forall s a. HasRange s a => Lens' s a
J.range) Maybe UInt
forall a. Maybe a
Nothing (AnnotatedTextEdit
e AnnotatedTextEdit -> Getting Text AnnotatedTextEdit Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text AnnotatedTextEdit Text
forall s a. HasNewText s a => Lens' s a
J.newText)
editToChangeEvent (J.InL TextEdit
e) = Maybe Range -> Maybe UInt -> Text -> TextDocumentContentChangeEvent
J.TextDocumentContentChangeEvent (Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ TextEdit
e TextEdit -> Getting Range TextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range TextEdit Range
forall s a. HasRange s a => Lens' s a
J.range) Maybe UInt
forall a. Maybe a
Nothing (TextEdit
e TextEdit -> Getting Text TextEdit Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text TextEdit Text
forall s a. HasNewText s a => Lens' s a
J.newText)
applyDocumentChange :: J.DocumentChange -> VFS -> IO VFS
applyDocumentChange :: DocumentChange -> VFS -> IO VFS
applyDocumentChange (J.InL TextDocumentEdit
change) = TextDocumentEdit -> VFS -> IO VFS
applyTextDocumentEdit TextDocumentEdit
change
applyDocumentChange (J.InR (J.InL CreateFile
change)) = VFS -> IO VFS
forall (m :: * -> *) a. Monad m => a -> m a
return (VFS -> IO VFS) -> (VFS -> VFS) -> VFS -> IO VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateFile -> VFS -> VFS
applyCreateFile CreateFile
change
applyDocumentChange (J.InR (J.InR (J.InL RenameFile
change))) = VFS -> IO VFS
forall (m :: * -> *) a. Monad m => a -> m a
return (VFS -> IO VFS) -> (VFS -> VFS) -> VFS -> IO VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenameFile -> VFS -> VFS
applyRenameFile RenameFile
change
applyDocumentChange (J.InR (J.InR (J.InR DeleteFile
change))) = VFS -> IO VFS
forall (m :: * -> *) a. Monad m => a -> m a
return (VFS -> IO VFS) -> (VFS -> VFS) -> VFS -> IO VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeleteFile -> VFS -> VFS
applyDeleteFile DeleteFile
change
changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS
changeFromServerVFS :: VFS -> Message 'WorkspaceApplyEdit -> IO VFS
changeFromServerVFS VFS
initVfs (J.RequestMessage _ _ _ params) = do
let J.ApplyWorkspaceEditParams Maybe Text
_label WorkspaceEdit
edit = ApplyWorkspaceEditParams
MessageParams 'WorkspaceApplyEdit
params
J.WorkspaceEdit Maybe WorkspaceEditMap
mChanges Maybe (List DocumentChange)
mDocChanges Maybe ChangeAnnotationMap
_anns = WorkspaceEdit
edit
case Maybe (List DocumentChange)
mDocChanges of
Just (J.List [DocumentChange]
docChanges) -> [DocumentChange] -> IO VFS
applyDocumentChanges [DocumentChange]
docChanges
Maybe (List DocumentChange)
Nothing -> case Maybe WorkspaceEditMap
mChanges of
Just WorkspaceEditMap
cs -> [DocumentChange] -> IO VFS
applyDocumentChanges ([DocumentChange] -> IO VFS) -> [DocumentChange] -> IO VFS
forall a b. (a -> b) -> a -> b
$ (TextDocumentEdit -> DocumentChange)
-> [TextDocumentEdit] -> [DocumentChange]
forall a b. (a -> b) -> [a] -> [b]
map TextDocumentEdit -> DocumentChange
forall a b. a -> a |? b
J.InL ([TextDocumentEdit] -> [DocumentChange])
-> [TextDocumentEdit] -> [DocumentChange]
forall a b. (a -> b) -> a -> b
$ ([TextDocumentEdit] -> Uri -> List TextEdit -> [TextDocumentEdit])
-> [TextDocumentEdit] -> WorkspaceEditMap -> [TextDocumentEdit]
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HashMap.foldlWithKey' [TextDocumentEdit] -> Uri -> List TextEdit -> [TextDocumentEdit]
changeToTextDocumentEdit [] WorkspaceEditMap
cs
Maybe WorkspaceEditMap
Nothing -> do
String -> String -> IO ()
debugM String
"haskell-lsp.changeVfs" String
"No changes"
VFS -> IO VFS
forall (m :: * -> *) a. Monad m => a -> m a
return VFS
initVfs
where
changeToTextDocumentEdit :: [TextDocumentEdit] -> Uri -> List TextEdit -> [TextDocumentEdit]
changeToTextDocumentEdit [TextDocumentEdit]
acc Uri
uri List TextEdit
edits =
[TextDocumentEdit]
acc [TextDocumentEdit] -> [TextDocumentEdit] -> [TextDocumentEdit]
forall a. [a] -> [a] -> [a]
++ [VersionedTextDocumentIdentifier
-> List (TextEdit |? AnnotatedTextEdit) -> TextDocumentEdit
J.TextDocumentEdit (Uri -> TextDocumentVersion -> VersionedTextDocumentIdentifier
J.VersionedTextDocumentIdentifier Uri
uri (Int32 -> TextDocumentVersion
forall a. a -> Maybe a
Just Int32
0)) ((TextEdit -> TextEdit |? AnnotatedTextEdit)
-> List TextEdit -> List (TextEdit |? AnnotatedTextEdit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEdit -> TextEdit |? AnnotatedTextEdit
forall a b. a -> a |? b
J.InL List TextEdit
edits)]
applyDocumentChanges :: [J.DocumentChange] -> IO VFS
applyDocumentChanges :: [DocumentChange] -> IO VFS
applyDocumentChanges = (VFS -> DocumentChange -> IO VFS)
-> VFS -> [DocumentChange] -> IO VFS
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((DocumentChange -> VFS -> IO VFS)
-> VFS -> DocumentChange -> IO VFS
forall a b c. (a -> b -> c) -> b -> a -> c
flip DocumentChange -> VFS -> IO VFS
applyDocumentChange) VFS
initVfs ([DocumentChange] -> IO VFS)
-> ([DocumentChange] -> [DocumentChange])
-> [DocumentChange]
-> IO VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocumentChange -> TextDocumentVersion)
-> [DocumentChange] -> [DocumentChange]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn DocumentChange -> TextDocumentVersion
project
project :: J.DocumentChange -> J.TextDocumentVersion
project :: DocumentChange -> TextDocumentVersion
project (J.InL TextDocumentEdit
textDocumentEdit) = TextDocumentEdit
textDocumentEdit TextDocumentEdit
-> Getting TextDocumentVersion TextDocumentEdit TextDocumentVersion
-> TextDocumentVersion
forall s a. s -> Getting a s a -> a
^. (VersionedTextDocumentIdentifier
-> Const TextDocumentVersion VersionedTextDocumentIdentifier)
-> TextDocumentEdit -> Const TextDocumentVersion TextDocumentEdit
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((VersionedTextDocumentIdentifier
-> Const TextDocumentVersion VersionedTextDocumentIdentifier)
-> TextDocumentEdit -> Const TextDocumentVersion TextDocumentEdit)
-> ((TextDocumentVersion
-> Const TextDocumentVersion TextDocumentVersion)
-> VersionedTextDocumentIdentifier
-> Const TextDocumentVersion VersionedTextDocumentIdentifier)
-> Getting TextDocumentVersion TextDocumentEdit TextDocumentVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentVersion
-> Const TextDocumentVersion TextDocumentVersion)
-> VersionedTextDocumentIdentifier
-> Const TextDocumentVersion VersionedTextDocumentIdentifier
forall s a. HasVersion s a => Lens' s a
J.version
project DocumentChange
_ = TextDocumentVersion
forall a. Maybe a
Nothing
virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath
virtualFileName :: String -> NormalizedUri -> VirtualFile -> String
virtualFileName String
prefix NormalizedUri
uri (VirtualFile Int32
_ Int
file_ver Rope
_) =
let uri_raw :: Uri
uri_raw = NormalizedUri -> Uri
J.fromNormalizedUri NormalizedUri
uri
basename :: String
basename = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ShowS
takeFileName (Uri -> Maybe String
J.uriToFilePath Uri
uri_raw)
padLeft :: Int -> Int -> String
padLeft :: Int -> Int -> String
padLeft Int
n Int
num =
let numString :: String
numString = Int -> String
forall a. Show a => a -> String
show Int
num
in Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
numString) Char
'0' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
numString
in String
prefix String -> ShowS
</> String
basename String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Int -> String
padLeft Int
5 Int
file_ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Uri -> Int
forall a. Hashable a => a -> Int
hash Uri
uri_raw) String -> ShowS
<.> ShowS
takeExtensions String
basename
persistFileVFS :: VFS -> J.NormalizedUri -> Maybe (FilePath, IO ())
persistFileVFS :: VFS -> NormalizedUri -> Maybe (String, IO ())
persistFileVFS VFS
vfs NormalizedUri
uri =
case NormalizedUri -> Map NormalizedUri VirtualFile -> Maybe VirtualFile
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalizedUri
uri (VFS -> Map NormalizedUri VirtualFile
vfsMap VFS
vfs) of
Maybe VirtualFile
Nothing -> Maybe (String, IO ())
forall a. Maybe a
Nothing
Just VirtualFile
vf ->
let tfn :: String
tfn = String -> NormalizedUri -> VirtualFile -> String
virtualFileName (VFS -> String
vfsTempDir VFS
vfs) NormalizedUri
uri VirtualFile
vf
action :: IO ()
action = do
Bool
exists <- String -> IO Bool
doesFileExist String
tfn
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let contents :: String
contents = Rope -> String
Rope.toString (VirtualFile -> Rope
_text VirtualFile
vf)
writeRaw :: Handle -> IO ()
writeRaw Handle
h = do
Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
noNewlineTranslation
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
Handle -> String -> IO ()
hPutStr Handle
h String
contents
String -> String -> IO ()
debugM String
"haskell-lsp.persistFileVFS" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Writing virtual file: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"uri = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedUri -> String
forall a. Show a => a -> String
show NormalizedUri
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", virtual file = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
tfn
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tfn IOMode
WriteMode Handle -> IO ()
writeRaw
in (String, IO ()) -> Maybe (String, IO ())
forall a. a -> Maybe a
Just (String
tfn, IO ()
action)
closeVFS :: VFS -> J.Message 'J.TextDocumentDidClose -> (VFS, [String])
closeVFS :: VFS -> Message 'TextDocumentDidClose -> (VFS, [String])
closeVFS VFS
vfs (J.NotificationMessage _ _ params) =
let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier Uri
uri) = DidCloseTextDocumentParams
MessageParams 'TextDocumentDidClose
params
in ((Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> VFS -> VFS
updateVFS (NormalizedUri
-> Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Uri -> NormalizedUri
J.toNormalizedUri Uri
uri)) VFS
vfs,[String
"Closed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri])
applyChanges :: Rope -> [J.TextDocumentContentChangeEvent] -> Rope
applyChanges :: Rope -> [TextDocumentContentChangeEvent] -> Rope
applyChanges = (Rope -> TextDocumentContentChangeEvent -> Rope)
-> Rope -> [TextDocumentContentChangeEvent] -> Rope
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Rope -> TextDocumentContentChangeEvent -> Rope
applyChange
applyChange :: Rope -> J.TextDocumentContentChangeEvent -> Rope
applyChange :: Rope -> TextDocumentContentChangeEvent -> Rope
applyChange Rope
_ (J.TextDocumentContentChangeEvent Maybe Range
Nothing Maybe UInt
Nothing Text
str)
= Text -> Rope
Rope.fromText Text
str
applyChange Rope
str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position UInt
sl UInt
sc) Position
_to)) (Just UInt
len) Text
txt)
= Rope -> Int -> Int -> Text -> Rope
changeChars Rope
str Int
start (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
len) Text
txt
where
start :: Int
start = RowColumn -> Rope -> Int
Rope.rowColumnCodeUnits (Int -> Int -> RowColumn
Rope.RowColumn (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sl) (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sc)) Rope
str
applyChange Rope
str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position UInt
sl UInt
sc) (J.Position UInt
el UInt
ec))) Maybe UInt
Nothing Text
txt)
= Rope -> Int -> Int -> Text -> Rope
changeChars Rope
str Int
start Int
len Text
txt
where
start :: Int
start = RowColumn -> Rope -> Int
Rope.rowColumnCodeUnits (Int -> Int -> RowColumn
Rope.RowColumn (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sl) (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sc)) Rope
str
end :: Int
end = RowColumn -> Rope -> Int
Rope.rowColumnCodeUnits (Int -> Int -> RowColumn
Rope.RowColumn (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
el) (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
ec)) Rope
str
len :: Int
len = Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start
applyChange Rope
str (J.TextDocumentContentChangeEvent Maybe Range
Nothing (Just UInt
_) Text
_txt)
= Rope
str
changeChars :: Rope -> Int -> Int -> Text -> Rope
changeChars :: Rope -> Int -> Int -> Text -> Rope
changeChars Rope
str Int
start Int
len Text
new = [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat [Rope
before, Text -> Rope
Rope.fromText Text
new, Rope
after']
where
(Rope
before, Rope
after) = Int -> Rope -> (Rope, Rope)
Rope.splitAt Int
start Rope
str
after' :: Rope
after' = Int -> Rope -> Rope
Rope.drop Int
len Rope
after
data PosPrefixInfo = PosPrefixInfo
{ PosPrefixInfo -> Text
fullLine :: !T.Text
, PosPrefixInfo -> Text
prefixModule :: !T.Text
, PosPrefixInfo -> Text
prefixText :: !T.Text
, PosPrefixInfo -> Position
cursorPos :: !J.Position
} deriving (Int -> PosPrefixInfo -> ShowS
[PosPrefixInfo] -> ShowS
PosPrefixInfo -> String
(Int -> PosPrefixInfo -> ShowS)
-> (PosPrefixInfo -> String)
-> ([PosPrefixInfo] -> ShowS)
-> Show PosPrefixInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PosPrefixInfo] -> ShowS
$cshowList :: [PosPrefixInfo] -> ShowS
show :: PosPrefixInfo -> String
$cshow :: PosPrefixInfo -> String
showsPrec :: Int -> PosPrefixInfo -> ShowS
$cshowsPrec :: Int -> PosPrefixInfo -> ShowS
Show,PosPrefixInfo -> PosPrefixInfo -> Bool
(PosPrefixInfo -> PosPrefixInfo -> Bool)
-> (PosPrefixInfo -> PosPrefixInfo -> Bool) -> Eq PosPrefixInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PosPrefixInfo -> PosPrefixInfo -> Bool
$c/= :: PosPrefixInfo -> PosPrefixInfo -> Bool
== :: PosPrefixInfo -> PosPrefixInfo -> Bool
$c== :: PosPrefixInfo -> PosPrefixInfo -> Bool
Eq)
getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo)
getCompletionPrefix :: Position -> VirtualFile -> m (Maybe PosPrefixInfo)
getCompletionPrefix pos :: Position
pos@(J.Position UInt
l UInt
c) (VirtualFile Int32
_ Int
_ Rope
ropetext) =
Maybe PosPrefixInfo -> m (Maybe PosPrefixInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PosPrefixInfo -> m (Maybe PosPrefixInfo))
-> Maybe PosPrefixInfo -> m (Maybe PosPrefixInfo)
forall a b. (a -> b) -> a -> b
$ PosPrefixInfo -> Maybe PosPrefixInfo
forall a. a -> Maybe a
Just (PosPrefixInfo -> Maybe PosPrefixInfo)
-> PosPrefixInfo -> Maybe PosPrefixInfo
forall a b. (a -> b) -> a -> b
$ PosPrefixInfo -> Maybe PosPrefixInfo -> PosPrefixInfo
forall a. a -> Maybe a -> a
fromMaybe (Text -> Text -> Text -> Position -> PosPrefixInfo
PosPrefixInfo Text
"" Text
"" Text
"" Position
pos) (Maybe PosPrefixInfo -> PosPrefixInfo)
-> Maybe PosPrefixInfo -> PosPrefixInfo
forall a b. (a -> b) -> a -> b
$ do
let headMaybe :: [a] -> Maybe a
headMaybe [] = Maybe a
forall a. Maybe a
Nothing
headMaybe (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Maybe a
forall a. Maybe a
Nothing
lastMaybe [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
last [a]
xs
Text
curLine <- [Text] -> Maybe Text
forall a. [a] -> Maybe a
headMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Rope -> Text
Rope.toText
(Rope -> Text) -> Rope -> Text
forall a b. (a -> b) -> a -> b
$ (Rope, Rope) -> Rope
forall a b. (a, b) -> a
fst ((Rope, Rope) -> Rope) -> (Rope, Rope) -> Rope
forall a b. (a -> b) -> a -> b
$ Int -> Rope -> (Rope, Rope)
Rope.splitAtLine Int
1 (Rope -> (Rope, Rope)) -> Rope -> (Rope, Rope)
forall a b. (a -> b) -> a -> b
$ (Rope, Rope) -> Rope
forall a b. (a, b) -> b
snd ((Rope, Rope) -> Rope) -> (Rope, Rope) -> Rope
forall a b. (a -> b) -> a -> b
$ Int -> Rope -> (Rope, Rope)
Rope.splitAtLine (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l) Rope
ropetext
let beforePos :: Text
beforePos = Int -> Text -> Text
T.take (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
c) Text
curLine
Text
curWord <-
if | Text -> Bool
T.null Text
beforePos -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
| Text -> Char
T.last Text
beforePos Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
| Bool
otherwise -> [Text] -> Maybe Text
forall a. [a] -> Maybe a
lastMaybe (Text -> [Text]
T.words Text
beforePos)
let parts :: [Text]
parts = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.')
(Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd (\Char
x -> Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"._'"::String)) Text
curWord
case [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
parts of
[] -> Maybe PosPrefixInfo
forall a. Maybe a
Nothing
(Text
x:[Text]
xs) -> do
let modParts :: [Text]
modParts = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper (Char -> Bool) -> (Text -> Char) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head)
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Text -> Bool
T.null) [Text]
xs
modName :: Text
modName = Text -> [Text] -> Text
T.intercalate Text
"." [Text]
modParts
PosPrefixInfo -> Maybe PosPrefixInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (PosPrefixInfo -> Maybe PosPrefixInfo)
-> PosPrefixInfo -> Maybe PosPrefixInfo
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Position -> PosPrefixInfo
PosPrefixInfo Text
curLine Text
modName Text
x Position
pos
rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text
rangeLinesFromVfs :: VirtualFile -> Range -> Text
rangeLinesFromVfs (VirtualFile Int32
_ Int
_ Rope
ropetext) (J.Range (J.Position UInt
lf UInt
_cf) (J.Position UInt
lt UInt
_ct)) = Text
r
where
(Rope
_ ,Rope
s1) = Int -> Rope -> (Rope, Rope)
Rope.splitAtLine (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
lf) Rope
ropetext
(Rope
s2, Rope
_) = Int -> Rope -> (Rope, Rope)
Rope.splitAtLine (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt
lt UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
- UInt
lf)) Rope
s1
r :: Text
r = Rope -> Text
Rope.toText Rope
s2