src/Language/Haskell/LSP/Test/Files.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 module Language.Haskell.LSP.Test.Files
   5   ( swapFiles
   6   , rootDir
   7   )
   8 where
   9
  10 import           Language.Haskell.LSP.Types        hiding ( error )
  11 import           Control.Lens
  12 import           Data.Aeson
  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
  17 import           Data.Maybe
  18 import           System.Directory
  19 import           System.FilePath
  20
  21 swapFiles :: FilePath -> FilePath -> [B.ByteString] -> IO [B.ByteString]
  22 swapFiles recBaseDir relCurBaseDir msgs = do
  23   curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
  24   let transform uri =
  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]
  29
  30   return newMsgs
  31
  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
  36   uriToFilePath rootUri
  37
  38 mapUris :: (Uri -> Uri) -> B.ByteString -> B.ByteString
  39 mapUris f msg =
  40   case decode msg :: Maybe Object of
  41     Just obj -> encode $ HashMap.map (mapValue f) obj
  42     Nothing -> error "Couldn't decode message"
  43
  44   where
  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
  54             Error _ -> x
  55
  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
  63
  64     transform x = toJSON $ x & uri .~ f (x ^. uri)
  65
  66     -- transform rootUri/rootPath
  67     transformInit :: InitializeParams -> Value
  68     transformInit x =
  69       let newRootUri = fmap f (x ^. rootUri)
  70           newRootPath = do
  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