- Nothing -> error "Couldn't find root dir"
-
-extractUris :: B.ByteString -> Set.Set Uri
-extractUris msgs =
- case decode msgs :: Maybe Object of
- Just obj -> HashMap.foldlWithKey' gather Set.empty obj
- Nothing -> error "nooo"
- where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri
- gather uris "uri" (String s) = Set.insert (Uri s) uris
- gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o
- gather uris _ _ = uris
-
-swapUris :: FileMap -> B.ByteString -> B.ByteString
-swapUris fileMap msg =
- case decode msg :: Maybe Object of
- Just obj -> encode $ HashMap.mapWithKey f obj
- Nothing -> error "Couldn't decode message"
-
- where f :: T.Text -> Value -> Value
- f "uri" (String uri) = String $ swap uri
- f "changes" (Object obj) = Object $
- HashMap.foldlWithKey' (\acc k v -> HashMap.insert (swap k) v acc)
- HashMap.empty
- obj
- f _ x = g x
-
- g :: Value -> Value
- g (Array arr) = Array $ fmap g arr
- g (Object obj) = Object $ HashMap.mapWithKey f obj
- g x = x
-
- swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri
+rootDir _ = error "Couldn't find initialize request in session"
+
+mapUris :: (Uri -> Uri) -> Event -> Event
+mapUris f event =
+ case event of
+ FromClient t msg -> FromClient t (fromClientMsg msg)
+ FromServer t msg -> FromServer t (fromServerMsg msg)
+
+ where
+ --TODO: Handle all other URIs that might need swapped
+ fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n
+ fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n
+ fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n
+ fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n
+ fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n
+ fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r
+ fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r
+ fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r
+ fromClientMsg x = x
+
+ fromServerMsg :: FromServerMessage -> FromServerMessage
+ fromServerMsg (ReqApplyWorkspaceEdit r) =
+ ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
+
+ fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n
+
+ fromServerMsg (RspDocumentSymbols r) =
+ let newSymbols = case r ^. result of
+ Just (DSSymbolInformation si) -> Just (DSSymbolInformation (fmap (swapUri location) si))
+ x -> x
+ in RspDocumentSymbols $ result .~ newSymbols $ r
+
+ fromServerMsg (RspRename r) =
+ let oldResult = r ^. result :: Maybe WorkspaceEdit
+ newResult = fmap swapWorkspaceEdit oldResult
+ in RspRename $ result .~ newResult $ r
+
+ fromServerMsg x = x
+
+ swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
+ swapWorkspaceEdit e =
+ let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges
+ newChanges = fmap (swapKeys f) $ e ^. changes
+ in WorkspaceEdit newChanges newDocChanges
+
+ swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
+ swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
+
+ swapUri :: HasUri b Uri => Lens' a b -> a -> a
+ swapUri lens x =
+ let newUri = f (x ^. lens . uri)
+ in (lens . uri) .~ newUri $ x
+
+ -- | Transforms rootUri/rootPath.
+ transformInit :: InitializeParams -> InitializeParams
+ transformInit x =
+ let newRootUri = fmap f (x ^. rootUri)
+ newRootPath = do
+ fp <- T.unpack <$> x ^. rootPath
+ let uri = filePathToUri fp
+ T.pack <$> uriToFilePath (f uri)
+ in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x