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   , FileMap
   7   , emptyFileMap
   8   , rootDir
   9   , cleanupFiles
  10   )
  11 where
  12
  13 import           Language.Haskell.LSP.Types        hiding ( error )
  14 import           Control.Lens
  15 import           Control.Monad
  16 import           Data.Aeson
  17 import qualified Data.ByteString.Lazy.Char8    as B
  18 import qualified Data.Text                     as T
  19 import qualified Data.Map                      as Map
  20 import           Data.Map ((!))
  21 import qualified Data.HashMap.Strict           as HashMap
  22 import qualified Data.Set                      as Set
  23 import           Data.Maybe
  24 import           System.Directory
  25 import           System.IO
  26 import           System.FilePath
  27
  28 type FileMap = Map.Map Uri Uri
  29
  30 emptyFileMap :: FileMap
  31 emptyFileMap = Map.empty
  32
  33 buildFileMap :: [Uri] -> FilePath -> FilePath -> FileMap -> IO FileMap
  34 buildFileMap uris recBaseDir curBaseDir oldMap =
  35   foldM (createFile recBaseDir curBaseDir) oldMap uris
  36   where
  37   createFile baseDir curDir  map uri =
  38     if Map.member uri map
  39       then return map
  40       else do
  41         let fp = fromMaybe (error "Couldn't convert file path")
  42                  (uriToFilePath uri)
  43             relativeFp = makeRelative baseDir fp
  44             actualFp = curDir </> relativeFp
  45
  46         -- Need to store in a directory inside tmp directory
  47         -- otherwise ghc-mod ends up creating one for us
  48         tmpDir <- (</> "lsp-test" </> takeDirectory relativeFp) <$> getTemporaryDirectory
  49         createDirectoryIfMissing True tmpDir
  50
  51         (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName actualFp)
  52
  53         readFile actualFp >>= hPutStr tmpH
  54         tmpUri <- filePathToUri <$> canonicalizePath tmpFp
  55         return $ Map.insert uri tmpUri map
  56
  57 cleanupFiles :: IO ()
  58 cleanupFiles = removeDirectoryRecursive =<< (</> "lsp-test") <$> getTemporaryDirectory
  59
  60 swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap)
  61 swapFiles fileMap recBaseDir curBaseDir msgs = do
  62
  63   let oldUris = Set.unions $ map extractUris msgs
  64
  65   newMap <- buildFileMap (Set.elems oldUris) recBaseDir curBaseDir fileMap
  66
  67   let newMsgs = map (swapUris newMap) msgs
  68
  69   case decode (head newMsgs) :: Maybe InitializeRequest of
  70     -- If there is an initialize request we will need to swap
  71     -- the rootUri and rootPath
  72     Just req -> do
  73       cd <- getCurrentDirectory
  74       let newRoot = cd </> curBaseDir
  75           newRootUri = params . rootUri .~ Just (filePathToUri newRoot) $ req
  76           newRootPath = params . rootPath .~ Just (T.pack newRoot) $ newRootUri
  77           newReq = encode newRootPath
  78       return (newReq:(tail newMsgs), newMap)
  79
  80     Nothing -> return (newMsgs, newMap)
  81
  82 rootDir :: [B.ByteString] -> FilePath
  83 rootDir msgs = case decode (head msgs) :: Maybe InitializeRequest of
  84                 Just req -> fromMaybe (error "Couldn't convert root dir") $ do
  85                   rootUri <- req ^. params . rootUri
  86                   uriToFilePath rootUri
  87                 Nothing -> error "Couldn't find root dir"
  88
  89 extractUris :: B.ByteString -> Set.Set Uri
  90 extractUris msgs =
  91   case decode msgs :: Maybe Object of
  92     Just obj -> HashMap.foldlWithKey' gather Set.empty obj
  93     Nothing -> error "Couldn't decode message"
  94   where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri
  95         gather uris "uri" (String s) = Set.insert (Uri s) uris
  96         gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o
  97         gather uris _ _ = uris
  98
  99 swapUris :: FileMap -> B.ByteString -> B.ByteString
 100 swapUris fileMap msg =
 101   case decode msg :: Maybe Object of
 102     Just obj -> encode $ HashMap.mapWithKey f obj
 103     Nothing -> error "Couldn't decode message"
 104
 105   where f :: T.Text -> Value -> Value
 106         f "uri" (String uri) = String $ swap uri
 107         f "changes" (Object obj) = Object $
 108           HashMap.foldlWithKey' (\acc k v -> HashMap.insert (swap k) v acc)
 109                                 HashMap.empty
 110                                 obj
 111         f _ x = g x
 112
 113         g :: Value -> Value
 114         g (Array arr) = Array $ fmap g arr
 115         g (Object obj) = Object $ HashMap.mapWithKey f obj
 116         g x = x
 117
 118         swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri