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

import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import qualified Language.LSP.Protocol.Lens    as L
import           Control.Lens
import qualified Data.Map.Strict               as M
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
SMethod_Initialize TMessage 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 <- case TMessage m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasRootUri s a => Lens' s a
L.rootUri of
        InL Uri
r -> forall a. a -> Maybe a
Just Uri
r
        InR Null
_ -> forall a. HasCallStack => FilePath -> a
error FilePath
"Couldn't find root dir"
    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 'ServerToClient '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
SMethod_Initialize                 TMessage m
r) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage m -> FromClientMessage' a
FromClientMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall s a. HasParams s a => Lens' s a
L.params forall s t a b. ASetter s t a b -> b -> s -> t
.~ InitializeParams -> InitializeParams
transformInit (TMessage m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params) forall a b. (a -> b) -> a -> b
$ TMessage m
r
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentDidOpen        TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage 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
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument) TMessage m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentDidChange      TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage 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
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument) TMessage m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentWillSave       TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage 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
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument) TMessage m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentDidSave        TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage 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
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument) TMessage m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentDidClose       TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage 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
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument) TMessage m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentDocumentSymbol TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage 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
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument) TMessage m
n
    fromClientMsg (FromClientMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentRename         TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ClientToServer t)
       (a :: Method 'ServerToClient 'Request -> *).
SMethod m -> TMessage 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
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument) TMessage m
n
    fromClientMsg FromClientMessage' a
x = FromClientMessage' a
x

    fromServerMsg :: FromServerMessage -> FromServerMessage
    fromServerMsg :: FromServerMessage -> FromServerMessage
fromServerMsg (FromServerMess m :: SMethod m
m@SMethod m
SMethod_WorkspaceApplyEdit TMessage m
r) = forall (t :: MessageKind) (m :: Method 'ServerToClient t)
       (a :: Method 'ClientToServer 'Request -> *).
SMethod m -> TMessage m -> FromServerMessage' a
FromServerMess SMethod m
m forall a b. (a -> b) -> a -> b
$ forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
L.edit forall s t a b. ASetter s t a b -> b -> s -> t
.~ WorkspaceEdit -> WorkspaceEdit
swapWorkspaceEdit (TMessage m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
L.edit) forall a b. (a -> b) -> a -> b
$ TMessage m
r
    fromServerMsg (FromServerMess m :: SMethod m
m@SMethod m
SMethod_TextDocumentPublishDiagnostics TMessage m
n) = forall (t :: MessageKind) (m :: Method 'ServerToClient t)
       (a :: Method 'ClientToServer 'Request -> *).
SMethod m -> TMessage 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
L.params TMessage m
n
    fromServerMsg (FromServerRsp m :: SMethod m
m@SMethod m
SMethod_TextDocumentDocumentSymbol TResponseMessage m
r) =
      let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null
          swapUri' :: ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
swapUri' (InR (InL [DocumentSymbol]
dss)) = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL [DocumentSymbol]
dss -- no file locations here
          swapUri' (InR (InR Null
n)) = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
n
          swapUri' (InL [SymbolInformation]
si) = forall a b. a -> a |? b
InL (forall b a. HasUri b Uri => Lens' a b -> a -> a
swapUri forall s a. HasLocation s a => Lens' s a
L.location forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SymbolInformation]
si)
      in forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage m -> FromServerMessage' a
FromServerRsp SMethod m
m forall a b. (a -> b) -> a -> b
$ TResponseMessage m
r forall a b. a -> (a -> b) -> b
& forall s a. HasResult s a => Lens' s a
L.result forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
swapUri'
    fromServerMsg (FromServerRsp m :: SMethod m
m@SMethod m
SMethod_TextDocumentRename TResponseMessage m
r) = forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage m -> FromServerMessage' a
FromServerRsp SMethod m
m forall a b. (a -> b) -> a -> b
$ TResponseMessage m
r forall a b. a -> (a -> b) -> b
& forall s a. HasResult s a => Lens' s a
L.result forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ 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
L.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
L.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
L.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
       in WorkspaceEdit
e forall a b. a -> (a -> b) -> b
& forall s a. HasChanges s a => Lens' s a
L.changes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall b. (Uri -> Uri) -> Map Uri b -> Map Uri b
swapKeys Uri -> Uri
f
            forall a b. a -> (a -> b) -> b
& forall s a. HasDocumentChanges s a => Lens' s a
L.documentChanges forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversedforall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DocumentChange -> DocumentChange
swapDocumentChangeUri

    swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b
    swapKeys :: forall b. (Uri -> Uri) -> Map Uri b -> Map Uri b
swapKeys Uri -> Uri
f = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' (\Map Uri b
acc Uri
k b
v -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Uri -> Uri
f Uri
k) b
v Map Uri b
acc) forall k a. Map k a
M.empty

    swapUri :: L.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
L.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
L.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 modifyRootPath :: Text -> Text
modifyRootPath Text
p =
            let fp :: FilePath
fp = Text -> FilePath
T.unpack Text
p
                uri :: Uri
uri = FilePath -> Uri
filePathToUri FilePath
fp
            in case Uri -> Maybe FilePath
uriToFilePath (Uri -> Uri
f Uri
uri) of
              Just FilePath
fp -> FilePath -> Text
T.pack FilePath
fp
              Maybe FilePath
Nothing -> Text
p
      in InitializeParams
x forall a b. a -> (a -> b) -> b
& forall s a. HasRootUri s a => Lens' s a
L.rootUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Uri -> Uri
f
           forall a b. a -> (a -> b) -> b
& forall s a. HasRootPath s a => Lens' s a
L.rootPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Text
modifyRootPath