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 hiding ( error )
  12 import           Language.Haskell.LSP.Messages
  13 import           Control.Lens
  14 import           Data.Aeson
  15 import qualified Data.ByteString.Lazy.Char8    as B
  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
  22 swapFiles :: FilePath -> [Event] -> IO [Event]
  23 swapFiles relCurBaseDir msgs = do
  24   let capturedBaseDir = rootDir msgs
  25
  26   curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
  27   let transform uri =
  28         let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
  29             newFp = curBaseDir </> makeRelative capturedBaseDir fp
  30           in filePathToUri newFp
  31       newMsgs = map (mapUris transform) msgs
  32
  33   return newMsgs
  34
  35 rootDir :: [Event] -> FilePath
  36 rootDir (FromClient _ (ReqInitialize req):_) =
  37   fromMaybe (error "Couldn't find root dir") $ do
  38     rootUri <- req ^. params .rootUri
  39     uriToFilePath rootUri
  40 rootDir _ = error "Couldn't find initialize request in session"
  41
  42 mapUris :: (Uri -> Uri) -> Event -> Event
  43 mapUris f event =
  44   case event of
  45     FromClient t msg -> FromClient t (fromClientMsg msg)
  46     FromServer t msg -> FromServer t (fromServerMsg msg)
  47
  48   where
  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 x = x
  56
  57     fromServerMsg :: FromServerMessage -> FromServerMessage
  58     fromServerMsg (ReqApplyWorkspaceEdit r) =
  59       let newDocChanges = fmap (fmap (swapUri textDocument)) $ r ^. params . edit . documentChanges
  60           r1 = (params . edit . documentChanges) .~ newDocChanges $ r
  61           newChanges = fmap (swapKeys f) $ r1 ^. params . edit . changes
  62           r2 = (params . edit . changes) .~ newChanges $ r1
  63       in ReqApplyWorkspaceEdit r2
  64     fromServerMsg x = x
  65
  66     swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
  67     swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
  68
  69     swapUri :: HasUri b Uri => Lens' a b -> a -> a
  70     swapUri lens x =
  71       let newUri = f (x ^. lens . uri)
  72         in (lens . uri) .~ newUri $ x
  73
  74     -- | Transforms rootUri/rootPath.
  75     transformInit :: InitializeParams -> InitializeParams
  76     transformInit x =
  77       let newRootUri = fmap f (x ^. rootUri)
  78           newRootPath = do
  79             fp <- T.unpack <$> x ^. rootPath
  80             let uri = filePathToUri fp
  81             T.pack <$> uriToFilePath (f uri)
  82         in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x