1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Language.Haskell.LSP.Test.Files
11 import Language.Haskell.LSP.Types hiding ( error )
12 import Language.Haskell.LSP.Test.Parsing
15 import qualified Data.ByteString.Lazy.Char8 as B
16 import qualified Data.Text as T
17 import qualified Data.Map as Map
19 import qualified Data.HashMap.Strict as HashMap
20 import qualified Data.Set as Set
22 import System.Directory
24 import System.FilePath
26 type FileMap = Map.Map Uri Uri
28 emptyFileMap :: FileMap
29 emptyFileMap = Map.empty
31 buildFileMap :: [Uri] -> FileMap -> IO FileMap
32 buildFileMap uris oldMap = foldM createFile oldMap uris
38 let fp = fromMaybe (error "Couldn't convert file path")
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
46 (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName fp)
48 readFile fp >>= hPutStr tmpH
49 tmpUri <- filePathToUri <$> canonicalizePath tmpFp
50 return $ Map.insert uri tmpUri map
52 swapFiles :: FileMap -> Handle -> IO ([B.ByteString], FileMap)
53 swapFiles fileMap h = do
54 msgs <- getAllMessages h
56 let oldUris = Set.unions $ map extractUris msgs
58 newMap <- buildFileMap (Set.elems oldUris) fileMap
60 let newMsgs = map (swapUris newMap) msgs
62 return (newMsgs, newMap)
64 extractUris :: B.ByteString -> Set.Set Uri
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
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"
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)
89 g (Array arr) = Array $ fmap g arr
90 g (Object obj) = Object $ HashMap.mapWithKey f obj
93 swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri