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

   1 {-# LANGUAGE FlexibleContexts #-}
   2 module Language.Haskell.LSP.Test.Files
   3   ( loadSwappedFiles
   4   , FileMap
   5   , emptyFileMap
   6   )
   7 where
   8
   9 import           Language.Haskell.LSP.Core
  10 import qualified Language.Haskell.LSP.Control  as Control
  11 import           Language.Haskell.LSP.Types        hiding ( error )
  12 import           Data.Default
  13 import           Control.Lens
  14 import           Control.Monad
  15 import           Control.Concurrent
  16 import           Data.Aeson
  17 import qualified Data.ByteString.Lazy.Char8    as B
  18 import           Data.Map                      as Map
  19 import           Data.Maybe
  20 import           System.Directory
  21 import           System.IO
  22
  23 type FileMap = Map.Map FilePath FilePath
  24
  25 emptyFileMap :: FileMap
  26 emptyFileMap = Map.empty
  27
  28 buildFiles
  29   :: (HasParams a b, HasTextDocument b c, HasUri c Uri)
  30   => [a]
  31   -> FileMap
  32   -> IO FileMap
  33 buildFiles ns oldMap = foldM createFile oldMap ns
  34  where
  35   createFile map n = do
  36     let fp = fromMaybe (error "Couldn't convert file path")
  37                        (uriToFilePath $ n ^. params . textDocument . uri)
  38     if Map.member fp map
  39       then return map
  40       else do
  41         tmpDir        <- getTemporaryDirectory
  42         (tmpFp, tmpH) <- openTempFile tmpDir "lspTestDoc"
  43         readFile fp >>= hPutStr tmpH
  44         return $ Map.insert fp tmpFp map
  45
  46 swapFile :: (HasUri a Uri) => FileMap -> a -> a
  47 swapFile m msg = fromMaybe msg $ do
  48   let oldUri = msg ^. uri
  49   oldFp <- uriToFilePath oldUri
  50   newFp <- Map.lookup oldFp m
  51   let newUri = filePathToUri newFp
  52   return $ uri .~ newUri $ msg
  53
  54 loadSwappedFiles :: FileMap -> Handle -> IO ([B.ByteString], FileMap)
  55 loadSwappedFiles map h = do
  56   fileMapVar <- newMVar map
  57   msgsVar    <- newMVar []
  58   nullH      <- openFile "/dev/null" WriteMode
  59   Control.runWithHandles h
  60                          nullH
  61                          (const $ Right (), const $ return Nothing)
  62                          (handlers msgsVar fileMapVar)
  63                          def
  64                          Nothing
  65                          Nothing
  66   newMap <- readMVar fileMapVar
  67   msgs   <- reverse <$> readMVar msgsVar
  68   return (msgs, newMap)
  69
  70 handlers :: MVar [B.ByteString] -> MVar FileMap -> Handlers
  71 handlers msgs fileMap = Handlers
  72   {
  73     -- Requests
  74     hoverHandler                             = Just put
  75   , completionHandler                        = Just put
  76   , completionResolveHandler                 = Just put
  77   , signatureHelpHandler                     = Just put
  78   , definitionHandler                        = Just put
  79   , referencesHandler                        = Just put
  80   , documentHighlightHandler                 = Just put
  81   , documentSymbolHandler                    = Just $ swapUri (params . textDocument)
  82   , workspaceSymbolHandler                   = Just put
  83   , codeActionHandler                        = Just put
  84   , codeLensHandler                          = Just put
  85   , codeLensResolveHandler                   = Just put
  86   , documentFormattingHandler                = Just put
  87   , documentRangeFormattingHandler           = Just put
  88   , documentTypeFormattingHandler            = Just put
  89   , renameHandler                            = Just $ swapUri (params . textDocument)
  90   , documentLinkHandler                      = Just $ swapUri (params . textDocument)
  91   , documentLinkResolveHandler               = Just put
  92   , executeCommandHandler                    = Just put
  93   , initializeRequestHandler                 = Just put
  94     -- Notifications
  95   , didChangeConfigurationParamsHandler      = Just put
  96   , didOpenTextDocumentNotificationHandler   = Just $ swapUri (params . textDocument)
  97   , didChangeTextDocumentNotificationHandler = Just $ swapUri (params . textDocument)
  98   , didCloseTextDocumentNotificationHandler  = Just $ swapUri (params . textDocument)
  99   , didSaveTextDocumentNotificationHandler   = Just $ swapUri (params . textDocument)
 100   , willSaveWaitUntilTextDocHandler          = Just put
 101   , didChangeWatchedFilesNotificationHandler = Just put
 102   , initializedHandler                       = Just put
 103   , willSaveTextDocumentNotificationHandler  = Just $ swapUri (params . textDocument)
 104   , cancelNotificationHandler                = Just put
 105   , exitNotificationHandler                  = Just put
 106     -- Responses
 107   , responseHandler                          = Just put
 108   }
 109  where
 110   swapUri f msg = do
 111     modifyMVar_ fileMap (buildFiles [msg])
 112     map <- readMVar fileMap
 113     put $ swapFile map $ msg ^. f
 114
 115   put :: ToJSON a => a -> IO ()
 116   put msg = modifyMVar_ msgs (return . (encode msg :))