{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ViewPatterns #-}
-- So we can keep using the old prettyprinter modules (which have a better
-- compatibility range) for now.
{-# OPTIONS_GHC -Wno-deprecations #-}

{- |
Handles the "Language.LSP.Types.TextDocumentDidChange" \/
"Language.LSP.Types.TextDocumentDidOpen" \/
"Language.LSP.Types.TextDocumentDidClose" messages to keep an in-memory
`filesystem` of the current client workspace.  The server can access and edit
files in the client workspace by operating on the "VFS" in "LspFuncs".
-}
module Language.LSP.VFS (
  VFS (..),
  vfsMap,
  VirtualFile (..),
  lsp_version,
  file_version,
  file_text,
  virtualFileText,
  virtualFileVersion,
  VfsLog (..),

  -- * Managing the VFS
  emptyVFS,
  openVFS,
  changeFromClientVFS,
  changeFromServerVFS,
  persistFileVFS,
  closeVFS,

  -- * Positions and transformations
  CodePointPosition (..),
  line,
  character,
  codePointPositionToPosition,
  positionToCodePointPosition,
  CodePointRange (..),
  start,
  end,
  codePointRangeToRange,
  rangeToCodePointRange,

  -- * manipulating the file contents
  rangeLinesFromVfs,

  -- * for tests
  applyChanges,
  applyChange,
  changeChars,
) where

import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
import Control.Lens hiding (parts, (<.>))
import Control.Monad
import Control.Monad.State
import Data.Foldable (traverse_)
import Data.Hashable
import Data.Int (Int32)
import Data.List
import Data.Map.Strict qualified as Map
import Data.Ord
import Data.Row
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Prettyprint.Doc hiding (line)
import Data.Text.Utf16.Lines as Utf16 (Position (..))
import Data.Text.Utf16.Rope.Mixed (Rope)
import Data.Text.Utf16.Rope.Mixed qualified as Rope
import Language.LSP.Protocol.Lens qualified as J
import Language.LSP.Protocol.Message qualified as J
import Language.LSP.Protocol.Types qualified as J
import System.Directory
import System.FilePath
import System.IO

-- ---------------------------------------------------------------------
{-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
{-# ANN module ("hlint: ignore Redundant do" :: String) #-}

-- ---------------------------------------------------------------------

data VirtualFile = VirtualFile
  { VirtualFile -> Int32
_lsp_version :: !Int32
  -- ^ The LSP version of the document
  , VirtualFile -> Int
_file_version :: !Int
  -- ^ This number is only incremented whilst the file
  -- remains in the map.
  , VirtualFile -> Rope
_file_text :: !Rope
  -- ^ The full contents of the document
  }
  deriving (Int -> VirtualFile -> ShowS
[VirtualFile] -> ShowS
VirtualFile -> [Char]
(Int -> VirtualFile -> ShowS)
-> (VirtualFile -> [Char])
-> ([VirtualFile] -> ShowS)
-> Show VirtualFile
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VirtualFile -> ShowS
showsPrec :: Int -> VirtualFile -> ShowS
$cshow :: VirtualFile -> [Char]
show :: VirtualFile -> [Char]
$cshowList :: [VirtualFile] -> ShowS
showList :: [VirtualFile] -> ShowS
Show)

data VFS = VFS
  { VFS -> Map NormalizedUri VirtualFile
_vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)
  }
  deriving (Int -> VFS -> ShowS
[VFS] -> ShowS
VFS -> [Char]
(Int -> VFS -> ShowS)
-> (VFS -> [Char]) -> ([VFS] -> ShowS) -> Show VFS
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VFS -> ShowS
showsPrec :: Int -> VFS -> ShowS
$cshow :: VFS -> [Char]
show :: VFS -> [Char]
$cshowList :: [VFS] -> ShowS
showList :: [VFS] -> ShowS
Show)

data VfsLog
  = SplitInsideCodePoint Utf16.Position Rope
  | URINotFound J.NormalizedUri
  | Opening J.NormalizedUri
  | Closing J.NormalizedUri
  | PersistingFile J.NormalizedUri FilePath
  | CantRecursiveDelete J.NormalizedUri
  | DeleteNonExistent J.NormalizedUri
  deriving (Int -> VfsLog -> ShowS
[VfsLog] -> ShowS
VfsLog -> [Char]
(Int -> VfsLog -> ShowS)
-> (VfsLog -> [Char]) -> ([VfsLog] -> ShowS) -> Show VfsLog
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VfsLog -> ShowS
showsPrec :: Int -> VfsLog -> ShowS
$cshow :: VfsLog -> [Char]
show :: VfsLog -> [Char]
$cshowList :: [VfsLog] -> ShowS
showList :: [VfsLog] -> ShowS
Show)

instance Pretty VfsLog where
  pretty :: forall ann. VfsLog -> Doc ann
pretty (SplitInsideCodePoint Position
pos Rope
r) =
    Doc ann
"VFS: asked to make change inside code point. Position" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Position
pos Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Rope -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Rope
r
  pretty (URINotFound NormalizedUri
uri) = Doc ann
"VFS: don't know about URI" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedUri -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. NormalizedUri -> Doc ann
pretty NormalizedUri
uri
  pretty (Opening NormalizedUri
uri) = Doc ann
"VFS: opening" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedUri -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. NormalizedUri -> Doc ann
pretty NormalizedUri
uri
  pretty (Closing NormalizedUri
uri) = Doc ann
"VFS: closing" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedUri -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. NormalizedUri -> Doc ann
pretty NormalizedUri
uri
  pretty (PersistingFile NormalizedUri
uri [Char]
fp) = Doc ann
"VFS: Writing virtual file for" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedUri -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. NormalizedUri -> Doc ann
pretty NormalizedUri
uri Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"to" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow [Char]
fp
  pretty (CantRecursiveDelete NormalizedUri
uri) =
    Doc ann
"VFS: can't recursively delete" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedUri -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. NormalizedUri -> Doc ann
pretty NormalizedUri
uri Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"because we don't track directory status"
  pretty (DeleteNonExistent NormalizedUri
uri) = Doc ann
"VFS: asked to delete non-existent file" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedUri -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. NormalizedUri -> Doc ann
pretty NormalizedUri
uri

makeFieldsNoPrefix ''VirtualFile
makeFieldsNoPrefix ''VFS

---

virtualFileText :: VirtualFile -> Text
virtualFileText :: VirtualFile -> Text
virtualFileText VirtualFile
vf = Rope -> Text
Rope.toText (VirtualFile -> Rope
_file_text VirtualFile
vf)

virtualFileVersion :: VirtualFile -> Int32
virtualFileVersion :: VirtualFile -> Int32
virtualFileVersion VirtualFile
vf = VirtualFile -> Int32
_lsp_version VirtualFile
vf

---

emptyVFS :: VFS
emptyVFS :: VFS
emptyVFS = Map NormalizedUri VirtualFile -> VFS
VFS Map NormalizedUri VirtualFile
forall a. Monoid a => a
mempty

-- ---------------------------------------------------------------------

-- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS'
openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidOpen -> m ()
openVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidOpen
-> m ()
openVFS LogAction m (WithSeverity VfsLog)
logger TMessage
  @'ClientToServer @'Notification 'Method_TextDocumentDidOpen
msg = do
  let J.TextDocumentItem (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) Text
_ Int32
version Text
text = TMessage
  @'ClientToServer @'Notification 'Method_TextDocumentDidOpen
TNotificationMessage @'ClientToServer 'Method_TextDocumentDidOpen
msg TNotificationMessage @'ClientToServer 'Method_TextDocumentDidOpen
-> Getting
     TextDocumentItem
     (TNotificationMessage @'ClientToServer 'Method_TextDocumentDidOpen)
     TextDocumentItem
-> TextDocumentItem
forall s a. s -> Getting a s a -> a
^. (DidOpenTextDocumentParams
 -> Const @(*) TextDocumentItem DidOpenTextDocumentParams)
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidOpen
-> Const
     @(*)
     TextDocumentItem
     (TNotificationMessage @'ClientToServer 'Method_TextDocumentDidOpen)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage @'ClientToServer 'Method_TextDocumentDidOpen)
  DidOpenTextDocumentParams
J.params ((DidOpenTextDocumentParams
  -> Const @(*) TextDocumentItem DidOpenTextDocumentParams)
 -> TNotificationMessage
      @'ClientToServer 'Method_TextDocumentDidOpen
 -> Const
      @(*)
      TextDocumentItem
      (TNotificationMessage
         @'ClientToServer 'Method_TextDocumentDidOpen))
-> ((TextDocumentItem
     -> Const @(*) TextDocumentItem TextDocumentItem)
    -> DidOpenTextDocumentParams
    -> Const @(*) TextDocumentItem DidOpenTextDocumentParams)
-> Getting
     TextDocumentItem
     (TNotificationMessage @'ClientToServer 'Method_TextDocumentDidOpen)
     TextDocumentItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentItem -> Const @(*) TextDocumentItem TextDocumentItem)
-> DidOpenTextDocumentParams
-> Const @(*) TextDocumentItem DidOpenTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DidOpenTextDocumentParams TextDocumentItem
J.textDocument
      vfile :: VirtualFile
vfile = Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
version Int
0 (Text -> Rope
Rope.fromText Text
text)
  LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
Opening NormalizedUri
uri VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe VirtualFile))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe VirtualFile))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
uri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe VirtualFile))
 -> VFS -> Identity VFS)
-> Maybe VirtualFile -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= VirtualFile -> Maybe VirtualFile
forall a. a -> Maybe a
Just VirtualFile
vfile

-- ---------------------------------------------------------------------

-- | Applies a 'DidChangeTextDocumentNotification' to the 'VFS'
changeFromClientVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidChange -> m ()
changeFromClientVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> m ()
changeFromClientVFS LogAction m (WithSeverity VfsLog)
logger TMessage
  @'ClientToServer @'Notification 'Method_TextDocumentDidChange
msg = do
  let
    J.DidChangeTextDocumentParams VersionedTextDocumentIdentifier
vid [TextDocumentContentChangeEvent]
changes = TMessage
  @'ClientToServer @'Notification 'Method_TextDocumentDidChange
TNotificationMessage @'ClientToServer 'Method_TextDocumentDidChange
msg TNotificationMessage @'ClientToServer 'Method_TextDocumentDidChange
-> Getting
     DidChangeTextDocumentParams
     (TNotificationMessage
        @'ClientToServer 'Method_TextDocumentDidChange)
     DidChangeTextDocumentParams
-> DidChangeTextDocumentParams
forall s a. s -> Getting a s a -> a
^. Getting
  DidChangeTextDocumentParams
  (TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidChange)
  DidChangeTextDocumentParams
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidChange)
  DidChangeTextDocumentParams
J.params
    -- the client shouldn't be sending over a null version, only the server, but we just use 0 if that happens
    J.VersionedTextDocumentIdentifier (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) Int32
version = VersionedTextDocumentIdentifier
vid
  VFS
vfs <- m VFS
forall s (m :: * -> *). MonadState s m => m s
get
  case VFS
vfs VFS
-> Getting (Maybe VirtualFile) VFS (Maybe VirtualFile)
-> Maybe VirtualFile
forall s a. s -> Getting a s a -> a
^. (Map NormalizedUri VirtualFile
 -> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
-> VFS -> Const @(*) (Maybe VirtualFile) VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
 -> VFS -> Const @(*) (Maybe VirtualFile) VFS)
-> ((Maybe VirtualFile
     -> Const @(*) (Maybe VirtualFile) (Maybe VirtualFile))
    -> Map NormalizedUri VirtualFile
    -> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
-> Getting (Maybe VirtualFile) VFS (Maybe VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
uri of
    Just (VirtualFile Int32
_ Int
file_ver Rope
contents) -> do
      Rope
contents' <- LogAction m (WithSeverity VfsLog)
-> Rope -> [TextDocumentContentChangeEvent] -> m Rope
forall (m :: * -> *).
Monad m =>
LogAction m (WithSeverity VfsLog)
-> Rope -> [TextDocumentContentChangeEvent] -> m Rope
applyChanges LogAction m (WithSeverity VfsLog)
logger Rope
contents [TextDocumentContentChangeEvent]
changes
      (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe VirtualFile))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe VirtualFile))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
uri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe VirtualFile))
 -> VFS -> Identity VFS)
-> Maybe VirtualFile -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= VirtualFile -> Maybe VirtualFile
forall a. a -> Maybe a
Just (Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
version (Int
file_ver Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Rope
contents')
    Maybe VirtualFile
Nothing -> LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
URINotFound NormalizedUri
uri VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning

-- ---------------------------------------------------------------------

applyCreateFile :: (MonadState VFS m) => J.CreateFile -> m ()
applyCreateFile :: forall (m :: * -> *). MonadState VFS m => CreateFile -> m ()
applyCreateFile (J.CreateFile Maybe ChangeAnnotationIdentifier
_ann AString "create"
_kind (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) Maybe CreateFileOptions
options) =
  (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap
    ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> (Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile)
-> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (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)
      NormalizedUri
uri
      (Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
0 Int
0 Rope
forall a. Monoid a => a
mempty)
 where
  shouldOverwrite :: Bool
  shouldOverwrite :: Bool
shouldOverwrite = case Maybe CreateFileOptions
options of
    Maybe CreateFileOptions
Nothing -> Bool
False -- default
    Just (J.CreateFileOptions Maybe Bool
Nothing Maybe Bool
Nothing) -> Bool
False -- default
    Just (J.CreateFileOptions Maybe Bool
Nothing (Just Bool
True)) -> Bool
False -- `ignoreIfExists` is True
    Just (J.CreateFileOptions Maybe Bool
Nothing (Just Bool
False)) -> Bool
True -- `ignoreIfExists` is False
    Just (J.CreateFileOptions (Just Bool
True) Maybe Bool
Nothing) -> Bool
True -- `overwrite` is True
    Just (J.CreateFileOptions (Just Bool
True) (Just Bool
True)) -> Bool
True -- `overwrite` wins over `ignoreIfExists`
    Just (J.CreateFileOptions (Just Bool
True) (Just Bool
False)) -> Bool
True -- `overwrite` is True
    Just (J.CreateFileOptions (Just Bool
False) Maybe Bool
Nothing) -> Bool
False -- `overwrite` is False
    Just (J.CreateFileOptions (Just Bool
False) (Just Bool
True)) -> Bool
False -- `overwrite` is False
    Just (J.CreateFileOptions (Just Bool
False) (Just Bool
False)) -> Bool
False -- `overwrite` wins over `ignoreIfExists`

applyRenameFile :: (MonadState VFS m) => J.RenameFile -> m ()
applyRenameFile :: forall (m :: * -> *). MonadState VFS m => RenameFile -> m ()
applyRenameFile (J.RenameFile Maybe ChangeAnnotationIdentifier
_ann AString "rename"
_kind (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
oldUri) (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
newUri) Maybe RenameFileOptions
options) = do
  VFS
vfs <- m VFS
forall s (m :: * -> *). MonadState s m => m s
get
  case VFS
vfs VFS
-> Getting
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
     VFS
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
-> Maybe (IxValue (Map NormalizedUri VirtualFile))
forall s a. s -> Getting a s a -> a
^. (Map NormalizedUri VirtualFile
 -> Const
      @(*)
      (Maybe (IxValue (Map NormalizedUri VirtualFile)))
      (Map NormalizedUri VirtualFile))
-> VFS
-> Const @(*) (Maybe (IxValue (Map NormalizedUri VirtualFile))) VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Const
       @(*)
       (Maybe (IxValue (Map NormalizedUri VirtualFile)))
       (Map NormalizedUri VirtualFile))
 -> VFS
 -> Const
      @(*) (Maybe (IxValue (Map NormalizedUri VirtualFile))) VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Const
          @(*)
          (Maybe (IxValue (Map NormalizedUri VirtualFile)))
          (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Const
         @(*)
         (Maybe (IxValue (Map NormalizedUri VirtualFile)))
         (Map NormalizedUri VirtualFile))
-> Getting
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
     VFS
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
oldUri of
    -- nothing to rename
    Maybe (IxValue (Map NormalizedUri VirtualFile))
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just IxValue (Map NormalizedUri VirtualFile)
file -> case VFS
vfs VFS
-> Getting
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
     VFS
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
-> Maybe (IxValue (Map NormalizedUri VirtualFile))
forall s a. s -> Getting a s a -> a
^. (Map NormalizedUri VirtualFile
 -> Const
      @(*)
      (Maybe (IxValue (Map NormalizedUri VirtualFile)))
      (Map NormalizedUri VirtualFile))
-> VFS
-> Const @(*) (Maybe (IxValue (Map NormalizedUri VirtualFile))) VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Const
       @(*)
       (Maybe (IxValue (Map NormalizedUri VirtualFile)))
       (Map NormalizedUri VirtualFile))
 -> VFS
 -> Const
      @(*) (Maybe (IxValue (Map NormalizedUri VirtualFile))) VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Const
          @(*)
          (Maybe (IxValue (Map NormalizedUri VirtualFile)))
          (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Const
         @(*)
         (Maybe (IxValue (Map NormalizedUri VirtualFile)))
         (Map NormalizedUri VirtualFile))
-> Getting
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
     VFS
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
newUri of
      -- the target does not exist, just move over
      Maybe (IxValue (Map NormalizedUri VirtualFile))
Nothing -> do
        (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
oldUri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
 -> VFS -> Identity VFS)
-> Maybe (IxValue (Map NormalizedUri VirtualFile)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe (IxValue (Map NormalizedUri VirtualFile))
forall a. Maybe a
Nothing
        (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
newUri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
 -> VFS -> Identity VFS)
-> Maybe (IxValue (Map NormalizedUri VirtualFile)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= IxValue (Map NormalizedUri VirtualFile)
-> Maybe (IxValue (Map NormalizedUri VirtualFile))
forall a. a -> Maybe a
Just IxValue (Map NormalizedUri VirtualFile)
file
      Just IxValue (Map NormalizedUri VirtualFile)
_ -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldOverwrite (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
oldUri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
 -> VFS -> Identity VFS)
-> Maybe (IxValue (Map NormalizedUri VirtualFile)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe (IxValue (Map NormalizedUri VirtualFile))
forall a. Maybe a
Nothing
        (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
newUri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
 -> VFS -> Identity VFS)
-> Maybe (IxValue (Map NormalizedUri VirtualFile)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= IxValue (Map NormalizedUri VirtualFile)
-> Maybe (IxValue (Map NormalizedUri VirtualFile))
forall a. a -> Maybe a
Just IxValue (Map NormalizedUri VirtualFile)
file
 where
  shouldOverwrite :: Bool
  shouldOverwrite :: Bool
shouldOverwrite = case Maybe RenameFileOptions
options of
    Maybe RenameFileOptions
Nothing -> Bool
False -- default
    Just (J.RenameFileOptions Maybe Bool
Nothing Maybe Bool
Nothing) -> Bool
False -- default
    Just (J.RenameFileOptions Maybe Bool
Nothing (Just Bool
True)) -> Bool
False -- `ignoreIfExists` is True
    Just (J.RenameFileOptions Maybe Bool
Nothing (Just Bool
False)) -> Bool
True -- `ignoreIfExists` is False
    Just (J.RenameFileOptions (Just Bool
True) Maybe Bool
Nothing) -> Bool
True -- `overwrite` is True
    Just (J.RenameFileOptions (Just Bool
True) (Just Bool
True)) -> Bool
True -- `overwrite` wins over `ignoreIfExists`
    Just (J.RenameFileOptions (Just Bool
True) (Just Bool
False)) -> Bool
True -- `overwrite` is True
    Just (J.RenameFileOptions (Just Bool
False) Maybe Bool
Nothing) -> Bool
False -- `overwrite` is False
    Just (J.RenameFileOptions (Just Bool
False) (Just Bool
True)) -> Bool
False -- `overwrite` is False
    Just (J.RenameFileOptions (Just Bool
False) (Just Bool
False)) -> Bool
False -- `overwrite` wins over `ignoreIfExists`

applyDeleteFile :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DeleteFile -> m ()
applyDeleteFile :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog) -> DeleteFile -> m ()
applyDeleteFile LogAction m (WithSeverity VfsLog)
logger (J.DeleteFile Maybe ChangeAnnotationIdentifier
_ann AString "delete"
_kind (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) Maybe DeleteFileOptions
options) = do
  -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe DeleteFileOptions
options Maybe DeleteFileOptions
-> Getting (First Bool) (Maybe DeleteFileOptions) Bool
-> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? (DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
-> Maybe DeleteFileOptions
-> Const @(*) (First Bool) (Maybe DeleteFileOptions)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
 -> Maybe DeleteFileOptions
 -> Const @(*) (First Bool) (Maybe DeleteFileOptions))
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
-> Getting (First Bool) (Maybe DeleteFileOptions) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions
forall s a. HasRecursive s a => Lens' s a
Lens' DeleteFileOptions (Maybe Bool)
J.recursive ((Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
 -> DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> (Bool -> Const @(*) (First Bool) Bool)
-> DeleteFileOptions
-> Const @(*) (First Bool) DeleteFileOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const @(*) (First Bool) Bool)
-> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
CantRecursiveDelete NormalizedUri
uri VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
  -- Remove and get the old value so we can check if it was missing
  Maybe (IxValue (Map NormalizedUri VirtualFile))
old <- (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
uri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
 -> VFS -> Identity VFS)
-> Maybe (IxValue (Map NormalizedUri VirtualFile))
-> m (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m b
<.= Maybe (IxValue (Map NormalizedUri VirtualFile))
forall a. Maybe a
Nothing
  case Maybe (IxValue (Map NormalizedUri VirtualFile))
old of
    -- It's not entirely clear what the semantics of 'ignoreIfNotExists' are, but if it
    -- doesn't exist and we're not ignoring it, let's at least log it.
    Maybe (IxValue (Map NormalizedUri VirtualFile))
Nothing
      | Maybe DeleteFileOptions
options Maybe DeleteFileOptions
-> Getting (First Bool) (Maybe DeleteFileOptions) Bool
-> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? (DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
-> Maybe DeleteFileOptions
-> Const @(*) (First Bool) (Maybe DeleteFileOptions)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
 -> Maybe DeleteFileOptions
 -> Const @(*) (First Bool) (Maybe DeleteFileOptions))
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
-> Getting (First Bool) (Maybe DeleteFileOptions) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions
forall s a. HasIgnoreIfNotExists s a => Lens' s a
Lens' DeleteFileOptions (Maybe Bool)
J.ignoreIfNotExists ((Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
 -> DeleteFileOptions -> Const @(*) (First Bool) DeleteFileOptions)
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> (Bool -> Const @(*) (First Bool) Bool)
-> DeleteFileOptions
-> Const @(*) (First Bool) DeleteFileOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const @(*) (First Bool) Bool)
-> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True ->
          LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
CantRecursiveDelete NormalizedUri
uri VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
    Maybe (IxValue (Map NormalizedUri VirtualFile))
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

applyTextDocumentEdit :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TextDocumentEdit -> m ()
applyTextDocumentEdit :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog) -> TextDocumentEdit -> m ()
applyTextDocumentEdit LogAction m (WithSeverity VfsLog)
logger (J.TextDocumentEdit OptionalVersionedTextDocumentIdentifier
vid [TextEdit |? AnnotatedTextEdit]
edits) = do
  -- all edits are supposed to be applied at once
  -- so apply from bottom up so they don't affect others
  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
      -- TODO: is this right?
      vid' :: VersionedTextDocumentIdentifier
vid' = Uri -> Int32 -> VersionedTextDocumentIdentifier
J.VersionedTextDocumentIdentifier (OptionalVersionedTextDocumentIdentifier
vid OptionalVersionedTextDocumentIdentifier
-> Getting Uri OptionalVersionedTextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri OptionalVersionedTextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' OptionalVersionedTextDocumentIdentifier Uri
J.uri) (case OptionalVersionedTextDocumentIdentifier
vid OptionalVersionedTextDocumentIdentifier
-> Getting
     (Int32 |? Null)
     OptionalVersionedTextDocumentIdentifier
     (Int32 |? Null)
-> Int32 |? Null
forall s a. s -> Getting a s a -> a
^. Getting
  (Int32 |? Null)
  OptionalVersionedTextDocumentIdentifier
  (Int32 |? Null)
forall s a. HasVersion s a => Lens' s a
Lens' OptionalVersionedTextDocumentIdentifier (Int32 |? Null)
J.version of J.InL Int32
v -> Int32
v; J.InR Null
_ -> Int32
0)
      ps :: DidChangeTextDocumentParams
ps = VersionedTextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> DidChangeTextDocumentParams
J.DidChangeTextDocumentParams VersionedTextDocumentIdentifier
vid' [TextDocumentContentChangeEvent]
changeEvents
      notif :: TNotificationMessage @'ClientToServer 'Method_TextDocumentDidChange
notif = Text
-> SMethod
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> MessageParams
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidChange
forall (f :: MessageDirection) (m :: Method f 'Notification).
Text
-> SMethod @f @'Notification m
-> MessageParams @f @'Notification m
-> TNotificationMessage @f m
J.TNotificationMessage Text
"" SMethod
  @'ClientToServer @'Notification 'Method_TextDocumentDidChange
J.SMethod_TextDocumentDidChange DidChangeTextDocumentParams
MessageParams
  @'ClientToServer @'Notification 'Method_TextDocumentDidChange
ps
  LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> m ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> m ()
changeFromClientVFS LogAction m (WithSeverity VfsLog)
logger TMessage
  @'ClientToServer @'Notification 'Method_TextDocumentDidChange
TNotificationMessage @'ClientToServer 'Method_TextDocumentDidChange
notif
 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
Lens' AnnotatedTextEdit Range
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
Lens' TextEdit Range
J.range

  editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent
  editToChangeEvent :: (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent (J.InR AnnotatedTextEdit
e) = (Rec
   ((.+)
      @(*)
      (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
      ((.+)
         @(*)
         (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
 |? Rec
      ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
-> TextDocumentContentChangeEvent
J.TextDocumentContentChangeEvent ((Rec
    ((.+)
       @(*)
       (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
       ((.+)
          @(*)
          (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
          ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
  |? Rec
       ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
 -> TextDocumentContentChangeEvent)
-> (Rec
      ((.+)
         @(*)
         (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
         ((.+)
            @(*)
            (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
            ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
    |? Rec
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ Rec
  ((.+)
     @(*)
     (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
     ((.+)
        @(*)
        (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
-> Rec
     ((.+)
        @(*)
        (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
        ((.+)
           @(*)
           (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
           ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
   |? Rec
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))
forall a b. a -> a |? b
J.InL (Rec
   ((.+)
      @(*)
      (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
      ((.+)
         @(*)
         (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
 -> Rec
      ((.+)
         @(*)
         (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
         ((.+)
            @(*)
            (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
            ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
    |? Rec
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
-> Rec
     ((.+)
        @(*)
        (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
        ((.+)
           @(*)
           (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
           ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
-> Rec
     ((.+)
        @(*)
        (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
        ((.+)
           @(*)
           (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
           ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
   |? Rec
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))
forall a b. (a -> b) -> a -> b
$ Label "range"
#range Label "range"
-> Range
-> Rec (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== 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
Lens' AnnotatedTextEdit Range
J.range Rec
  ('R
     @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
-> Rec
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ('[] @(LT (*)))))
-> Rec
     ((.+)
        @(*)
        ('R
           @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
        ('R
           @(*)
           ((':)
              @(LT (*))
              ((':->) @(*) "rangeLength" (Maybe UInt))
              ('[] @(LT (*))))))
forall (l :: Row (*)) (r :: Row (*)).
FreeForall @(*) l =>
Rec l -> Rec r -> Rec ((.+) @(*) l r)
.+ Label "rangeLength"
#rangeLength Label "rangeLength"
-> Maybe UInt
-> Rec
     (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== Maybe UInt
forall a. Maybe a
Nothing Rec
  ((.+)
     @(*)
     ('R
        @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ('[] @(LT (*))))))
-> Rec
     ('R
        @(*) ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))
-> Rec
     ((.+)
        @(*)
        ((.+)
           @(*)
           ('R
              @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
           ('R
              @(*)
              ((':)
                 @(LT (*))
                 ((':->) @(*) "rangeLength" (Maybe UInt))
                 ('[] @(LT (*))))))
        ('R
           @(*) ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*))))))
forall (l :: Row (*)) (r :: Row (*)).
FreeForall @(*) l =>
Rec l -> Rec r -> Rec ((.+) @(*) l r)
.+ Label "text"
#text Label "text" -> Text -> Rec ((.==) @(*) "text" Text)
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== 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
Lens' AnnotatedTextEdit Text
J.newText
  editToChangeEvent (J.InL TextEdit
e) = (Rec
   ((.+)
      @(*)
      (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
      ((.+)
         @(*)
         (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
 |? Rec
      ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
-> TextDocumentContentChangeEvent
J.TextDocumentContentChangeEvent ((Rec
    ((.+)
       @(*)
       (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
       ((.+)
          @(*)
          (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
          ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
  |? Rec
       ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
 -> TextDocumentContentChangeEvent)
-> (Rec
      ((.+)
         @(*)
         (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
         ((.+)
            @(*)
            (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
            ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
    |? Rec
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ Rec
  ((.+)
     @(*)
     (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
     ((.+)
        @(*)
        (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
-> Rec
     ((.+)
        @(*)
        (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
        ((.+)
           @(*)
           (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
           ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
   |? Rec
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))
forall a b. a -> a |? b
J.InL (Rec
   ((.+)
      @(*)
      (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
      ((.+)
         @(*)
         (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
 -> Rec
      ((.+)
         @(*)
         (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
         ((.+)
            @(*)
            (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
            ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
    |? Rec
         ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*))))))
-> Rec
     ((.+)
        @(*)
        (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
        ((.+)
           @(*)
           (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
           ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
-> Rec
     ((.+)
        @(*)
        (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
        ((.+)
           @(*)
           (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
           ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
   |? Rec
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))
forall a b. (a -> b) -> a -> b
$ Label "range"
#range Label "range"
-> Range
-> Rec (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== 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
Lens' TextEdit Range
J.range Rec
  ('R
     @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
-> Rec
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ('[] @(LT (*)))))
-> Rec
     ((.+)
        @(*)
        ('R
           @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
        ('R
           @(*)
           ((':)
              @(LT (*))
              ((':->) @(*) "rangeLength" (Maybe UInt))
              ('[] @(LT (*))))))
forall (l :: Row (*)) (r :: Row (*)).
FreeForall @(*) l =>
Rec l -> Rec r -> Rec ((.+) @(*) l r)
.+ Label "rangeLength"
#rangeLength Label "rangeLength"
-> Maybe UInt
-> Rec
     (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== Maybe UInt
forall a. Maybe a
Nothing Rec
  ((.+)
     @(*)
     ('R
        @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ('[] @(LT (*))))))
-> Rec
     ('R
        @(*) ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))
-> Rec
     ((.+)
        @(*)
        ((.+)
           @(*)
           ('R
              @(*) ((':) @(LT (*)) ((':->) @(*) "range" Range) ('[] @(LT (*)))))
           ('R
              @(*)
              ((':)
                 @(LT (*))
                 ((':->) @(*) "rangeLength" (Maybe UInt))
                 ('[] @(LT (*))))))
        ('R
           @(*) ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*))))))
forall (l :: Row (*)) (r :: Row (*)).
FreeForall @(*) l =>
Rec l -> Rec r -> Rec ((.+) @(*) l r)
.+ Label "text"
#text Label "text" -> Text -> Rec ((.==) @(*) "text" Text)
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== 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
Lens' TextEdit Text
J.newText

applyDocumentChange :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DocumentChange -> m ()
applyDocumentChange :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog) -> DocumentChange -> m ()
applyDocumentChange LogAction m (WithSeverity VfsLog)
logger (J.InL TextDocumentEdit
change) = LogAction m (WithSeverity VfsLog) -> TextDocumentEdit -> m ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog) -> TextDocumentEdit -> m ()
applyTextDocumentEdit LogAction m (WithSeverity VfsLog)
logger TextDocumentEdit
change
applyDocumentChange LogAction m (WithSeverity VfsLog)
_ (J.InR (J.InL CreateFile
change)) = CreateFile -> m ()
forall (m :: * -> *). MonadState VFS m => CreateFile -> m ()
applyCreateFile CreateFile
change
applyDocumentChange LogAction m (WithSeverity VfsLog)
_ (J.InR (J.InR (J.InL RenameFile
change))) = RenameFile -> m ()
forall (m :: * -> *). MonadState VFS m => RenameFile -> m ()
applyRenameFile RenameFile
change
applyDocumentChange LogAction m (WithSeverity VfsLog)
logger (J.InR (J.InR (J.InR DeleteFile
change))) = LogAction m (WithSeverity VfsLog) -> DeleteFile -> m ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog) -> DeleteFile -> m ()
applyDeleteFile LogAction m (WithSeverity VfsLog)
logger DeleteFile
change

-- | Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS'
changeFromServerVFS :: forall m. MonadState VFS m => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_WorkspaceApplyEdit -> m ()
changeFromServerVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage @'ServerToClient @'Request 'Method_WorkspaceApplyEdit
-> m ()
changeFromServerVFS LogAction m (WithSeverity VfsLog)
logger TMessage @'ServerToClient @'Request 'Method_WorkspaceApplyEdit
msg = do
  let J.ApplyWorkspaceEditParams Maybe Text
_label WorkspaceEdit
edit = TMessage @'ServerToClient @'Request 'Method_WorkspaceApplyEdit
TRequestMessage @'ServerToClient 'Method_WorkspaceApplyEdit
msg TRequestMessage @'ServerToClient 'Method_WorkspaceApplyEdit
-> Getting
     ApplyWorkspaceEditParams
     (TRequestMessage @'ServerToClient 'Method_WorkspaceApplyEdit)
     ApplyWorkspaceEditParams
-> ApplyWorkspaceEditParams
forall s a. s -> Getting a s a -> a
^. Getting
  ApplyWorkspaceEditParams
  (TRequestMessage @'ServerToClient 'Method_WorkspaceApplyEdit)
  ApplyWorkspaceEditParams
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage @'ServerToClient 'Method_WorkspaceApplyEdit)
  ApplyWorkspaceEditParams
J.params
      J.WorkspaceEdit Maybe (Map Uri [TextEdit])
mChanges Maybe [DocumentChange]
mDocChanges Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_anns = WorkspaceEdit
edit
  case Maybe [DocumentChange]
mDocChanges of
    Just [DocumentChange]
docChanges -> [DocumentChange] -> m ()
applyDocumentChanges [DocumentChange]
docChanges
    Maybe [DocumentChange]
Nothing -> case Maybe (Map Uri [TextEdit])
mChanges of
      Just Map Uri [TextEdit]
cs -> [DocumentChange] -> m ()
applyDocumentChanges ([DocumentChange] -> m ()) -> [DocumentChange] -> m ()
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 -> [TextEdit] -> [TextDocumentEdit])
-> [TextDocumentEdit] -> Map Uri [TextEdit] -> [TextDocumentEdit]
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' [TextDocumentEdit] -> Uri -> [TextEdit] -> [TextDocumentEdit]
changeToTextDocumentEdit [] Map Uri [TextEdit]
cs
      Maybe (Map Uri [TextEdit])
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  changeToTextDocumentEdit :: [TextDocumentEdit] -> Uri -> [TextEdit] -> [TextDocumentEdit]
changeToTextDocumentEdit [TextDocumentEdit]
acc Uri
uri [TextEdit]
edits =
    [TextDocumentEdit]
acc [TextDocumentEdit] -> [TextDocumentEdit] -> [TextDocumentEdit]
forall a. [a] -> [a] -> [a]
++ [OptionalVersionedTextDocumentIdentifier
-> [TextEdit |? AnnotatedTextEdit] -> TextDocumentEdit
J.TextDocumentEdit (Uri -> (Int32 |? Null) -> OptionalVersionedTextDocumentIdentifier
J.OptionalVersionedTextDocumentIdentifier Uri
uri (Int32 -> Int32 |? Null
forall a b. a -> a |? b
J.InL Int32
0)) ((TextEdit -> TextEdit |? AnnotatedTextEdit)
-> [TextEdit] -> [TextEdit |? AnnotatedTextEdit]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEdit -> TextEdit |? AnnotatedTextEdit
forall a b. a -> a |? b
J.InL [TextEdit]
edits)]

  applyDocumentChanges :: [J.DocumentChange] -> m ()
  applyDocumentChanges :: [DocumentChange] -> m ()
applyDocumentChanges = (DocumentChange -> m ()) -> [DocumentChange] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LogAction m (WithSeverity VfsLog) -> DocumentChange -> m ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog) -> DocumentChange -> m ()
applyDocumentChange LogAction m (WithSeverity VfsLog)
logger) ([DocumentChange] -> m ())
-> ([DocumentChange] -> [DocumentChange])
-> [DocumentChange]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocumentChange -> Maybe Int32)
-> [DocumentChange] -> [DocumentChange]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn DocumentChange -> Maybe Int32
project

  -- for sorting [DocumentChange]
  project :: J.DocumentChange -> Maybe J.Int32
  project :: DocumentChange -> Maybe Int32
project (J.InL TextDocumentEdit
textDocumentEdit) = case TextDocumentEdit
textDocumentEdit TextDocumentEdit
-> Getting (Int32 |? Null) TextDocumentEdit (Int32 |? Null)
-> Int32 |? Null
forall s a. s -> Getting a s a -> a
^. (OptionalVersionedTextDocumentIdentifier
 -> Const
      @(*) (Int32 |? Null) OptionalVersionedTextDocumentIdentifier)
-> TextDocumentEdit -> Const @(*) (Int32 |? Null) TextDocumentEdit
forall s a. HasTextDocument s a => Lens' s a
Lens' TextDocumentEdit OptionalVersionedTextDocumentIdentifier
J.textDocument ((OptionalVersionedTextDocumentIdentifier
  -> Const
       @(*) (Int32 |? Null) OptionalVersionedTextDocumentIdentifier)
 -> TextDocumentEdit -> Const @(*) (Int32 |? Null) TextDocumentEdit)
-> Getting
     (Int32 |? Null)
     OptionalVersionedTextDocumentIdentifier
     (Int32 |? Null)
-> Getting (Int32 |? Null) TextDocumentEdit (Int32 |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Int32 |? Null)
  OptionalVersionedTextDocumentIdentifier
  (Int32 |? Null)
forall s a. HasVersion s a => Lens' s a
Lens' OptionalVersionedTextDocumentIdentifier (Int32 |? Null)
J.version of
    J.InL Int32
v -> Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
v
    Int32 |? Null
_ -> Maybe Int32
forall a. Maybe a
Nothing
  project DocumentChange
_ = Maybe Int32
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------
virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath
virtualFileName :: [Char] -> NormalizedUri -> VirtualFile -> [Char]
virtualFileName [Char]
prefix NormalizedUri
uri (VirtualFile Int32
_ Int
file_ver Rope
_) =
  let uri_raw :: Uri
uri_raw = NormalizedUri -> Uri
J.fromNormalizedUri NormalizedUri
uri
      basename :: [Char]
basename = [Char] -> ShowS -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ShowS
takeFileName (Uri -> Maybe [Char]
J.uriToFilePath Uri
uri_raw)
      -- Given a length and a version number, pad the version number to
      -- the given n. Does nothing if the version number string is longer
      -- than the given length.
      padLeft :: Int -> Int -> String
      padLeft :: Int -> Int -> [Char]
padLeft Int
n Int
num =
        let numString :: [Char]
numString = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num
         in Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
numString) Char
'0' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
numString
   in [Char]
prefix [Char] -> ShowS
</> [Char]
basename [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [Char]
padLeft Int
5 Int
file_ver [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Uri -> Int
forall a. Hashable a => a -> Int
hash Uri
uri_raw) [Char] -> ShowS
<.> ShowS
takeExtensions [Char]
basename

-- | Write a virtual file to a file in the given directory if it exists in the VFS.
persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> FilePath -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ())
persistFileVFS :: forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity VfsLog)
-> [Char] -> VFS -> NormalizedUri -> Maybe ([Char], m ())
persistFileVFS LogAction m (WithSeverity VfsLog)
logger [Char]
dir VFS
vfs NormalizedUri
uri =
  case VFS
vfs VFS
-> Getting (Maybe VirtualFile) VFS (Maybe VirtualFile)
-> Maybe VirtualFile
forall s a. s -> Getting a s a -> a
^. (Map NormalizedUri VirtualFile
 -> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
-> VFS -> Const @(*) (Maybe VirtualFile) VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
 -> VFS -> Const @(*) (Maybe VirtualFile) VFS)
-> ((Maybe VirtualFile
     -> Const @(*) (Maybe VirtualFile) (Maybe VirtualFile))
    -> Map NormalizedUri VirtualFile
    -> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
-> Getting (Maybe VirtualFile) VFS (Maybe VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
uri of
    Maybe VirtualFile
Nothing -> Maybe ([Char], m ())
forall a. Maybe a
Nothing
    Just VirtualFile
vf ->
      let tfn :: [Char]
tfn = [Char] -> NormalizedUri -> VirtualFile -> [Char]
virtualFileName [Char]
dir NormalizedUri
uri VirtualFile
vf
          action :: m ()
action = do
            Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
tfn
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              let contents :: Text
contents = Rope -> Text
Rope.toText (VirtualFile -> Rope
_file_text VirtualFile
vf)
                  writeRaw :: Handle -> IO ()
writeRaw Handle
h = do
                    -- We honour original file line endings
                    Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
noNewlineTranslation
                    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
                    Handle -> Text -> IO ()
T.hPutStr Handle
h Text
contents
              LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> [Char] -> VfsLog
PersistingFile NormalizedUri
uri [Char]
tfn VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
tfn IOMode
WriteMode Handle -> IO ()
writeRaw
       in ([Char], m ()) -> Maybe ([Char], m ())
forall a. a -> Maybe a
Just ([Char]
tfn, m ()
action)

-- ---------------------------------------------------------------------

closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidClose -> m ()
closeVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidClose
-> m ()
closeVFS LogAction m (WithSeverity VfsLog)
logger TMessage
  @'ClientToServer @'Notification 'Method_TextDocumentDidClose
msg = do
  let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri)) = TMessage
  @'ClientToServer @'Notification 'Method_TextDocumentDidClose
TNotificationMessage @'ClientToServer 'Method_TextDocumentDidClose
msg TNotificationMessage @'ClientToServer 'Method_TextDocumentDidClose
-> Getting
     DidCloseTextDocumentParams
     (TNotificationMessage
        @'ClientToServer 'Method_TextDocumentDidClose)
     DidCloseTextDocumentParams
-> DidCloseTextDocumentParams
forall s a. s -> Getting a s a -> a
^. Getting
  DidCloseTextDocumentParams
  (TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidClose)
  DidCloseTextDocumentParams
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidClose)
  DidCloseTextDocumentParams
J.params
  LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
Closing NormalizedUri
uri VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((Maybe (IxValue (Map NormalizedUri VirtualFile))
     -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (Maybe (IxValue (Map NormalizedUri VirtualFile))
    -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
     (Map NormalizedUri VirtualFile)
     (Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
uri ((Maybe (IxValue (Map NormalizedUri VirtualFile))
  -> Identity (Maybe (IxValue (Map NormalizedUri VirtualFile))))
 -> VFS -> Identity VFS)
-> Maybe (IxValue (Map NormalizedUri VirtualFile)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe (IxValue (Map NormalizedUri VirtualFile))
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------

{- | Apply the list of changes.
 Changes should be applied in the order that they are
 received from the client.
-}
applyChanges :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> [J.TextDocumentContentChangeEvent] -> m Rope
applyChanges :: forall (m :: * -> *).
Monad m =>
LogAction m (WithSeverity VfsLog)
-> Rope -> [TextDocumentContentChangeEvent] -> m Rope
applyChanges LogAction m (WithSeverity VfsLog)
logger = (Rope -> TextDocumentContentChangeEvent -> m Rope)
-> Rope -> [TextDocumentContentChangeEvent] -> m Rope
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (LogAction m (WithSeverity VfsLog)
-> Rope -> TextDocumentContentChangeEvent -> m Rope
forall (m :: * -> *).
Monad m =>
LogAction m (WithSeverity VfsLog)
-> Rope -> TextDocumentContentChangeEvent -> m Rope
applyChange LogAction m (WithSeverity VfsLog)
logger)

-- ---------------------------------------------------------------------

applyChange :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> J.TextDocumentContentChangeEvent -> m Rope
applyChange :: forall (m :: * -> *).
Monad m =>
LogAction m (WithSeverity VfsLog)
-> Rope -> TextDocumentContentChangeEvent -> m Rope
applyChange LogAction m (WithSeverity VfsLog)
logger Rope
str (J.TextDocumentContentChangeEvent (J.InL Rec
  ((.+)
     @(*)
     (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
     ((.+)
        @(*)
        (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
e))
  | J.Range (J.Position UInt
sl UInt
sc) (J.Position UInt
fl UInt
fc) <- Rec
  ((.+)
     @(*)
     (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
     ((.+)
        @(*)
        (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
Rec
  ('R
     @(*)
     ((':)
        @(LT (*))
        ((':->) @(*) "range" Range)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
e Rec
  ('R
     @(*)
     ((':)
        @(LT (*))
        ((':->) @(*) "range" Range)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
-> Label "range"
-> (.!)
     @(*)
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "range" Range)
           ((':)
              @(LT (*))
              ((':->) @(*) "rangeLength" (Maybe UInt))
              ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
     "range"
forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Rec r -> Label l -> (.!) @(*) r l
.! Label "range"
#range
  , (.!)
  @(*)
  ('R
     @(*)
     ((':)
        @(LT (*))
        ((':->) @(*) "range" Range)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
  "text"
txt <- Rec
  ((.+)
     @(*)
     (Extend @(*) "range" Range ('R @(*) ('[] @(LT (*)))))
     ((.+)
        @(*)
        (Extend @(*) "rangeLength" (Maybe UInt) ('R @(*) ('[] @(LT (*)))))
        ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))))
Rec
  ('R
     @(*)
     ((':)
        @(LT (*))
        ((':->) @(*) "range" Range)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
e Rec
  ('R
     @(*)
     ((':)
        @(LT (*))
        ((':->) @(*) "range" Range)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
-> Label "text"
-> (.!)
     @(*)
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "range" Range)
           ((':)
              @(LT (*))
              ((':->) @(*) "rangeLength" (Maybe UInt))
              ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
     "text"
forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Rec r -> Label l -> (.!) @(*) r l
.! Label "text"
#text =
      LogAction m (WithSeverity VfsLog)
-> Rope -> Position -> Position -> Text -> m Rope
forall (m :: * -> *).
Monad m =>
LogAction m (WithSeverity VfsLog)
-> Rope -> Position -> Position -> Text -> m Rope
changeChars LogAction m (WithSeverity VfsLog)
logger Rope
str (Word -> Word -> Position
Utf16.Position (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sl) (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sc)) (Word -> Word -> Position
Utf16.Position (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
fl) (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
fc)) Text
(.!)
  @(*)
  ('R
     @(*)
     ((':)
        @(LT (*))
        ((':->) @(*) "range" Range)
        ((':)
           @(LT (*))
           ((':->) @(*) "rangeLength" (Maybe UInt))
           ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))))
  "text"
txt
applyChange LogAction m (WithSeverity VfsLog)
_ Rope
_ (J.TextDocumentContentChangeEvent (J.InR Rec ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))
e)) =
  Rope -> m Rope
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rope -> m Rope) -> Rope -> m Rope
forall a b. (a -> b) -> a -> b
$ Text -> Rope
Rope.fromText (Text -> Rope) -> Text -> Rope
forall a b. (a -> b) -> a -> b
$ Rec ((.+) @(*) ((.==) @(*) "text" Text) ('R @(*) ('[] @(LT (*)))))
Rec
  ('R
     @(*) ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))
e Rec
  ('R
     @(*) ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))
-> Label "text"
-> (.!)
     @(*)
     ('R
        @(*) ((':) @(LT (*)) ((':->) @(*) "text" Text) ('[] @(LT (*)))))
     "text"
forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Rec r -> Label l -> (.!) @(*) r l
.! Label "text"
#text

-- ---------------------------------------------------------------------

{- | Given a 'Rope', start and end positions, and some new text, replace
 the given range with the new text. If the given positions lie within
 a code point then this does nothing (returns the original 'Rope') and logs.
-}
changeChars :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> Utf16.Position -> Utf16.Position -> Text -> m Rope
changeChars :: forall (m :: * -> *).
Monad m =>
LogAction m (WithSeverity VfsLog)
-> Rope -> Position -> Position -> Text -> m Rope
changeChars LogAction m (WithSeverity VfsLog)
logger Rope
str Position
start Position
finish Text
new = do
  case Position -> Rope -> Maybe (Rope, Rope)
Rope.utf16SplitAtPosition Position
finish Rope
str of
    Maybe (Rope, Rope)
Nothing -> LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Position -> Rope -> VfsLog
SplitInsideCodePoint Position
finish Rope
str VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning m () -> m Rope -> m Rope
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rope -> m Rope
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
str
    Just (Rope
before, Rope
after) -> case Position -> Rope -> Maybe (Rope, Rope)
Rope.utf16SplitAtPosition Position
start Rope
before of
      Maybe (Rope, Rope)
Nothing -> LogAction m (WithSeverity VfsLog)
logger LogAction m (WithSeverity VfsLog) -> WithSeverity VfsLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Position -> Rope -> VfsLog
SplitInsideCodePoint Position
start Rope
before VfsLog -> Severity -> WithSeverity VfsLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning m () -> m Rope -> m Rope
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rope -> m Rope
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
str
      Just (Rope
before', Rope
_) -> Rope -> m Rope
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rope -> m Rope) -> Rope -> m Rope
forall a b. (a -> b) -> a -> b
$ [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat [Rope
before', Text -> Rope
Rope.fromText Text
new, Rope
after]

-- ---------------------------------------------------------------------

{- | A position, like a 'J.Position', but where the offsets in the line are measured in
 Unicode code points instead of UTF-16 code units.
-}
data CodePointPosition = CodePointPosition
  { CodePointPosition -> UInt
_line :: J.UInt
  -- ^ Line position in a document (zero-based).
  , CodePointPosition -> UInt
_character :: J.UInt
  -- ^ Character offset on a line in a document in *code points* (zero-based).
  }
  deriving (Int -> CodePointPosition -> ShowS
[CodePointPosition] -> ShowS
CodePointPosition -> [Char]
(Int -> CodePointPosition -> ShowS)
-> (CodePointPosition -> [Char])
-> ([CodePointPosition] -> ShowS)
-> Show CodePointPosition
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodePointPosition -> ShowS
showsPrec :: Int -> CodePointPosition -> ShowS
$cshow :: CodePointPosition -> [Char]
show :: CodePointPosition -> [Char]
$cshowList :: [CodePointPosition] -> ShowS
showList :: [CodePointPosition] -> ShowS
Show, ReadPrec [CodePointPosition]
ReadPrec CodePointPosition
Int -> ReadS CodePointPosition
ReadS [CodePointPosition]
(Int -> ReadS CodePointPosition)
-> ReadS [CodePointPosition]
-> ReadPrec CodePointPosition
-> ReadPrec [CodePointPosition]
-> Read CodePointPosition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CodePointPosition
readsPrec :: Int -> ReadS CodePointPosition
$creadList :: ReadS [CodePointPosition]
readList :: ReadS [CodePointPosition]
$creadPrec :: ReadPrec CodePointPosition
readPrec :: ReadPrec CodePointPosition
$creadListPrec :: ReadPrec [CodePointPosition]
readListPrec :: ReadPrec [CodePointPosition]
Read, CodePointPosition -> CodePointPosition -> Bool
(CodePointPosition -> CodePointPosition -> Bool)
-> (CodePointPosition -> CodePointPosition -> Bool)
-> Eq CodePointPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodePointPosition -> CodePointPosition -> Bool
== :: CodePointPosition -> CodePointPosition -> Bool
$c/= :: CodePointPosition -> CodePointPosition -> Bool
/= :: CodePointPosition -> CodePointPosition -> Bool
Eq, Eq CodePointPosition
Eq CodePointPosition =>
(CodePointPosition -> CodePointPosition -> Ordering)
-> (CodePointPosition -> CodePointPosition -> Bool)
-> (CodePointPosition -> CodePointPosition -> Bool)
-> (CodePointPosition -> CodePointPosition -> Bool)
-> (CodePointPosition -> CodePointPosition -> Bool)
-> (CodePointPosition -> CodePointPosition -> CodePointPosition)
-> (CodePointPosition -> CodePointPosition -> CodePointPosition)
-> Ord CodePointPosition
CodePointPosition -> CodePointPosition -> Bool
CodePointPosition -> CodePointPosition -> Ordering
CodePointPosition -> CodePointPosition -> CodePointPosition
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CodePointPosition -> CodePointPosition -> Ordering
compare :: CodePointPosition -> CodePointPosition -> Ordering
$c< :: CodePointPosition -> CodePointPosition -> Bool
< :: CodePointPosition -> CodePointPosition -> Bool
$c<= :: CodePointPosition -> CodePointPosition -> Bool
<= :: CodePointPosition -> CodePointPosition -> Bool
$c> :: CodePointPosition -> CodePointPosition -> Bool
> :: CodePointPosition -> CodePointPosition -> Bool
$c>= :: CodePointPosition -> CodePointPosition -> Bool
>= :: CodePointPosition -> CodePointPosition -> Bool
$cmax :: CodePointPosition -> CodePointPosition -> CodePointPosition
max :: CodePointPosition -> CodePointPosition -> CodePointPosition
$cmin :: CodePointPosition -> CodePointPosition -> CodePointPosition
min :: CodePointPosition -> CodePointPosition -> CodePointPosition
Ord)

{- | A range, like a 'J.Range', but where the offsets in the line are measured in
 Unicode code points instead of UTF-16 code units.
-}
data CodePointRange = CodePointRange
  { CodePointRange -> CodePointPosition
_start :: CodePointPosition
  -- ^ The range's start position.
  , CodePointRange -> CodePointPosition
_end :: CodePointPosition
  -- ^ The range's end position.
  }
  deriving (Int -> CodePointRange -> ShowS
[CodePointRange] -> ShowS
CodePointRange -> [Char]
(Int -> CodePointRange -> ShowS)
-> (CodePointRange -> [Char])
-> ([CodePointRange] -> ShowS)
-> Show CodePointRange
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodePointRange -> ShowS
showsPrec :: Int -> CodePointRange -> ShowS
$cshow :: CodePointRange -> [Char]
show :: CodePointRange -> [Char]
$cshowList :: [CodePointRange] -> ShowS
showList :: [CodePointRange] -> ShowS
Show, ReadPrec [CodePointRange]
ReadPrec CodePointRange
Int -> ReadS CodePointRange
ReadS [CodePointRange]
(Int -> ReadS CodePointRange)
-> ReadS [CodePointRange]
-> ReadPrec CodePointRange
-> ReadPrec [CodePointRange]
-> Read CodePointRange
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CodePointRange
readsPrec :: Int -> ReadS CodePointRange
$creadList :: ReadS [CodePointRange]
readList :: ReadS [CodePointRange]
$creadPrec :: ReadPrec CodePointRange
readPrec :: ReadPrec CodePointRange
$creadListPrec :: ReadPrec [CodePointRange]
readListPrec :: ReadPrec [CodePointRange]
Read, CodePointRange -> CodePointRange -> Bool
(CodePointRange -> CodePointRange -> Bool)
-> (CodePointRange -> CodePointRange -> Bool) -> Eq CodePointRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodePointRange -> CodePointRange -> Bool
== :: CodePointRange -> CodePointRange -> Bool
$c/= :: CodePointRange -> CodePointRange -> Bool
/= :: CodePointRange -> CodePointRange -> Bool
Eq, Eq CodePointRange
Eq CodePointRange =>
(CodePointRange -> CodePointRange -> Ordering)
-> (CodePointRange -> CodePointRange -> Bool)
-> (CodePointRange -> CodePointRange -> Bool)
-> (CodePointRange -> CodePointRange -> Bool)
-> (CodePointRange -> CodePointRange -> Bool)
-> (CodePointRange -> CodePointRange -> CodePointRange)
-> (CodePointRange -> CodePointRange -> CodePointRange)
-> Ord CodePointRange
CodePointRange -> CodePointRange -> Bool
CodePointRange -> CodePointRange -> Ordering
CodePointRange -> CodePointRange -> CodePointRange
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CodePointRange -> CodePointRange -> Ordering
compare :: CodePointRange -> CodePointRange -> Ordering
$c< :: CodePointRange -> CodePointRange -> Bool
< :: CodePointRange -> CodePointRange -> Bool
$c<= :: CodePointRange -> CodePointRange -> Bool
<= :: CodePointRange -> CodePointRange -> Bool
$c> :: CodePointRange -> CodePointRange -> Bool
> :: CodePointRange -> CodePointRange -> Bool
$c>= :: CodePointRange -> CodePointRange -> Bool
>= :: CodePointRange -> CodePointRange -> Bool
$cmax :: CodePointRange -> CodePointRange -> CodePointRange
max :: CodePointRange -> CodePointRange -> CodePointRange
$cmin :: CodePointRange -> CodePointRange -> CodePointRange
min :: CodePointRange -> CodePointRange -> CodePointRange
Ord)

makeFieldsNoPrefix ''CodePointPosition
makeFieldsNoPrefix ''CodePointRange

{- Note [Converting between code points and code units]
This is inherently a somewhat expensive operation, but we take some care to minimize the cost.
In particular, we use the good asymptotics of 'Rope' to our advantage:
- We extract the single line that we are interested in in time logarithmic in the number of lines.
- We then split the line at the given position, and check how long the prefix is, which takes
linear time in the length of the (single) line.

So the overall process is logarithmic in the number of lines, and linear in the length of the specific
line. Which is okay-ish, so long as we don't have very long lines.

We are not able to use the `Rope.splitAtPosition`
Because when column index out of range or when the column indexing at the newline char.
The prefix result would wrap over the line and having the same result (nextLineNum, 0).
We would not be able to distinguish them. When the first case should return `Nothing`,
second case should return a `Just (CurrentLineNum, columnNumberConverted)`.
-}

{- | Extracts a specific line from a 'Rope.Rope'.
 Logarithmic in the number of lines.
-}
extractLine :: Rope.Rope -> Word -> Maybe Rope.Rope
extractLine :: Rope -> Word -> Maybe Rope
extractLine Rope
rope Word
l = do
  -- Check for the line being out of bounds
  let lastLine :: Word
lastLine = Position -> Word
Utf16.posLine (Position -> Word) -> Position -> Word
forall a b. (a -> b) -> a -> b
$ Rope -> Position
Rope.utf16LengthAsPosition Rope
rope
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word
l Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
lastLine
  let (Rope
_, Rope
suffix) = Word -> Rope -> (Rope, Rope)
Rope.splitAtLine Word
l Rope
rope
      (Rope
prefix, Rope
_) = Word -> Rope -> (Rope, Rope)
Rope.splitAtLine Word
1 Rope
suffix
  Rope -> Maybe Rope
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
prefix

{- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file.

 Will return 'Nothing' if the requested position is out of bounds of the document.

 Logarithmic in the number of lines in the document, and linear in the length of the line containing
 the position.
-}
codePointPositionToPosition :: VirtualFile -> CodePointPosition -> Maybe J.Position
codePointPositionToPosition :: VirtualFile -> CodePointPosition -> Maybe Position
codePointPositionToPosition VirtualFile
vFile (CodePointPosition UInt
l UInt
c) = do
  -- See Note [Converting between code points and code units]
  let text :: Rope
text = VirtualFile -> Rope
_file_text VirtualFile
vFile
  Rope
lineRope <- Rope -> Word -> Maybe Rope
extractLine Rope
text (Word -> Maybe Rope) -> Word -> Maybe Rope
forall a b. (a -> b) -> a -> b
$ UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ UInt
c UInt -> UInt -> Bool
forall a. Ord a => a -> a -> Bool
<= Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rope -> Word
Rope.charLength Rope
lineRope)
  Position -> Maybe Position
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ UInt -> UInt -> Position
J.Position UInt
l (Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> UInt) -> Word -> UInt
forall a b. (a -> b) -> a -> b
$ Rope -> Word
Rope.utf16Length (Rope -> Word) -> Rope -> Word
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
$ Word -> Rope -> (Rope, Rope)
Rope.charSplitAt (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
c) Rope
lineRope)

{- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file.

 Will return 'Nothing' if any of the positions are out of bounds of the document.

 Logarithmic in the number of lines in the document, and linear in the length of the lines containing
 the positions.
-}
codePointRangeToRange :: VirtualFile -> CodePointRange -> Maybe J.Range
codePointRangeToRange :: VirtualFile -> CodePointRange -> Maybe Range
codePointRangeToRange VirtualFile
vFile (CodePointRange CodePointPosition
b CodePointPosition
e) =
  Position -> Position -> Range
J.Range (Position -> Position -> Range)
-> Maybe Position -> Maybe (Position -> Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VirtualFile -> CodePointPosition -> Maybe Position
codePointPositionToPosition VirtualFile
vFile CodePointPosition
b Maybe (Position -> Range) -> Maybe Position -> Maybe Range
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VirtualFile -> CodePointPosition -> Maybe Position
codePointPositionToPosition VirtualFile
vFile CodePointPosition
e

{- | Given a virtual file, translate a 'J.Position' in that file into a 'CodePointPosition' in that file.

 Will return 'Nothing' if the requested position lies inside a code point, or if it is out of bounds of the document.

 Logarithmic in the number of lines in the document, and linear in the length of the line containing
 the position.
-}
positionToCodePointPosition :: VirtualFile -> J.Position -> Maybe CodePointPosition
positionToCodePointPosition :: VirtualFile -> Position -> Maybe CodePointPosition
positionToCodePointPosition VirtualFile
vFile (J.Position UInt
l UInt
c) = do
  -- See Note [Converting between code points and code units]
  let text :: Rope
text = VirtualFile -> Rope
_file_text VirtualFile
vFile
  Rope
lineRope <- Rope -> Word -> Maybe Rope
extractLine Rope
text (Word -> Maybe Rope) -> Word -> Maybe Rope
forall a b. (a -> b) -> a -> b
$ UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ UInt
c UInt -> UInt -> Bool
forall a. Ord a => a -> a -> Bool
<= Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rope -> Word
Rope.utf16Length Rope
lineRope)
  UInt -> UInt -> CodePointPosition
CodePointPosition UInt
l (UInt -> CodePointPosition)
-> ((Rope, Rope) -> UInt) -> (Rope, Rope) -> CodePointPosition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> UInt) -> ((Rope, Rope) -> Word) -> (Rope, Rope) -> UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> Word
Rope.charLength (Rope -> Word) -> ((Rope, Rope) -> Rope) -> (Rope, Rope) -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rope, Rope) -> Rope
forall a b. (a, b) -> a
fst ((Rope, Rope) -> CodePointPosition)
-> Maybe (Rope, Rope) -> Maybe CodePointPosition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Rope -> Maybe (Rope, Rope)
Rope.utf16SplitAt (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
c) Rope
lineRope

{- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file.

 Will return 'Nothing' if any of the positions are out of bounds of the document.

 Logarithmic in the number of lines in the document, and linear in the length of the lines containing
 the positions.
-}
rangeToCodePointRange :: VirtualFile -> J.Range -> Maybe CodePointRange
rangeToCodePointRange :: VirtualFile -> Range -> Maybe CodePointRange
rangeToCodePointRange VirtualFile
vFile (J.Range Position
b Position
e) =
  CodePointPosition -> CodePointPosition -> CodePointRange
CodePointRange (CodePointPosition -> CodePointPosition -> CodePointRange)
-> Maybe CodePointPosition
-> Maybe (CodePointPosition -> CodePointRange)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VirtualFile -> Position -> Maybe CodePointPosition
positionToCodePointPosition VirtualFile
vFile Position
b Maybe (CodePointPosition -> CodePointRange)
-> Maybe CodePointPosition -> Maybe CodePointRange
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VirtualFile -> Position -> Maybe CodePointPosition
positionToCodePointPosition VirtualFile
vFile Position
e

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) = Word -> Rope -> (Rope, Rope)
Rope.splitAtLine (UInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
lf) Rope
ropetext
  (Rope
s2, Rope
_) = Word -> Rope -> (Rope, Rope)
Rope.splitAtLine (UInt -> Word
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