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