{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeInType #-}

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}

-- 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
  , vfsTempDir
  , VirtualFile(..)
  , lsp_version
  , file_version
  , file_text
  , virtualFileText
  , virtualFileVersion
  , VfsLog (..)
  -- * Managing the VFS
  , initVFS
  , openVFS
  , changeFromClientVFS
  , changeFromServerVFS
  , persistFileVFS
  , closeVFS

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

  -- * manipulating the file contents
  , rangeLinesFromVfs
  , PosPrefixInfo(..)
  , getCompletionPrefix

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

import           Control.Lens hiding ( (<.>), parts )
import           Control.Monad
import           Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import           Control.Monad.State
import           Data.Char (isUpper, isAlphaNum)
import           Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Data.Int (Int32)
import           Data.List
import           Data.Ord
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import           Data.Maybe
import qualified Data.Text.Rope as URope
import           Data.Text.Utf16.Rope ( Rope )
import qualified Data.Text.Utf16.Rope as Rope
import           Data.Text.Prettyprint.Doc hiding (line)
import qualified Language.LSP.Types           as J
import qualified Language.LSP.Types.Lens      as J
import           System.FilePath
import           Data.Hashable
import           System.Directory
import           System.IO
import           System.IO.Temp
import Data.Foldable (traverse_)

-- ---------------------------------------------------------------------
{-# 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VirtualFile] -> ShowS
$cshowList :: [VirtualFile] -> ShowS
show :: VirtualFile -> [Char]
$cshow :: VirtualFile -> [Char]
showsPrec :: Int -> VirtualFile -> ShowS
$cshowsPrec :: Int -> VirtualFile -> ShowS
Show)

data VFS = VFS { VFS -> Map NormalizedUri VirtualFile
_vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)
               , VFS -> [Char]
_vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to
               } deriving Int -> VFS -> ShowS
[VFS] -> ShowS
VFS -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VFS] -> ShowS
$cshowList :: [VFS] -> ShowS
show :: VFS -> [Char]
$cshow :: VFS -> [Char]
showsPrec :: Int -> VFS -> ShowS
$cshowsPrec :: Int -> VFS -> ShowS
Show

data VfsLog =
  SplitInsideCodePoint Rope.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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VfsLog] -> ShowS
$cshowList :: [VfsLog] -> ShowS
show :: VfsLog -> [Char]
$cshow :: VfsLog -> [Char]
showsPrec :: Int -> VfsLog -> ShowS
$cshowsPrec :: Int -> 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" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Position
pos forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in" forall ann. Doc ann -> Doc ann -> 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" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedUri
uri
  pretty (Opening NormalizedUri
uri) = Doc ann
"VFS: opening" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedUri
uri
  pretty (Closing NormalizedUri
uri) = Doc ann
"VFS: closing" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedUri
uri
  pretty (PersistingFile NormalizedUri
uri [Char]
fp) = Doc ann
"VFS: Writing virtual file for" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedUri
uri forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"to" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow [Char]
fp
  pretty (CantRecursiveDelete NormalizedUri
uri) =
    Doc ann
"VFS: can't recursively delete" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedUri
uri 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" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow 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

---

initVFS :: (VFS -> IO r) -> IO r
initVFS :: forall r. (VFS -> IO r) -> IO r
initVFS VFS -> IO r
k = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m a) -> m a
withSystemTempDirectory [Char]
"haskell-lsp" forall a b. (a -> b) -> a -> b
$ \[Char]
temp_dir -> VFS -> IO r
k (Map NormalizedUri VirtualFile -> [Char] -> VFS
VFS forall a. Monoid a => a
mempty [Char]
temp_dir)

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

-- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS'
openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidOpen -> m ()
openVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromClient @'Notification 'TextDocumentDidOpen -> m ()
openVFS LogAction m (WithSeverity VfsLog)
logger Message @'FromClient @'Notification 'TextDocumentDidOpen
msg = do
  let J.TextDocumentItem (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) Text
_ Int32
version Text
text = Message @'FromClient @'Notification 'TextDocumentDidOpen
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
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 forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
Opening NormalizedUri
uri forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
uri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just VirtualFile
vfile

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

-- | Applies a 'DidChangeTextDocumentNotification' to the 'VFS'
changeFromClientVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidChange -> m ()
changeFromClientVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromClient @'Notification 'TextDocumentDidChange
-> m ()
changeFromClientVFS LogAction m (WithSeverity VfsLog)
logger Message @'FromClient @'Notification 'TextDocumentDidChange
msg = do
  let
    J.DidChangeTextDocumentParams VersionedTextDocumentIdentifier
vid (J.List [TextDocumentContentChangeEvent]
changes) = Message @'FromClient @'Notification 'TextDocumentDidChange
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
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) (forall a. a -> Maybe a -> a
fromMaybe Int32
0 -> Int32
version) = VersionedTextDocumentIdentifier
vid
  VFS
vfs <- forall s (m :: * -> *). MonadState s m => m s
get
  case VFS
vfs forall s a. s -> Getting a s a -> a
^. forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
uri of
    Just (VirtualFile Int32
_ Int
file_ver Rope
contents) -> do
      Rope
contents' <- forall (m :: * -> *).
Monad m =>
LogAction m (WithSeverity VfsLog)
-> Rope -> [TextDocumentContentChangeEvent] -> m Rope
applyChanges LogAction m (WithSeverity VfsLog)
logger Rope
contents [TextDocumentContentChangeEvent]
changes
      forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
uri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just (Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
version (Int
file_ver forall a. Num a => a -> a -> a
+ Int
1) Rope
contents')
    Maybe VirtualFile
Nothing -> LogAction m (WithSeverity VfsLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
URINotFound NormalizedUri
uri 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 (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) Maybe CreateFileOptions
options Maybe ChangeAnnotationIdentifier
_ann) =
  forall s a. HasVfsMap s a => Lens' s a
vfsMap forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= 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 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 (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
oldUri) (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
newUri) Maybe RenameFileOptions
options Maybe ChangeAnnotationIdentifier
_ann) = do
  VFS
vfs <- forall s (m :: * -> *). MonadState s m => m s
get
  case VFS
vfs forall s a. s -> Getting a s a -> a
^. forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
oldUri of
      -- nothing to rename
      Maybe (IxValue (Map NormalizedUri VirtualFile))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just IxValue (Map NormalizedUri VirtualFile)
file -> case VFS
vfs forall s a. s -> Getting a s a -> a
^. forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
newUri of
        -- the target does not exist, just move over
        Maybe (IxValue (Map NormalizedUri VirtualFile))
Nothing -> do
          forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
oldUri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Maybe a
Nothing
          forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
newUri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just IxValue (Map NormalizedUri VirtualFile)
file
        Just IxValue (Map NormalizedUri VirtualFile)
_  -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldOverwrite forall a b. (a -> b) -> a -> b
$ do
          forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
oldUri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Maybe a
Nothing
          forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
newUri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 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 (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri) Maybe DeleteFileOptions
options Maybe ChangeAnnotationIdentifier
_ann) = do
  -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe DeleteFileOptions
options forall s a. s -> Getting (First a) s a -> Maybe a
^? forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasRecursive s a => Lens' s a
J.recursive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True) forall a b. (a -> b) -> a -> b
$
    LogAction m (WithSeverity VfsLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
CantRecursiveDelete NormalizedUri
uri 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 <- forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
uri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m b
<.= 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 forall s a. s -> Getting (First a) s a -> Maybe a
^? forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasIgnoreIfNotExists s a => Lens' s a
J.ignoreIfNotExists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Bool
True ->
              LogAction m (WithSeverity VfsLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
CantRecursiveDelete NormalizedUri
uri forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
    Maybe (IxValue (Map NormalizedUri VirtualFile))
_ -> 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 VersionedTextDocumentIdentifier
vid (J.List [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 = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextEdit |? AnnotatedTextEdit) -> Range
editRange) [TextEdit |? AnnotatedTextEdit]
edits
      changeEvents :: [TextDocumentContentChangeEvent]
changeEvents = forall a b. (a -> b) -> [a] -> [b]
map (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent [TextEdit |? AnnotatedTextEdit]
sortedEdits
      ps :: DidChangeTextDocumentParams
ps = VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> DidChangeTextDocumentParams
J.DidChangeTextDocumentParams VersionedTextDocumentIdentifier
vid (forall a. [a] -> List a
J.List [TextDocumentContentChangeEvent]
changeEvents)
      notif :: NotificationMessage @'FromClient 'TextDocumentDidChange
notif = forall (f :: From) (m :: Method f 'Notification).
Text
-> SMethod @f @'Notification m
-> MessageParams @f @'Notification m
-> NotificationMessage @f m
J.NotificationMessage Text
"" SMethod @'FromClient @'Notification 'TextDocumentDidChange
J.STextDocumentDidChange DidChangeTextDocumentParams
ps
  forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromClient @'Notification 'TextDocumentDidChange
-> m ()
changeFromClientVFS LogAction m (WithSeverity VfsLog)
logger NotificationMessage @'FromClient 'TextDocumentDidChange
notif

  where
    editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range
    editRange :: (TextEdit |? AnnotatedTextEdit) -> Range
editRange (J.InR AnnotatedTextEdit
e) = AnnotatedTextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
J.range
    editRange (J.InL TextEdit
e) = TextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
J.range

    editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent
    editToChangeEvent :: (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent (J.InR AnnotatedTextEdit
e) = Maybe Range -> Maybe UInt -> Text -> TextDocumentContentChangeEvent
J.TextDocumentContentChangeEvent (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AnnotatedTextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
J.range) forall a. Maybe a
Nothing (AnnotatedTextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasNewText s a => Lens' s a
J.newText)
    editToChangeEvent (J.InL TextEdit
e) = Maybe Range -> Maybe UInt -> Text -> TextDocumentContentChangeEvent
J.TextDocumentContentChangeEvent (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
J.range) forall a. Maybe a
Nothing (TextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasNewText s a => Lens' s a
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)   = 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))  = forall (m :: * -> *). MonadState VFS m => CreateFile -> m ()
applyCreateFile CreateFile
change
applyDocumentChange LogAction m (WithSeverity VfsLog)
_      (J.InR (J.InR (J.InL RenameFile
change))) = forall (m :: * -> *). MonadState VFS m => RenameFile -> m ()
applyRenameFile RenameFile
change
applyDocumentChange LogAction m (WithSeverity VfsLog)
logger (J.InR (J.InR (J.InR DeleteFile
change))) = 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.Message 'J.WorkspaceApplyEdit -> m ()
changeFromServerVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromServer @'Request 'WorkspaceApplyEdit -> m ()
changeFromServerVFS LogAction m (WithSeverity VfsLog)
logger Message @'FromServer @'Request 'WorkspaceApplyEdit
msg = do
  let J.ApplyWorkspaceEditParams Maybe Text
_label WorkspaceEdit
edit = Message @'FromServer @'Request 'WorkspaceApplyEdit
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params
      J.WorkspaceEdit Maybe WorkspaceEditMap
mChanges Maybe (List DocumentChange)
mDocChanges Maybe ChangeAnnotationMap
_anns = WorkspaceEdit
edit
  case Maybe (List DocumentChange)
mDocChanges of
    Just (J.List [DocumentChange]
docChanges) -> [DocumentChange] -> m ()
applyDocumentChanges [DocumentChange]
docChanges
    Maybe (List DocumentChange)
Nothing -> case Maybe WorkspaceEditMap
mChanges of
      Just WorkspaceEditMap
cs -> [DocumentChange] -> m ()
applyDocumentChanges forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> a |? b
J.InL forall a b. (a -> b) -> a -> b
$ forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HashMap.foldlWithKey' [TextDocumentEdit] -> Uri -> List TextEdit -> [TextDocumentEdit]
changeToTextDocumentEdit [] WorkspaceEditMap
cs
      Maybe WorkspaceEditMap
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  where
    changeToTextDocumentEdit :: [TextDocumentEdit] -> Uri -> List TextEdit -> [TextDocumentEdit]
changeToTextDocumentEdit [TextDocumentEdit]
acc Uri
uri List TextEdit
edits =
      [TextDocumentEdit]
acc forall a. [a] -> [a] -> [a]
++ [VersionedTextDocumentIdentifier
-> List (TextEdit |? AnnotatedTextEdit) -> TextDocumentEdit
J.TextDocumentEdit (Uri -> TextDocumentVersion -> VersionedTextDocumentIdentifier
J.VersionedTextDocumentIdentifier Uri
uri (forall a. a -> Maybe a
Just Int32
0)) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> a |? b
J.InL List TextEdit
edits)]

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

    -- for sorting [DocumentChange]
    project :: J.DocumentChange -> J.TextDocumentVersion -- type TextDocumentVersion = Maybe Int
    project :: DocumentChange -> TextDocumentVersion
project (J.InL TextDocumentEdit
textDocumentEdit) = TextDocumentEdit
textDocumentEdit forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
J.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasVersion s a => Lens' s a
J.version
    project DocumentChange
_ = 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 = 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 = forall a. Show a => a -> [Char]
show Int
num
        in forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
numString) Char
'0' forall a. [a] -> [a] -> [a]
++ [Char]
numString
  in [Char]
prefix [Char] -> ShowS
</> [Char]
basename forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ Int -> Int -> [Char]
padLeft Int
5 Int
file_ver forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Hashable a => a -> Int
hash Uri
uri_raw) [Char] -> ShowS
<.> ShowS
takeExtensions [Char]
basename

-- | Write a virtual file to a temporary file if it exists in the VFS.
persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ())
persistFileVFS :: forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity VfsLog)
-> VFS -> NormalizedUri -> Maybe ([Char], m ())
persistFileVFS LogAction m (WithSeverity VfsLog)
logger VFS
vfs NormalizedUri
uri =
  case VFS
vfs forall s a. s -> Getting a s a -> a
^. forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
uri of
    Maybe VirtualFile
Nothing -> forall a. Maybe a
Nothing
    Just VirtualFile
vf ->
      let tfn :: [Char]
tfn = [Char] -> NormalizedUri -> VirtualFile -> [Char]
virtualFileName (VFS
vfs forall s a. s -> Getting a s a -> a
^. forall s a. HasVfsTempDir s a => Lens' s a
vfsTempDir) NormalizedUri
uri VirtualFile
vf
          action :: m ()
action = do
            Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
tfn
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists 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 forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> [Char] -> VfsLog
PersistingFile NormalizedUri
uri [Char]
tfn forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
               forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
tfn IOMode
WriteMode Handle -> IO ()
writeRaw
      in forall a. a -> Maybe a
Just ([Char]
tfn, m ()
action)

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

closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidClose -> m ()
closeVFS :: forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromClient @'Notification 'TextDocumentDidClose
-> m ()
closeVFS LogAction m (WithSeverity VfsLog)
logger Message @'FromClient @'Notification 'TextDocumentDidClose
msg = do
  let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier (Uri -> NormalizedUri
J.toNormalizedUri -> NormalizedUri
uri)) = Message @'FromClient @'Notification 'TextDocumentDidClose
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params
  LogAction m (WithSeverity VfsLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& NormalizedUri -> VfsLog
Closing NormalizedUri
uri forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at NormalizedUri
uri forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 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 = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (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)
_ Rope
_ (J.TextDocumentContentChangeEvent Maybe Range
Nothing Maybe UInt
_ Text
str)
  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Rope
Rope.fromText Text
str
applyChange LogAction m (WithSeverity VfsLog)
logger Rope
str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position UInt
sl UInt
sc) (J.Position UInt
fl UInt
fc))) Maybe UInt
_ Text
txt)
  = 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
Rope.Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sl) (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sc)) (Word -> Word -> Position
Rope.Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
fl) (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
fc)) Text
txt

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

-- | 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 -> Rope.Position -> Rope.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.splitAtPosition Position
finish Rope
str of
   Maybe (Rope, Rope)
Nothing -> LogAction m (WithSeverity VfsLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Position -> Rope -> VfsLog
SplitInsideCodePoint Position
finish Rope
str forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
str
   Just (Rope
before, Rope
after) ->  case Position -> Rope -> Maybe (Rope, Rope)
Rope.splitAtPosition Position
start Rope
before of
     Maybe (Rope, Rope)
Nothing -> LogAction m (WithSeverity VfsLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Position -> Rope -> VfsLog
SplitInsideCodePoint Position
start Rope
before forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
str
     Just (Rope
before', Rope
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
    { -- | Line position in a document (zero-based).
      CodePointPosition -> UInt
_line      :: J.UInt
      -- | Character offset on a line in a document in *code points* (zero-based).
    , CodePointPosition -> UInt
_character :: J.UInt
    } deriving (Int -> CodePointPosition -> ShowS
[CodePointPosition] -> ShowS
CodePointPosition -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CodePointPosition] -> ShowS
$cshowList :: [CodePointPosition] -> ShowS
show :: CodePointPosition -> [Char]
$cshow :: CodePointPosition -> [Char]
showsPrec :: Int -> CodePointPosition -> ShowS
$cshowsPrec :: Int -> CodePointPosition -> ShowS
Show, ReadPrec [CodePointPosition]
ReadPrec CodePointPosition
Int -> ReadS CodePointPosition
ReadS [CodePointPosition]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CodePointPosition]
$creadListPrec :: ReadPrec [CodePointPosition]
readPrec :: ReadPrec CodePointPosition
$creadPrec :: ReadPrec CodePointPosition
readList :: ReadS [CodePointPosition]
$creadList :: ReadS [CodePointPosition]
readsPrec :: Int -> ReadS CodePointPosition
$creadsPrec :: Int -> ReadS CodePointPosition
Read, CodePointPosition -> CodePointPosition -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodePointPosition -> CodePointPosition -> Bool
$c/= :: CodePointPosition -> CodePointPosition -> Bool
== :: CodePointPosition -> CodePointPosition -> Bool
$c== :: CodePointPosition -> CodePointPosition -> Bool
Eq, Eq 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
min :: CodePointPosition -> CodePointPosition -> CodePointPosition
$cmin :: CodePointPosition -> CodePointPosition -> CodePointPosition
max :: CodePointPosition -> CodePointPosition -> CodePointPosition
$cmax :: CodePointPosition -> CodePointPosition -> CodePointPosition
>= :: CodePointPosition -> CodePointPosition -> Bool
$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
compare :: CodePointPosition -> CodePointPosition -> Ordering
$ccompare :: CodePointPosition -> CodePointPosition -> Ordering
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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CodePointRange] -> ShowS
$cshowList :: [CodePointRange] -> ShowS
show :: CodePointRange -> [Char]
$cshow :: CodePointRange -> [Char]
showsPrec :: Int -> CodePointRange -> ShowS
$cshowsPrec :: Int -> CodePointRange -> ShowS
Show, ReadPrec [CodePointRange]
ReadPrec CodePointRange
Int -> ReadS CodePointRange
ReadS [CodePointRange]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CodePointRange]
$creadListPrec :: ReadPrec [CodePointRange]
readPrec :: ReadPrec CodePointRange
$creadPrec :: ReadPrec CodePointRange
readList :: ReadS [CodePointRange]
$creadList :: ReadS [CodePointRange]
readsPrec :: Int -> ReadS CodePointRange
$creadsPrec :: Int -> ReadS CodePointRange
Read, CodePointRange -> CodePointRange -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodePointRange -> CodePointRange -> Bool
$c/= :: CodePointRange -> CodePointRange -> Bool
== :: CodePointRange -> CodePointRange -> Bool
$c== :: CodePointRange -> CodePointRange -> Bool
Eq, Eq 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
min :: CodePointRange -> CodePointRange -> CodePointRange
$cmin :: CodePointRange -> CodePointRange -> CodePointRange
max :: CodePointRange -> CodePointRange -> CodePointRange
$cmax :: CodePointRange -> CodePointRange -> CodePointRange
>= :: CodePointRange -> CodePointRange -> Bool
$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
compare :: CodePointRange -> CodePointRange -> Ordering
$ccompare :: CodePointRange -> CodePointRange -> Ordering
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.

We also may need to convert the line back and forth between ropes with different indexing. Again
this is linear time in the length of the 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.
-}

-- | 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
Rope.posLine forall a b. (a -> b) -> a -> b
$ Rope -> Position
Rope.lengthAsPosition Rope
rope
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Word
l 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
prefix

-- | Translate a code-point offset into a code-unit offset.
-- Linear in the length of the rope.
codePointOffsetToCodeUnitOffset :: URope.Rope -> Word -> Maybe Word
codePointOffsetToCodeUnitOffset :: Rope -> Word -> Maybe Word
codePointOffsetToCodeUnitOffset Rope
rope Word
offset = do
  -- Check for the position being out of bounds
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Word
offset forall a. Ord a => a -> a -> Bool
<= Rope -> Word
URope.length Rope
rope
  -- Split at the given position in *code points*
  let (Rope
prefix, Rope
_) = Word -> Rope -> (Rope, Rope)
URope.splitAt Word
offset Rope
rope
      -- Convert the prefix to a rope using *code units*
      utf16Prefix :: Rope
utf16Prefix = Text -> Rope
Rope.fromText forall a b. (a -> b) -> a -> b
$ Rope -> Text
URope.toText Rope
prefix
      -- Get the length of the prefix in *code units*
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Rope -> Word
Rope.length Rope
utf16Prefix

-- | Translate a UTF-16 code-unit offset into a code-point offset.
-- Linear in the length of the rope.
codeUnitOffsetToCodePointOffset :: Rope.Rope -> Word -> Maybe Word
codeUnitOffsetToCodePointOffset :: Rope -> Word -> Maybe Word
codeUnitOffsetToCodePointOffset Rope
rope Word
offset = do
  -- Check for the position being out of bounds
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Word
offset forall a. Ord a => a -> a -> Bool
<= Rope -> Word
Rope.length Rope
rope
  -- Split at the given position in *code units*
  (Rope
prefix, Rope
_) <- Word -> Rope -> Maybe (Rope, Rope)
Rope.splitAt Word
offset Rope
rope
  -- Convert the prefix to a rope using *code points*
  let utfPrefix :: Rope
utfPrefix = Text -> Rope
URope.fromText forall a b. (a -> b) -> a -> b
$ Rope -> Text
Rope.toText Rope
prefix
      -- Get the length of the prefix in *code points*
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Rope -> Word
URope.length Rope
utfPrefix

-- | 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
cpc) = do
  -- See Note [Converting between code points and code units]
  let text :: Rope
text = VirtualFile -> Rope
_file_text VirtualFile
vFile
  Rope
utf16Line <- Rope -> Word -> Maybe Rope
extractLine Rope
text (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l)
  -- Convert the line a rope using *code points*
  let utfLine :: Rope
utfLine = Text -> Rope
URope.fromText forall a b. (a -> b) -> a -> b
$ Rope -> Text
Rope.toText Rope
utf16Line

  Word
cuc <- Rope -> Word -> Maybe Word
codePointOffsetToCodeUnitOffset Rope
utfLine (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
cpc)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ UInt -> UInt -> Position
J.Position UInt
l (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
cuc)

-- | 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VirtualFile -> CodePointPosition -> Maybe Position
codePointPositionToPosition VirtualFile
vFile CodePointPosition
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
cuc) = do
  -- See Note [Converting between code points and code units]
  let text :: Rope
text = VirtualFile -> Rope
_file_text VirtualFile
vFile
  Rope
utf16Line <- Rope -> Word -> Maybe Rope
extractLine Rope
text (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l)

  Word
cpc <- Rope -> Word -> Maybe Word
codeUnitOffsetToCodePointOffset Rope
utf16Line (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
cuc)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ UInt -> UInt -> CodePointPosition
CodePointPosition UInt
l (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
cpc)

-- | 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VirtualFile -> Position -> Maybe CodePointPosition
positionToCodePointPosition VirtualFile
vFile Position
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VirtualFile -> Position -> Maybe CodePointPosition
positionToCodePointPosition VirtualFile
vFile Position
e

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

-- TODO:AZ:move this to somewhere sane
-- | Describes the line at the current cursor position
data PosPrefixInfo = PosPrefixInfo
  { PosPrefixInfo -> Text
fullLine :: !T.Text
    -- ^ The full contents of the line the cursor is at

  , PosPrefixInfo -> Text
prefixModule :: !T.Text
    -- ^ If any, the module name that was typed right before the cursor position.
    --  For example, if the user has typed "Data.Maybe.from", then this property
    --  will be "Data.Maybe"

  , PosPrefixInfo -> Text
prefixText :: !T.Text
    -- ^ The word right before the cursor position, after removing the module part.
    -- For example if the user has typed "Data.Maybe.from",
    -- then this property will be "from"
  , PosPrefixInfo -> Position
cursorPos :: !J.Position
    -- ^ The cursor position
  } deriving (Int -> PosPrefixInfo -> ShowS
[PosPrefixInfo] -> ShowS
PosPrefixInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PosPrefixInfo] -> ShowS
$cshowList :: [PosPrefixInfo] -> ShowS
show :: PosPrefixInfo -> [Char]
$cshow :: PosPrefixInfo -> [Char]
showsPrec :: Int -> PosPrefixInfo -> ShowS
$cshowsPrec :: Int -> PosPrefixInfo -> ShowS
Show,PosPrefixInfo -> PosPrefixInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PosPrefixInfo -> PosPrefixInfo -> Bool
$c/= :: PosPrefixInfo -> PosPrefixInfo -> Bool
== :: PosPrefixInfo -> PosPrefixInfo -> Bool
$c== :: PosPrefixInfo -> PosPrefixInfo -> Bool
Eq)

getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo)
getCompletionPrefix :: forall (m :: * -> *).
Monad m =>
Position -> VirtualFile -> m (Maybe PosPrefixInfo)
getCompletionPrefix pos :: Position
pos@(J.Position UInt
l UInt
c) (VirtualFile Int32
_ Int
_ Rope
ropetext) =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (Text -> Text -> Text -> Position -> PosPrefixInfo
PosPrefixInfo Text
"" Text
"" Text
"" Position
pos) forall a b. (a -> b) -> a -> b
$ do -- Maybe monad
        let lastMaybe :: [a] -> Maybe a
lastMaybe [] = forall a. Maybe a
Nothing
            lastMaybe [a]
xs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [a]
xs

        let curRope :: Rope
curRope = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Word -> Rope -> (Rope, Rope)
Rope.splitAtLine Word
1 forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Word -> Rope -> (Rope, Rope)
Rope.splitAtLine (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
l) Rope
ropetext
        Text
beforePos <- Rope -> Text
Rope.toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Rope -> Maybe (Rope, Rope)
Rope.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
c) Rope
curRope
        Text
curWord <-
            if | Text -> Bool
T.null Text
beforePos -> forall a. a -> Maybe a
Just Text
""
               | Text -> Char
T.last Text
beforePos forall a. Eq a => a -> a -> Bool
== Char
' ' -> forall a. a -> Maybe a
Just Text
"" -- don't count abc as the curword in 'abc '
               | Bool
otherwise -> forall {a}. [a] -> Maybe a
lastMaybe (Text -> [Text]
T.words Text
beforePos)

        let parts :: [Text]
parts = (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'.')
                      forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd (\Char
x -> Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"._'"::String)) Text
curWord
        case forall a. [a] -> [a]
reverse [Text]
parts of
          [] -> forall a. Maybe a
Nothing
          (Text
x:[Text]
xs) -> do
            let modParts :: [Text]
modParts = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head)
                                forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
.Text -> Bool
T.null) [Text]
xs
                modName :: Text
modName = Text -> [Text] -> Text
T.intercalate Text
"." [Text]
modParts
            -- curRope is already a single line, but it may include an enclosing '\n'
            let curLine :: Text
curLine = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'\n') forall a b. (a -> b) -> a -> b
$ Rope -> Text
Rope.toText Rope
curRope
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Position -> PosPrefixInfo
PosPrefixInfo Text
curLine Text
modName Text
x Position
pos

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

rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text
rangeLinesFromVfs :: VirtualFile -> Range -> Text
rangeLinesFromVfs (VirtualFile Int32
_ Int
_ Rope
ropetext) (J.Range (J.Position UInt
lf UInt
_cf) (J.Position UInt
lt UInt
_ct)) = Text
r
  where
    (Rope
_ ,Rope
s1) = Word -> Rope -> (Rope, Rope)
Rope.splitAtLine (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
lf) Rope
ropetext
    (Rope
s2, Rope
_) = Word -> Rope -> (Rope, Rope)
Rope.splitAtLine (forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt
lt forall a. Num a => a -> a -> a
- UInt
lf)) Rope
s1
    r :: Text
r = Rope -> Text
Rope.toText Rope
s2
-- ---------------------------------------------------------------------