src/Language/Haskell/LSP/Test/Files.hs

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