From: Luke Lau Date: Tue, 29 May 2018 17:47:20 +0000 (-0400) Subject: Current non-working version of file parsing X-Git-Tag: 0.1.0.0~99 X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=287998584f8dc2ec1c1995733ca38d38d8d9f031 Current non-working version of file parsing --- diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index f32611c..a61a18d 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -50,7 +50,10 @@ test-suite tests ghc-options: -W build-depends: base >= 4.7 && < 5 , hspec + , lens + , directory , haskell-lsp-test + , haskell-lsp-types default-language: Haskell2010 executable example diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs index 3529526..f59551a 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -3,99 +3,72 @@ {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Files ( swapFiles - , FileMap - , emptyFileMap , rootDir ) where import Language.Haskell.LSP.Types hiding ( error ) import Control.Lens -import Control.Monad import Data.Aeson +import Data.Aeson.Types import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Text as T -import qualified Data.Map as Map -import Data.Map ((!)) import qualified Data.HashMap.Strict as HashMap -import qualified Data.Set as Set import Data.Maybe import System.Directory -import System.IO import System.FilePath -type FileMap = Map.Map Uri Uri +swapFiles :: FilePath -> FilePath -> [B.ByteString] -> IO [B.ByteString] +swapFiles recBaseDir relCurBaseDir msgs = do + curBaseDir <- ( relCurBaseDir) <$> getCurrentDirectory + let transform uri = + let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) + newFp = curBaseDir makeRelative recBaseDir fp + in filePathToUri newFp + newMsgs = map (mapUris transform) msgs :: [B.ByteString] -emptyFileMap :: FileMap -emptyFileMap = Map.empty - -buildFileMap :: Set.Set Uri -> FilePath -> FilePath -> FileMap -> IO FileMap -buildFileMap uris oldBaseDir newBaseDir oldMap = foldM transform oldMap uris - where - transform map uri = do - let fp = fromMaybe (error "Couldn't convert file path") $ uriToFilePath uri - rel = makeRelative oldBaseDir fp - newFp = newBaseDir rel - newUri <- filePathToUri <$> canonicalizePath newFp - return $ Map.insert uri newUri map - -swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap) -swapFiles fileMap recBaseDir curBaseDir msgs = do - - let oldUris = Set.unions $ map extractUris msgs - - newMap <- buildFileMap oldUris recBaseDir curBaseDir fileMap - - let newMsgs = map (swapUris newMap) msgs - - case decode (head newMsgs) :: Maybe InitializeRequest of - -- If there is an initialize request we will need to swap - -- the rootUri and rootPath - Just req -> do - cd <- getCurrentDirectory - let newRoot = cd curBaseDir - newRootUri = params . rootUri ?~ filePathToUri newRoot $ req - newRootPath = params . rootPath ?~ T.pack newRoot $ newRootUri - newReq = encode newRootPath - return (newReq:tail newMsgs, newMap) - - Nothing -> return (newMsgs, newMap) + return newMsgs rootDir :: [B.ByteString] -> FilePath -rootDir msgs = case decode (head msgs) :: Maybe InitializeRequest of - Just req -> fromMaybe (error "Couldn't convert root dir") $ do +rootDir msgs = fromMaybe (error "Couldn't find root dir") $ do + req <- decode (head msgs) :: Maybe InitializeRequest rootUri <- req ^. params .rootUri uriToFilePath rootUri - Nothing -> error "Couldn't find root dir" - -extractUris :: B.ByteString -> Set.Set Uri -extractUris msgs = - case decode msgs :: Maybe Object of - Just obj -> HashMap.foldlWithKey' gather Set.empty obj - Nothing -> error "Couldn't decode message" - where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri - gather uris "uri" (String s) = Set.insert (Uri s) uris - gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o - gather uris _ _ = uris -swapUris :: FileMap -> B.ByteString -> B.ByteString -swapUris fileMap msg = +mapUris :: (Uri -> Uri) -> B.ByteString -> B.ByteString +mapUris f msg = case decode msg :: Maybe Object of - Just obj -> encode $ HashMap.mapWithKey f obj + Just obj -> encode $ HashMap.map (mapValue f) obj Nothing -> error "Couldn't decode message" - where f :: T.Text -> Value -> Value - f "uri" (String uri) = String $ swap uri - f "changes" (Object obj) = Object $ - HashMap.foldlWithKey' (\acc k v -> HashMap.insert (swap k) v acc) - HashMap.empty - obj - f _ x = g x - - g :: Value -> Value - g (Array arr) = Array $ fmap g arr - g (Object obj) = Object $ HashMap.mapWithKey f obj - g x = x - - swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri - + where + mapValue :: (Uri -> Uri) -> Value -> Value + mapValue f x = case parse parseJSON x :: Result VersionedTextDocumentIdentifier of + Success doc -> transform doc + Error _ -> case parse parseJSON x :: Result TextDocumentIdentifier of + Success doc -> transform doc + Error _ -> case parse parseJSON x :: Result InitializeParams of + Success params -> transformInit params + Error _ -> case parse parseJSON x :: Result Object of + Success obj -> Object $ HashMap.map (mapValue f) obj + Error _ -> x + + -- parsing with just JSON + -- mapValueWithKey :: (Uri -> Uri) -> T.Text -> Value -> Value + -- mapValueWithKey f "uri" (String s) = fromMaybe (error "Couldn't convert uri") $ do + -- let uri = filePathToUri $ T.unpack s + -- String <$> (fmap T.pack (uriToFilePath $ f uri)) + -- mapValueWithKey f _ (Array xs) = Array $ fmap (mapValue f) xs + -- mapValueWithKey f _ (Object x) = Object $ HashMap.mapWithKey (mapValueWithKey f) x + + transform x = toJSON $ x & uri .~ f (x ^. uri) + + -- transform rootUri/rootPath + transformInit :: InitializeParams -> Value + transformInit x = + let newRootUri = fmap f (x ^. rootUri) + newRootPath = do + fp <- T.unpack <$> x ^. rootPath + let uri = filePathToUri fp + T.pack <$> uriToFilePath (f uri) + in toJSON $ (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index 504f3ff..41df16d 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -61,14 +61,17 @@ replay cfp sfp curRootDir = do let recRootDir = rootDir unswappedClientMsgs - (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs + clientMsgs <- swapFiles recRootDir curRootDir unswappedClientMsgs + + print clientMsgs + error "sdaf" tmpDir <- getTemporaryDirectory (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped" mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs hSeek mappedClientRecIn AbsoluteSeek 0 - (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn + expectedMsgs <- swapFiles recRootDir curRootDir =<< getAllMessages serverRecIn -- listen to server forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass @@ -159,7 +162,7 @@ listenServer expectedMsgs h semas@(reqSema, rspSema) = do lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) lift $ print n - lift $ putStrLn $ show ((length $ filter isNotification expectedMsgs) - 1) ++ " notifications remaining" + lift $ putStrLn $ show (length (filter isNotification expectedMsgs) - 1) ++ " notifications remaining" if n ^. LSP.method == LSP.WindowLogMessage then return expectedMsgs diff --git a/test/Test.hs b/test/Test.hs index e24b1e1..3fd14e4 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,7 +1,13 @@ import Test.Hspec +import System.IO +import System.Directory +import Control.Lens import Language.Haskell.LSP.Test.Recorded +-- import Language.Haskell.LSP.Test.Parsing +-- import Language.Haskell.LSP.Test.Files +import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP -main = hspec $ +main = hspec $ do describe "Replay" $ do it "passes a test" $ replay "test/recordings/renamePass/client.log" @@ -13,3 +19,20 @@ main = hspec $ "test/recordings/documentSymbolFail/server.log" "test/recordings/documentSymbolFail" `shouldReturn` False + + -- describe "file swapping" $ do + -- it "gets the base directory" $ do + -- h <- openFile "test/recordings/renamePass/client.log" ReadMode + -- msgs <- getAllMessages h + -- rootDir msgs `shouldBe` "/Users/luke/Desktop" + + -- it "gets builds a mapping of files" $ do + -- h <- openFile "test/recordings/renamePass/client.log" ReadMode + -- msgs <- getAllMessages h + -- let root = rootDir msgs + -- swapped <- swapFiles root "test/recordings/renamePass/" msgs + -- let (Just n) = decode (swapped !! 3) :: Maybe LSP.DidOpenNotification + + -- cd <- getCurrentDirectory + + -- n .^ params . uri `shouldBe` LSP.uriFromFilePath (cd "test/recordings/renamePass/")