1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Language.Haskell.LSP.Test.Files
12 import Language.Haskell.LSP.Types hiding ( error )
16 import qualified Data.ByteString.Lazy.Char8 as B
17 import qualified Data.Text as T
18 import qualified Data.Map as Map
20 import qualified Data.HashMap.Strict as HashMap
21 import qualified Data.Set as Set
23 import System.Directory
25 import System.FilePath
27 type FileMap = Map.Map Uri Uri
29 emptyFileMap :: FileMap
30 emptyFileMap = Map.empty
32 buildFileMap :: [Uri] -> FilePath -> FilePath -> FileMap -> IO FileMap
33 buildFileMap uris recBaseDir curBaseDir oldMap =
34 foldM (createFile recBaseDir curBaseDir) oldMap uris
36 createFile baseDir curDir map uri =
40 let fp = fromMaybe (error "Couldn't convert file path")
42 relativeFp = makeRelative baseDir fp
43 actualFp = curDir </> relativeFp
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
50 (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName actualFp)
52 readFile actualFp >>= hPutStr tmpH
53 tmpUri <- filePathToUri <$> canonicalizePath tmpFp
54 return $ Map.insert uri tmpUri map
56 swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap)
57 swapFiles fileMap recBaseDir curBaseDir msgs = do
59 let oldUris = Set.unions $ map extractUris msgs
61 newMap <- buildFileMap (Set.elems oldUris) recBaseDir curBaseDir fileMap
63 let newMsgs = map (swapUris newMap) msgs
65 return (newMsgs, newMap)
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
72 Nothing -> error "Couldn't find root dir"
74 extractUris :: B.ByteString -> Set.Set Uri
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
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"
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)
99 g (Array arr) = Array $ fmap g arr
100 g (Object obj) = Object $ HashMap.mapWithKey f obj
103 swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri