src/Language/LSP/Test/Files.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE TypeOperators #-}
   3 {-# LANGUAGE TypeInType #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE RankNTypes #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 module Language.LSP.Test.Files
   8   ( swapFiles
   9   , rootDir
  10   )
  11 where
  12
  13 import           Language.LSP.Types
  14 import           Language.LSP.Types.Lens hiding (id)
  15 import           Control.Lens
  16 import qualified Data.HashMap.Strict           as HM
  17 import qualified Data.Text                     as T
  18 import           Data.Maybe
  19 import           System.Directory
  20 import           System.FilePath
  21 import Data.Time.Clock
  22
  23 data Event
  24   = ClientEv UTCTime FromClientMessage
  25   | ServerEv UTCTime FromServerMessage
  26
  27 swapFiles :: FilePath -> [Event] -> IO [Event]
  28 swapFiles relCurBaseDir msgs = do
  29   let capturedBaseDir = rootDir msgs
  30
  31   curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
  32   let transform uri =
  33         let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
  34             newFp = curBaseDir </> makeRelative capturedBaseDir fp
  35           in filePathToUri newFp
  36       newMsgs = map (mapUris transform) msgs
  37
  38   return newMsgs
  39
  40 rootDir :: [Event] -> FilePath
  41 rootDir (ClientEv _ (FromClientMess SInitialize req):_) =
  42   fromMaybe (error "Couldn't find root dir") $ do
  43     rootUri <- req ^. params .rootUri
  44     uriToFilePath rootUri
  45 rootDir _ = error "Couldn't find initialize request in session"
  46
  47 mapUris :: (Uri -> Uri) -> Event -> Event
  48 mapUris f event =
  49   case event of
  50     ClientEv t msg -> ClientEv t (fromClientMsg msg)
  51     ServerEv t msg -> ServerEv t (fromServerMsg msg)
  52
  53   where
  54     --TODO: Handle all other URIs that might need swapped
  55     fromClientMsg (FromClientMess m@SInitialize                 r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r
  56     fromClientMsg (FromClientMess m@STextDocumentDidOpen        n) = FromClientMess m $ swapUri (params . textDocument) n
  57     fromClientMsg (FromClientMess m@STextDocumentDidChange      n) = FromClientMess m $ swapUri (params . textDocument) n
  58     fromClientMsg (FromClientMess m@STextDocumentWillSave       n) = FromClientMess m $ swapUri (params . textDocument) n
  59     fromClientMsg (FromClientMess m@STextDocumentDidSave        n) = FromClientMess m $ swapUri (params . textDocument) n
  60     fromClientMsg (FromClientMess m@STextDocumentDidClose       n) = FromClientMess m $ swapUri (params . textDocument) n
  61     fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n
  62     fromClientMsg (FromClientMess m@STextDocumentRename         n) = FromClientMess m $ swapUri (params . textDocument) n
  63     fromClientMsg x = x
  64
  65     fromServerMsg :: FromServerMessage -> FromServerMessage
  66     fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
  67     fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n
  68     fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) =
  69       let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation
  70           swapUri' (InR si) = InR (swapUri location <$> si)
  71           swapUri' (InL dss) = InL dss -- no file locations here
  72       in FromServerRsp m $ r & result %~ (fmap swapUri')
  73     fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)
  74     fromServerMsg x = x
  75
  76     swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
  77     swapWorkspaceEdit e =
  78       let swapDocumentChangeUri :: DocumentChange -> DocumentChange
  79           swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri textDocument textDocEdit
  80           swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile
  81           -- for RenameFile, we swap `newUri`
  82           swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ newUri .~ f (renameFile ^. newUri) $ renameFile
  83           swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile
  84
  85           newDocChanges = fmap (fmap swapDocumentChangeUri) $ e ^. documentChanges
  86           newChanges = fmap (swapKeys f) $ e ^. changes
  87        in WorkspaceEdit newChanges newDocChanges
  88
  89     swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
  90     swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
  91
  92     swapUri :: HasUri b Uri => Lens' a b -> a -> a
  93     swapUri lens x =
  94       let newUri = f (x ^. lens . uri)
  95         in (lens . uri) .~ newUri $ x
  96
  97     -- | Transforms rootUri/rootPath.
  98     transformInit :: InitializeParams -> InitializeParams
  99     transformInit x =
 100       let newRootUri = fmap f (x ^. rootUri)
 101           newRootPath = do
 102             fp <- T.unpack <$> x ^. rootPath
 103             let uri = filePathToUri fp
 104             T.pack <$> uriToFilePath (f uri)
 105         in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x