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