Current non-working version of file parsing

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index f32611c4d025d0325dac1abd82ca53fb1205bf35..a61a18d42f33a00be906b2c7cfa217a91b9fe467 100644 (file)
--- 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 3529526bcc47b2bfc9fe3f8d696e288b0e6bef8b..f59551a3719ae3e2dcf9f24b321ef7aa569eb1c1 100644 (file)
--- 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 504f3ff1f74fb68fd810d88fff1061c80abc7353..41df16d08bc0a8ccf66c698669fc7441ccd158b1 100644 (file)
--- 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 e24b1e1c75d333f2327ac273bdcf2d7d9d8e127e..3fd14e4c5dc9cbad53ff157cbffd0e8da8aecfae 100644 (file)
--- 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/")