diff --git a/lib/Proteome/Add.hs b/lib/Proteome/Add.hs --- a/lib/Proteome/Add.hs +++ b/lib/Proteome/Add.hs @@ -1,12 +1,15 @@ +{-# LANGUAGE RecordWildCards #-} + module Proteome.Add( proAdd, proAddCmd, ) where +import Control.Monad (when) import Control.Lens (over) import Data.List.Utils (split) -import Neovim (nvim_err_writeln', CommandArguments) +import Neovim (nvim_err_writeln', CommandArguments(CommandArguments, bang)) import qualified Ribosome.Data.Ribo as Ribo (modify) import Proteome.Data.AddOptions (AddOptions(AddOptions)) import Proteome.Data.Env (_projects) @@ -16,26 +19,32 @@ ProjectName(ProjectName), ProjectType(ProjectType), ) +import Proteome.Project.Activate (selectProject) import Proteome.Project.Resolve (resolveProjectFromConfig) import Proteome.Data.Proteome (Proteome) -add :: ProjectName -> Maybe ProjectType -> Proteome () -add name tpe = do +add :: ProjectName -> Maybe ProjectType -> Bool -> Proteome () +add name tpe activate = do project <- resolveProjectFromConfig Nothing name tpe case meta project of VirtualProject _ -> return () _ -> Ribo.modify $ over _projects (\p -> p ++ [project]) + when activate $ selectProject (-1) proAdd :: AddOptions -> Proteome () -proAdd (AddOptions name tpe) = - add name (Just tpe) +proAdd (AddOptions name tpe activate) = + add name (Just tpe) activate -addFromName :: ProjectName -> Proteome () +addFromName :: ProjectName -> Bool -> Proteome () addFromName name = add name Nothing proAddCmd :: CommandArguments -> String -> Proteome () -proAddCmd _ spec = +proAddCmd args spec = case split "/" spec of - [tpe, name] -> add (ProjectName name) (Just (ProjectType tpe)) - [name] -> addFromName (ProjectName name) + [tpe, name] -> add (ProjectName name) (Just (ProjectType tpe)) activate + [name] -> addFromName (ProjectName name) activate _ -> nvim_err_writeln' $ "invalid project spec: " ++ spec + where + activate = case args of + CommandArguments { bang = Just True, .. } -> True + _ -> False diff --git a/lib/Proteome/Data/AddOptions.hs b/lib/Proteome/Data/AddOptions.hs --- a/lib/Proteome/Data/AddOptions.hs +++ b/lib/Proteome/Data/AddOptions.hs @@ -12,13 +12,14 @@ import qualified Data.Map as Map (fromList) import Data.Text.Prettyprint.Doc ((<+>), viaShow) import Neovim (NvimObject(..), Dictionary, Object(ObjectMap)) -import Ribosome.Internal.NvimObject (extractObject) +import Ribosome.Internal.NvimObject (extractObject, extractObjectOr) import Proteome.Data.Project (ProjectName, ProjectType) data AddOptions = AddOptions { name :: ProjectName, - tpe :: ProjectType + tpe :: ProjectType, + activate :: Bool } deriving (Eq, Show, Generic, NFData) @@ -27,10 +28,11 @@ (toObject :: Dictionary -> Object) . Map.fromList $ [ ("name", toObject name), - ("tpe", toObject tpe) + ("tpe", toObject tpe), + ("activate", toObject activate) ] fromObject (ObjectMap o) = do name' <- extractObject "name" o tpe' <- extractObject "tpe" o - return $ AddOptions name' tpe' + return $ AddOptions name' tpe' (extractObjectOr "activate" False o) fromObject o = Left ("invalid type for AddOptions: " <+> viaShow o) diff --git a/lib/Proteome/Plugin.hs b/lib/Proteome/Plugin.hs --- a/lib/Proteome/Plugin.hs +++ b/lib/Proteome/Plugin.hs @@ -10,6 +10,7 @@ import UnliftIO.STM (TVar) import Neovim ( Plugin(..), + function, function', command, autocmd, @@ -39,7 +40,7 @@ $(function' 'proteomeStage1) Async, $(function' 'proteomeStage2) Async, $(function' 'proteomeStage4) Async, - $(function' 'proAdd) Async, + $(function "ProAddProject" 'proAdd) Sync, $(command "ProAdd" 'proAddCmd) [CmdBang], $(function' 'proSave) Async, $(function' 'proTags) Async, diff --git a/lib/Proteome/Project/Activate.hs b/lib/Proteome/Project/Activate.hs --- a/lib/Proteome/Project/Activate.hs +++ b/lib/Proteome/Project/Activate.hs @@ -3,9 +3,10 @@ activateCurrentProject, proPrev, proNext, + selectProject, ) where -import Control.Lens (over) +import qualified Control.Lens as Lens (over, set) import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) @@ -46,13 +47,21 @@ pro <- currentProject mapM_ activateProject pro +setProjectIndex :: Int -> Proteome () +setProjectIndex index = do + pros <- allProjects + Ribo.modify $ Lens.set Env._currentProjectIndex $ index `mod` length pros + cycleProjectIndex :: (Int -> Int) -> Proteome () cycleProjectIndex f = do pros <- allProjects - let - trans:: Int -> Int - trans a = f a `rem` length pros - Ribo.modify $ over Env._currentProjectIndex trans + let trans a = f a `rem` length pros + Ribo.modify $ Lens.over Env._currentProjectIndex trans + +selectProject :: Int -> Proteome () +selectProject index = do + setProjectIndex index + activateCurrentProject proPrev :: Proteome () proPrev = do diff --git a/lib/Proteome/Test/Functional.hs b/lib/Proteome/Test/Functional.hs --- a/lib/Proteome/Test/Functional.hs +++ b/lib/Proteome/Test/Functional.hs @@ -1,15 +1,18 @@ module Proteome.Test.Functional( spec, specWith, + fixture, + tempDir, + tempFile, ) where import Ribosome.Data.Ribo (Ribo) import Ribosome.Test.Embed (Vars) -import Ribosome.Test.Functional (functionalSpec) +import Ribosome.Test.Functional (functionalSpec, fixture, tempDir, tempFile) import Proteome.Test.Config (defaultTestConfig, defaultTestConfigWith) spec :: Ribo () () -> IO () spec = functionalSpec defaultTestConfig -specWith :: Vars -> Ribo () () -> IO () -specWith vars = functionalSpec $ defaultTestConfigWith vars +specWith :: Ribo () () -> Vars -> IO () +specWith thunk vars = functionalSpec (defaultTestConfigWith vars) thunk diff --git a/lib/Ribosome/Internal/NvimObject.hs b/lib/Ribosome/Internal/NvimObject.hs --- a/lib/Ribosome/Internal/NvimObject.hs +++ b/lib/Ribosome/Internal/NvimObject.hs @@ -1,6 +1,7 @@ module Ribosome.Internal.NvimObject( deriveString, extractObject, + extractObjectOr, ) where import qualified Data.ByteString.UTF8 as UTF8 (fromString) @@ -19,3 +20,9 @@ extractObject key data' = do value <- objectKeyMissing key $ data' !? (ObjectString . UTF8.fromString) key fromObject value + +extractObjectOr :: NvimObject o => String -> o -> Map Object Object -> o +extractObjectOr key default' data' = + case extractObject key data' of + Right a -> a + Left _ -> default' diff --git a/lib/Ribosome/Test/Embed.hs b/lib/Ribosome/Test/Embed.hs --- a/lib/Ribosome/Test/Embed.hs +++ b/lib/Ribosome/Test/Embed.hs @@ -8,7 +8,9 @@ setupPluginEnv, ) where +import Control.Monad.IO.Class (liftIO) import Data.Foldable (traverse_) +import System.Directory (makeAbsolute) import Neovim (Neovim, Object, vim_set_var') import Neovim.Test (testWithEmbeddedNeovim, Seconds(..)) import Ribosome.Data.Ribo (Ribo) @@ -39,7 +41,8 @@ setupPluginEnv :: TestConfig -> Neovim e () setupPluginEnv (TestConfig _ rtp _ vars) = do - rtpCat rtp + absRtp <- liftIO $ makeAbsolute rtp + rtpCat absRtp setVars vars unsafeEmbeddedSpec :: Runner (Ribosome e) -> TestConfig -> e -> Ribo e () -> IO () diff --git a/lib/Ribosome/Test/Functional.hs b/lib/Ribosome/Test/Functional.hs --- a/lib/Ribosome/Test/Functional.hs +++ b/lib/Ribosome/Test/Functional.hs @@ -2,34 +2,40 @@ startPlugin, fSpec, functionalSpec, + tempDir, + tempFile, + fixture, ) where import Control.Monad (when) import Control.Monad.IO.Class import Control.Exception (finally) import Data.Foldable (traverse_) -import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removePathForcibly, doesFileExist) -import System.FilePath (takeDirectory) +import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removePathForcibly, doesFileExist, makeAbsolute) +import System.FilePath (takeDirectory, (), takeFileName) import System.Console.ANSI (setSGR, SGR(SetColor, Reset), ConsoleLayer(Foreground), ColorIntensity(Dull), Color(Green)) import Neovim (Neovim, vim_command') import Ribosome.Data.Ribo (Ribo) import Ribosome.Test.Exists (waitForPlugin) import Ribosome.Test.Embed (TestConfig(..), unsafeEmbeddedSpec, setupPluginEnv) +import qualified Ribosome.Test.File as F (tempDir, fixture) jobstart :: MonadIO f => String -> f String jobstart cmd = do dir <- liftIO getCurrentDirectory return $ "call jobstart('" ++ cmd ++ "', { 'rpc': v:true, 'cwd': '" ++ dir ++ "' })" -logFile :: TestConfig -> FilePath -logFile conf = logPath conf ++ "-spec" +logFile :: TestConfig -> IO FilePath +logFile conf = makeAbsolute $ logPath conf ++ "-spec" startPlugin :: TestConfig -> Neovim env () startPlugin conf = do - liftIO $ createDirectoryIfMissing True (takeDirectory (logPath conf)) - liftIO $ removePathForcibly (logFile conf) + absLogPath <- liftIO $ makeAbsolute (logPath conf) + absLogFile <- liftIO $ logFile conf + liftIO $ createDirectoryIfMissing True (takeDirectory absLogPath) + liftIO $ removePathForcibly absLogFile setupPluginEnv conf - cmd <- jobstart $ "stack run -- -l " ++ logFile conf ++ " -v INFO" + cmd <- jobstart $ "stack run -- -l " ++ absLogFile ++ " -v INFO" vim_command' cmd waitForPlugin (pluginName conf) 0.1 3 @@ -47,7 +53,7 @@ showLog :: TestConfig -> IO () showLog conf = do - let file = logFile conf + file <- logFile conf exists <- doesFileExist file when exists $ do output <- readFile file @@ -58,3 +64,17 @@ functionalSpec :: TestConfig -> Ribo () () -> IO () functionalSpec conf spec = finally (unsafeEmbeddedSpec fSpec conf () spec) (showLog conf) + +fPrefix :: String +fPrefix = "f" + +tempDir :: FilePath -> Neovim e FilePath +tempDir = F.tempDir fPrefix + +tempFile :: FilePath -> Neovim e FilePath +tempFile file = do + absDir <- tempDir $ takeDirectory file + return $ absDir takeFileName file + +fixture :: MonadIO m => FilePath -> m FilePath +fixture = F.fixture fPrefix diff --git a/proteome.cabal b/proteome.cabal --- a/proteome.cabal +++ b/proteome.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 64efc5d8d1ec76be44f4c5186571386396e63ec02ac038fbc71186e62cf26075 +-- hash: e9f2d71e222d4ffaa6e98b7cfdc7739cb4d796152685b6e2b1374b3c4124f5f2 name: proteome -version: 0.3.12.0 +version: 0.3.13.0 synopsis: neovim project manager description: Please see the README on GitHub at category: Neovim diff --git a/test/f/AddSpec.hs b/test/f/AddSpec.hs --- a/test/f/AddSpec.hs +++ b/test/f/AddSpec.hs @@ -1,32 +1,45 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-} module AddSpec( - htf_thisModulesTests + htf_thisModulesTests, ) where +import Control.Monad.IO.Class (liftIO) import qualified Data.Map as Map (fromList) +import System.FilePath (()) import Test.Framework import Neovim (vim_call_function', vim_command', toObject) +import Ribosome.Api.Path (nvimCwd) +import Ribosome.Config.Setting (updateSetting) import Ribosome.Data.Ribo (Ribo) -import Proteome.Test.Functional (specWith) +import qualified Proteome.Settings as S (projectBaseDirs) +import Proteome.Test.Functional (specWith, fixture) import Config (vars) addSpec :: Ribo env () addSpec = do - _ <- vim_call_function' "ProAdd" [toObject $ Map.fromList [("name", "bar"), ("tpe", "foo")]] - return () + projectsDir <- fixture "projects" + updateSetting S.projectBaseDirs [projectsDir] + _ <- vim_call_function' "ProAddProject" [toObject $ Map.fromList [ + ("name", toObject "cilia"), + ("tpe", toObject "haskell"), + ("activate", toObject True) + ]] + cwd <- nvimCwd + liftIO $ assertEqual (projectsDir "haskell" "cilia") cwd -test_add :: IO () -test_add = do - v <- vars - specWith v addSpec +test_addFunction :: IO () +test_addFunction = + vars >>= specWith addSpec addCommandSpec :: Ribo env () addCommandSpec = do - _ <- vim_command' "ProAdd! foo/bar" - return () + projectsDir <- fixture "projects" + updateSetting S.projectBaseDirs [projectsDir] + _ <- vim_command' "ProAdd! haskell/cilia" + cwd <- nvimCwd + liftIO $ assertEqual (projectsDir "haskell" "cilia") cwd test_addCommand :: IO () -test_addCommand = do - v <- vars - specWith v addCommandSpec +test_addCommand = + vars >>= specWith addCommandSpec diff --git a/test/f/Config.hs b/test/f/Config.hs --- a/test/f/Config.hs +++ b/test/f/Config.hs @@ -10,6 +10,6 @@ vars = do base <- getCurrentDirectory return $ Vars [ - ("proteome_project_base_dirs", toObject [base ++ "/test/f/fixtures/config/projects"]), - ("proteome_main_project_dir", toObject $ base ++ "/test/f/fixtures/config/projects/haskell/flagellum") + ("proteome_project_base_dirs", toObject [base ++ "/test/f/fixtures/projects"]), + ("proteome_main_project_dir", toObject $ base ++ "/test/f/fixtures/projects/haskell/flagellum") ] diff --git a/test/f/ConfigSpec.hs b/test/f/ConfigSpec.hs --- a/test/f/ConfigSpec.hs +++ b/test/f/ConfigSpec.hs @@ -7,19 +7,18 @@ import Control.Monad.IO.Class (liftIO) import Test.Framework import Data.MessagePack (Object(ObjectInt)) -import Neovim (vim_call_function, vim_get_var', vim_command') +import Neovim (vim_call_function', vim_get_var', vim_command') import Ribosome.Data.Ribo (Ribo) import Proteome.Test.Functional (specWith) import Config (vars) configSpec :: Ribo env () configSpec = do - _ <- vim_call_function "ProReadConfig" [] + _ <- vim_call_function' "ProReadConfig" [] vim_command' "doautocmd User Test" value <- vim_get_var' "flag" - liftIO $ assertEqual value (ObjectInt 1) + liftIO $ assertEqual value (ObjectInt 13) test_config :: IO () -test_config = do - v <- vars - specWith v configSpec +test_config = + vars >>= specWith configSpec diff --git a/test/f/InitSpec.hs b/test/f/InitSpec.hs --- a/test/f/InitSpec.hs +++ b/test/f/InitSpec.hs @@ -21,6 +21,5 @@ liftIO $ assertEqual tpe (ProjectType "haskell") test_init :: IO () -test_init = do - v <- vars - specWith v initSpec +test_init = + vars >>= specWith initSpec diff --git a/test/u/AddSpec.hs b/test/u/AddSpec.hs --- a/test/u/AddSpec.hs +++ b/test/u/AddSpec.hs @@ -28,7 +28,7 @@ addSpec = do projectsDir <- fixture "projects" updateSetting S.projectBaseDirs [projectsDir] - proAdd $ AddOptions fn tp + proAdd $ AddOptions fn tp False ps <- Ribo.inspect projects let root = projectsDir hask flag liftIO $ assertEqual [Project (DirProject fn (ProjectRoot root) (Just tp)) [] (Just l) []] ps diff --git a/test/u/CycleSpec.hs b/test/u/CycleSpec.hs --- a/test/u/CycleSpec.hs +++ b/test/u/CycleSpec.hs @@ -34,8 +34,8 @@ updateSetting S.projectBaseDirs [projectsDir] updateSetting S.mainProjectDir mainDir resolveAndInitMain - proAdd $ AddOptions fn tp - proAdd $ AddOptions cn tp + proAdd $ AddOptions fn tp False + proAdd $ AddOptions cn tp False assertDir prot proNext assertDir flag diff --git a/test/u/MultiTagsSpec.hs b/test/u/MultiTagsSpec.hs --- a/test/u/MultiTagsSpec.hs +++ b/test/u/MultiTagsSpec.hs @@ -30,8 +30,8 @@ updateSetting S.tagsCommand "touch" updateSetting S.tagsArgs ".tags" updateSetting S.tagsFork False - proAdd $ AddOptions fn tp - proAdd $ AddOptions cn tp + proAdd $ AddOptions fn tp False + proAdd $ AddOptions cn tp False proTags bufEnter let ftags = projectsDir hask flag ".tags"