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

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