1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Language.Haskell.LSP.Test.Files
13 import Language.Haskell.LSP.Types hiding ( error )
17 import qualified Data.ByteString.Lazy.Char8 as B
18 import qualified Data.Text as T
19 import qualified Data.Map as Map
21 import qualified Data.HashMap.Strict as HashMap
22 import qualified Data.Set as Set
24 import System.Directory
26 import System.FilePath
28 type FileMap = Map.Map Uri Uri
30 emptyFileMap :: FileMap
31 emptyFileMap = Map.empty
33 buildFileMap :: [Uri] -> FilePath -> FilePath -> FileMap -> IO FileMap
34 buildFileMap uris recBaseDir curBaseDir oldMap =
35 foldM (createFile recBaseDir curBaseDir) oldMap uris
37 createFile baseDir curDir map uri =
41 let fp = fromMaybe (error "Couldn't convert file path")
43 relativeFp = makeRelative baseDir fp
44 actualFp = curDir </> relativeFp
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
51 (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName actualFp)
53 readFile actualFp >>= hPutStr tmpH
54 tmpUri <- filePathToUri <$> canonicalizePath tmpFp
55 return $ Map.insert uri tmpUri map
58 cleanupFiles = removeDirectoryRecursive =<< (</> "lsp-test") <$> getTemporaryDirectory
60 swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap)
61 swapFiles fileMap recBaseDir curBaseDir msgs = do
63 let oldUris = Set.unions $ map extractUris msgs
65 newMap <- buildFileMap (Set.elems oldUris) recBaseDir curBaseDir fileMap
67 let newMsgs = map (swapUris newMap) msgs
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
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)
80 Nothing -> return (newMsgs, newMap)
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
87 Nothing -> error "Couldn't find root dir"
89 extractUris :: B.ByteString -> Set.Set Uri
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
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"
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)
114 g (Array arr) = Array $ fmap g arr
115 g (Object obj) = Object $ HashMap.mapWithKey f obj
118 swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri