{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.LSP.Test.Files
  ( swapFiles
  , rootDir
  )
where

import           Language.LSP.Types
import           Language.LSP.Types.Lens hiding (id)
import           Control.Lens
import qualified Data.HashMap.Strict           as HM
import qualified Data.Text                     as T
import           Data.Maybe
import           System.Directory
import           System.FilePath
import Data.Time.Clock

data Event
  = ClientEv UTCTime FromClientMessage
  | ServerEv UTCTime FromServerMessage

swapFiles :: FilePath -> [Event] -> IO [Event]
swapFiles :: FilePath -> [Event] -> IO [Event]
swapFiles FilePath
relCurBaseDir [Event]
msgs = do
  let capturedBaseDir :: FilePath
capturedBaseDir = [Event] -> FilePath
rootDir [Event]
msgs

  FilePath
curBaseDir <- (FilePath -> FilePath -> FilePath
</> FilePath
relCurBaseDir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getCurrentDirectory
  let transform :: Uri -> Uri
transform Uri
uri =
        let fp :: FilePath
fp = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
error FilePath
"Couldn't transform uri") (Uri -> Maybe FilePath
uriToFilePath Uri
uri)
            newFp :: FilePath
newFp = FilePath
curBaseDir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
makeRelative FilePath
capturedBaseDir FilePath
fp
          in FilePath -> Uri
filePathToUri FilePath
newFp
      newMsgs :: [Event]
newMsgs = forall a b. (a -> b) -> [a] -> [b]
map ((Uri -> Uri) -> Event -> Event
mapUris Uri -> Uri
transform) [Event]
msgs

  forall (m :: * -> *) a. Monad m => a -> m a
return [Event]
newMsgs

rootDir :: [Event] -> FilePath
rootDir :: [Event] -> FilePath
rootDir (ClientEv UTCTime
_ (FromClientMess SMethod m
SInitialize Message m
req):[Event]
_) =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
error FilePath
"Couldn't find root dir") forall a b. (a -> b) -> a -> b
$ do
    Uri
rootUri <- Message m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasRootUri s a => Lens' s a
rootUri
    Uri -> Maybe FilePath
uriToFilePath Uri
rootUri
rootDir [Event]
_ = forall a. HasCallStack => FilePath -> a
error FilePath
"Couldn't find initialize request in session"

mapUris :: (Uri -> Uri) -> Event -> Event
mapUris :: (Uri -> Uri) -> Event -> Event
mapUris Uri -> Uri
f Event
event =
  case Event
event of
    ClientEv UTCTime
t FromClientMessage' SMethod
msg -> UTCTime -> FromClientMessage' SMethod -> Event
ClientEv UTCTime
t (forall {a :: Method 'FromServer 'Request -> *}.
FromClientMessage' a -> FromClientMessage' a
fromClientMsg FromClientMessage' SMethod
msg)
    ServerEv UTCTime
t FromServerMessage
msg -> UTCTime -> FromServerMessage -> Event
ServerEv UTCTime
t (FromServerMessage -> FromServerMessage
fromServerMsg FromServerMessage
msg)

  where
    --TODO: Handle all other URIs that might need swapped
    fromClientMsg :: FromClientMessage' a -> FromClientMessage' a
fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SInitialize                 Message m
r) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall s a. HasParams s a => Lens' s a
params forall s t a b. ASetter s t a b -> b -> s -> t
.~ InitializeParams -> InitializeParams
transformInit (Message m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params) forall a b. (a -> b) -> a -> b
$ Message m
r
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
STextDocumentDidOpen        Message m
n) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri (forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) Message m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
STextDocumentDidChange      Message m
n) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri (forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) Message m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
STextDocumentWillSave       Message m
n) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri (forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) Message m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
STextDocumentDidSave        Message m
n) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri (forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) Message m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
STextDocumentDidClose       Message m
n) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri (forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) Message m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
STextDocumentDocumentSymbol Message m
n) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri (forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) Message m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
STextDocumentRename         Message m
n) = forall (t :: MethodType) (m :: Method 'FromClient t)
       (a :: Method 'FromServer 'Request -> *).
SMethod m -> Message m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri (forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) Message m
n
    fromClientMsg FromClientMessage' a
x = FromClientMessage' a
x

    fromServerMsg :: FromServerMessage -> FromServerMessage
    fromServerMsg :: FromServerMessage -> FromServerMessage
fromServerMsg (FromServerMess m :: SMethod m
m@SMethod m
SWorkspaceApplyEdit Message m
r) = forall (t :: MethodType) (m :: Method 'FromServer t)
       (a :: Method 'FromClient 'Request -> *).
SMethod m -> Message m -> FromServerMessage' a
FromServerMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
edit forall s t a b. ASetter s t a b -> b -> s -> t
.~ WorkspaceEdit -> WorkspaceEdit
swapWorkspaceEdit (Message m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
edit) forall a b. (a -> b) -> a -> b
$ Message m
r
    fromServerMsg (FromServerMess m :: SMethod m
m@SMethod m
STextDocumentPublishDiagnostics Message m
n) = forall (t :: MethodType) (m :: Method 'FromServer t)
       (a :: Method 'FromClient 'Request -> *).
SMethod m -> Message m -> FromServerMessage' a
FromServerMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri forall s a. HasParams s a => Lens' s a
params Message m
n
    fromServerMsg (FromServerRsp m :: SMethod m
m@SMethod m
STextDocumentDocumentSymbol ResponseMessage m
r) =
      let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation
          swapUri' :: (List DocumentSymbol |? List SymbolInformation)
-> List DocumentSymbol |? List SymbolInformation
swapUri' (InR List SymbolInformation
si) = forall a b. b -> a |? b
InR (forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri forall s a. HasLocation s a => Lens' s a
location forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List SymbolInformation
si)
          swapUri' (InL List DocumentSymbol
dss) = forall a b. a -> a |? b
InL List DocumentSymbol
dss -- no file locations here
      in forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage m -> FromServerMessage' a
FromServerRsp SMethod m
m forall a b. (a -> b) -> a -> b
$ ResponseMessage m
r forall a b. a -> (a -> b) -> b
& forall s a. HasResult s a => Lens' s a
result forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (List DocumentSymbol |? List SymbolInformation)
-> List DocumentSymbol |? List SymbolInformation
swapUri')
    fromServerMsg (FromServerRsp m :: SMethod m
m@SMethod m
STextDocumentRename ResponseMessage m
r) = forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage m -> FromServerMessage' a
FromServerRsp SMethod m
m forall a b. (a -> b) -> a -> b
$ ResponseMessage m
r forall a b. a -> (a -> b) -> b
& forall s a. HasResult s a => Lens' s a
result forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WorkspaceEdit -> WorkspaceEdit
swapWorkspaceEdit)
    fromServerMsg FromServerMessage
x = FromServerMessage
x

    swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
    swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
swapWorkspaceEdit WorkspaceEdit
e =
      let swapDocumentChangeUri :: DocumentChange -> DocumentChange
          swapDocumentChangeUri :: DocumentChange -> DocumentChange
swapDocumentChangeUri (InL TextDocumentEdit
textDocEdit) = forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri forall s a. HasTextDocument s a => Lens' s a
textDocument TextDocumentEdit
textDocEdit
          swapDocumentChangeUri (InR (InL CreateFile
createFile)) = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri forall a. a -> a
id CreateFile
createFile
          -- for RenameFile, we swap `newUri`
          swapDocumentChangeUri (InR (InR (InL RenameFile
renameFile))) = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall s a. HasNewUri s a => Lens' s a
newUri forall s t a b. ASetter s t a b -> b -> s -> t
.~ Uri -> Uri
f (RenameFile
renameFile forall s a. s -> Getting a s a -> a
^. forall s a. HasNewUri s a => Lens' s a
newUri) forall a b. (a -> b) -> a -> b
$ RenameFile
renameFile
          swapDocumentChangeUri (InR (InR (InR DeleteFile
deleteFile))) = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri forall a. a -> a
id DeleteFile
deleteFile

          newDocChanges :: Maybe (List DocumentChange)
newDocChanges = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DocumentChange -> DocumentChange
swapDocumentChangeUri) forall a b. (a -> b) -> a -> b
$ WorkspaceEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasDocumentChanges s a => Lens' s a
documentChanges
          newChanges :: Maybe (HashMap Uri (List TextEdit))
newChanges = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b. (Uri -> Uri) -> HashMap Uri b -> HashMap Uri b
swapKeys Uri -> Uri
f) forall a b. (a -> b) -> a -> b
$ WorkspaceEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasChanges s a => Lens' s a
changes
       in Maybe (HashMap Uri (List TextEdit))
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit Maybe (HashMap Uri (List TextEdit))
newChanges Maybe (List DocumentChange)
newDocChanges forall a. Maybe a
Nothing

    swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
    swapKeys :: forall b. (Uri -> Uri) -> HashMap Uri b -> HashMap Uri b
swapKeys Uri -> Uri
f = forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HM.foldlWithKey' (\HashMap Uri b
acc Uri
k b
v -> forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (Uri -> Uri
f Uri
k) b
v HashMap Uri b
acc) forall k v. HashMap k v
HM.empty

    swapUri :: HasUri b Uri => Lens' a b -> a -> a
    swapUri :: forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri Lens' a b
lens a
x =
      let newUri :: Uri
newUri = Uri -> Uri
f (a
x forall s a. s -> Getting a s a -> a
^. Lens' a b
lens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
uri)
        in (Lens' a b
lens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
uri) forall s t a b. ASetter s t a b -> b -> s -> t
.~ Uri
newUri forall a b. (a -> b) -> a -> b
$ a
x

    -- | Transforms rootUri/rootPath.
    transformInit :: InitializeParams -> InitializeParams
    transformInit :: InitializeParams -> InitializeParams
transformInit InitializeParams
x =
      let newRootUri :: Maybe Uri
newRootUri = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Uri -> Uri
f (InitializeParams
x forall s a. s -> Getting a s a -> a
^. forall s a. HasRootUri s a => Lens' s a
rootUri)
          newRootPath :: Maybe Text
newRootPath = do
            FilePath
fp <- Text -> FilePath
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitializeParams
x forall s a. s -> Getting a s a -> a
^. forall s a. HasRootPath s a => Lens' s a
rootPath
            let uri :: Uri
uri = FilePath -> Uri
filePathToUri FilePath
fp
            FilePath -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> Maybe FilePath
uriToFilePath (Uri -> Uri
f Uri
uri)
        in (forall s a. HasRootUri s a => Lens' s a
rootUri forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Uri
newRootUri) forall a b. (a -> b) -> a -> b
$ (forall s a. HasRootPath s a => Lens' s a
rootPath forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Text
newRootPath) InitializeParams
x