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   , FileMap
   7   , emptyFileMap
   8   , rootDir
   9   )
  10 where
  11
  12 import           Language.Haskell.LSP.Types        hiding ( error )
  13 import           Control.Lens
  14 import           Control.Monad
  15 import           Data.Aeson
  16 import qualified Data.ByteString.Lazy.Char8    as B
  17 import qualified Data.Text                     as T
  18 import qualified Data.Map                      as Map
  19 import           Data.Map ((!))
  20 import qualified Data.HashMap.Strict           as HashMap
  21 import qualified Data.Set                      as Set
  22 import           Data.Maybe
  23 import           System.Directory
  24 import           System.IO
  25 import           System.FilePath
  26
  27 type FileMap = Map.Map Uri Uri
  28
  29 emptyFileMap :: FileMap
  30 emptyFileMap = Map.empty
  31
  32 buildFileMap :: Set.Set Uri -> FilePath -> FilePath -> FileMap -> IO FileMap
  33 buildFileMap uris oldBaseDir newBaseDir oldMap = foldM transform oldMap uris
  34   where
  35   transform map uri = do
  36     let fp = fromMaybe (error "Couldn't convert file path") $ uriToFilePath uri
  37         rel = makeRelative oldBaseDir fp
  38         newFp = newBaseDir </> rel
  39     newUri <- filePathToUri <$> canonicalizePath newFp
  40     return $ Map.insert uri newUri map
  41
  42 swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap)
  43 swapFiles fileMap recBaseDir curBaseDir msgs = do
  44
  45   let oldUris = Set.unions $ map extractUris msgs
  46
  47   newMap <- buildFileMap oldUris recBaseDir curBaseDir fileMap
  48
  49   let newMsgs = map (swapUris newMap) msgs
  50
  51   case decode (head newMsgs) :: Maybe InitializeRequest of
  52     -- If there is an initialize request we will need to swap
  53     -- the rootUri and rootPath
  54     Just req -> do
  55       cd <- getCurrentDirectory
  56       let newRoot = cd </> curBaseDir
  57           newRootUri = params . rootUri ?~ filePathToUri newRoot $ req
  58           newRootPath = params . rootPath ?~ T.pack newRoot $ newRootUri
  59           newReq = encode newRootPath
  60       return (newReq:tail newMsgs, newMap)
  61
  62     Nothing -> return (newMsgs, newMap)
  63
  64 rootDir :: [B.ByteString] -> FilePath
  65 rootDir msgs = case decode (head msgs) :: Maybe InitializeRequest of
  66                 Just req -> fromMaybe (error "Couldn't convert root dir") $ do
  67                   rootUri <- req ^. params . rootUri
  68                   uriToFilePath rootUri
  69                 Nothing -> error "Couldn't find root dir"
  70
  71 extractUris :: B.ByteString -> Set.Set Uri
  72 extractUris msgs =
  73   case decode msgs :: Maybe Object of
  74     Just obj -> HashMap.foldlWithKey' gather Set.empty obj
  75     Nothing -> error "Couldn't decode message"
  76   where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri
  77         gather uris "uri" (String s) = Set.insert (Uri s) uris
  78         gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o
  79         gather uris _ _ = uris
  80
  81 swapUris :: FileMap -> B.ByteString -> B.ByteString
  82 swapUris fileMap msg =
  83   case decode msg :: Maybe Object of
  84     Just obj -> encode $ HashMap.mapWithKey f obj
  85     Nothing -> error "Couldn't decode message"
  86
  87   where f :: T.Text -> Value -> Value
  88         f "uri" (String uri) = String $ swap uri
  89         f "changes" (Object obj) = Object $
  90           HashMap.foldlWithKey' (\acc k v -> HashMap.insert (swap k) v acc)
  91                                 HashMap.empty
  92                                 obj
  93         f _ x = g x
  94
  95         g :: Value -> Value
  96         g (Array arr) = Array $ fmap g arr
  97         g (Object obj) = Object $ HashMap.mapWithKey f obj
  98         g x = x
  99
 100         swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri
 101