1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Language.Haskell.LSP.Test.Files
10 import Language.Haskell.LSP.Types hiding ( error )
13 import Data.Aeson.Types
14 import qualified Data.ByteString.Lazy.Char8 as B
15 import qualified Data.Text as T
16 import qualified Data.HashMap.Strict as HashMap
18 import System.Directory
19 import System.FilePath
21 swapFiles :: FilePath -> FilePath -> [B.ByteString] -> IO [B.ByteString]
22 swapFiles recBaseDir relCurBaseDir msgs = do
23 curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
25 let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
26 newFp = curBaseDir </> makeRelative recBaseDir fp
27 in filePathToUri newFp
28 newMsgs = map (mapUris transform) msgs :: [B.ByteString]
32 rootDir :: [B.ByteString] -> FilePath
33 rootDir msgs = fromMaybe (error "Couldn't find root dir") $ do
34 req <- decode (head msgs) :: Maybe InitializeRequest
35 rootUri <- req ^. params .rootUri
38 mapUris :: (Uri -> Uri) -> B.ByteString -> B.ByteString
40 case decode msg :: Maybe Object of
41 Just obj -> encode $ HashMap.map (mapValue f) obj
42 Nothing -> error "Couldn't decode message"
45 mapValue :: (Uri -> Uri) -> Value -> Value
46 mapValue f x = case parse parseJSON x :: Result VersionedTextDocumentIdentifier of
47 Success doc -> transform doc
48 Error _ -> case parse parseJSON x :: Result TextDocumentIdentifier of
49 Success doc -> transform doc
50 Error _ -> case parse parseJSON x :: Result InitializeParams of
51 Success params -> transformInit params
52 Error _ -> case parse parseJSON x :: Result Object of
53 Success obj -> Object $ HashMap.map (mapValue f) obj
56 -- parsing with just JSON
57 -- mapValueWithKey :: (Uri -> Uri) -> T.Text -> Value -> Value
58 -- mapValueWithKey f "uri" (String s) = fromMaybe (error "Couldn't convert uri") $ do
59 -- let uri = filePathToUri $ T.unpack s
60 -- String <$> (fmap T.pack (uriToFilePath $ f uri))
61 -- mapValueWithKey f _ (Array xs) = Array $ fmap (mapValue f) xs
62 -- mapValueWithKey f _ (Object x) = Object $ HashMap.mapWithKey (mapValueWithKey f) x
64 transform x = toJSON $ x & uri .~ f (x ^. uri)
66 -- transform rootUri/rootPath
67 transformInit :: InitializeParams -> Value
69 let newRootUri = fmap f (x ^. rootUri)
71 fp <- T.unpack <$> x ^. rootPath
72 let uri = filePathToUri fp
73 T.pack <$> uriToFilePath (f uri)
74 in toJSON $ (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x