proteome 0.3.4.0 → 0.3.5.0

raw patch · 20 files changed

+263/−56 lines, 20 filesdep +transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• lib/Proteome/Add.hs +13/−7
• lib/Proteome/Data/AddOptions.hs +36/−0
• lib/Proteome/Data/Env.hs +7/−5
• lib/Proteome/Init.hs +13/−10
• lib/Proteome/PersistBuffers.hs +3/−2
• lib/Proteome/Plugin.hs +3/−2
• lib/Proteome/Project/Resolve.hs +51/−17
• lib/Proteome/Save.hs +5/−1
• lib/Ribosome/Api/Buffer.hs +1/−1
• lib/Ribosome/Data/Errors.hs +3/−1
• lib/Ribosome/Monad.hs +13/−0
• lib/Ribosome/Persist.hs +16/−6
• lib/Ribosome/Unsafe.hs +8/−0
• proteome.cabal +11/−2
• test/f/AddSpec.hs +22/−0
• test/f/SpecMain.hs +1/−0
• test/u/AddSpec.hs +54/−0
• test/u/PersistLoadSpec.hs +1/−1
• test/u/ResolveSpec.hs +1/−1
• test/u/SpecMain.hs +1/−0

@@ -1,13 +1,19 @@ module Proteome.Add(   proAdd,-  proteomePoll ) where -import Neovim--proAdd :: Neovim env String-proAdd = return "foo"+import Control.Lens (over)+import qualified Ribosome.Data.Ribo as Ribo (modify)+import Proteome.Data.AddOptions (AddOptions(AddOptions))+import Proteome.Data.Env (_projects)+import Proteome.Data.Project (meta, ProjectMetadata(VirtualProject))+import Proteome.Project.Resolve (resolveProjectFromConfig)+import Proteome.Data.Proteome (Proteome) -proteomePoll :: Neovim env Bool-proteomePoll = return True+proAdd :: AddOptions -> Proteome ()+proAdd (AddOptions name tpe) = do+  project <- resolveProjectFromConfig Nothing name (Just tpe)+  case meta project of+    VirtualProject _ -> return ()+    _ -> Ribo.modify $ over _projects (\p -> p ++ [project])

@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Proteome.Data.AddOptions(+  AddOptions(..),+) where++import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+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 Proteome.Data.Project (ProjectName, ProjectType)++data AddOptions =+  AddOptions {+    name :: ProjectName,+    tpe :: ProjectType+  }+  deriving (Eq, Show, Generic, NFData)++instance NvimObject AddOptions where+  toObject AddOptions {..} =+    (toObject :: Dictionary -> Object) . Map.fromList $+    [+      ("name", toObject name),+      ("tpe", toObject tpe)+    ]+  fromObject (ObjectMap o) = do+    name' <- extractObject "name" o+    tpe' <- extractObject "tpe" o+    return $ AddOptions name' tpe'+  fromObject o = Left ("invalid type for AddOptions: " <+> viaShow o)

@@ -12,11 +12,13 @@ import Ribosome.Data.Errors (Errors) import Proteome.Data.Project(Project) -data Env = Env {-  mainProject :: Project,-  projects :: [Project],-  errors :: Errors-}+data Env =+  Env {+    mainProject :: Project,+    projects :: [Project],+    errors :: Errors+  }+  deriving Show  makeClassy_ ''Env 

@@ -2,21 +2,21 @@   initialize,   proteomeStage2,   proteomeStage4,+  proteomePoll,+  proteomeStage1, ) where -import Control.Monad.Reader import Data.Default.Class (Default(def)) import System.Directory (getCurrentDirectory, makeAbsolute) import System.FilePath (takeFileName, takeDirectory) import System.Log.Logger (updateGlobalLogger, setLevel, Priority(ERROR))-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Neovim (Neovim) import UnliftIO.STM (TVar, newTVarIO)-import Ribosome.Config.Setting (setting, settingE, updateSetting)+import Ribosome.Config.Setting (settingE, updateSetting) import Ribosome.Data.Ribo (Ribo) import qualified Ribosome.Data.Ribo as Ribo (inspect) import Ribosome.Data.Ribosome (Ribosome(Ribosome))-import Ribosome.File (canonicalPaths) import Ribosome.Internal.IO (retypeNeovim) import Proteome.Data.Env (Env(Env)) import qualified Proteome.Data.Env as Env (mainProject)@@ -28,8 +28,9 @@   ProjectType(..),   ProjectMetadata(DirProject),   )-import Proteome.Project.Resolve (resolveProject)+import Proteome.Project.Resolve (resolveProjectFromConfig) import Proteome.Config (readConfig)+import Proteome.PersistBuffers (loadBuffers) import Proteome.Log import qualified Proteome.Settings as S @@ -47,11 +48,7 @@ mainProject = do   mainDir <- settingE S.mainProjectDir   (root, name, tpe) <- pathData mainDir-  baseDirs <- (canonicalPaths <=< setting) S.projectBaseDirs-  -- typeDirs <- setting S.projectTypeDirs-  explicit <- setting S.projects-  config <- setting S.projectConfig-  return $ resolveProject baseDirs explicit config root name (Just tpe)+  resolveProjectFromConfig (Just root) name (Just tpe)  loadPersistedBuffers :: Project -> Neovim e () loadPersistedBuffers _ = return ()@@ -84,6 +81,9 @@   env <- retypeNeovim (Ribosome "proteome") initialize'   newTVarIO env +proteomeStage1 :: Proteome ()+proteomeStage1 = loadBuffers+ proteomeStage2 :: Proteome () proteomeStage2 = do   main <- Ribo.inspect Env.mainProject@@ -93,3 +93,6 @@ proteomeStage4 = do   main <- Ribo.inspect Env.mainProject   readConfig "project_after" main++proteomePoll :: Neovim e Bool+proteomePoll = return True

@@ -9,6 +9,7 @@ import GHC.Generics import Control.Monad (filterM) import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (runExceptT) import Data.Aeson (ToJSON(toEncoding), FromJSON, genericToEncoding, defaultOptions) import Data.Foldable (traverse_) import System.Directory (doesFileExist)@@ -55,12 +56,12 @@   persistStore (path </> "buffers") (PersistBuffers current' files)  decodePersistBuffers :: FilePath -> Proteome (Either String PersistBuffers)-decodePersistBuffers path = persistLoad (path </> "buffers")+decodePersistBuffers path = runExceptT $ persistLoad (path </> "buffers")  restoreBuffers :: PersistBuffers -> Proteome () restoreBuffers (PersistBuffers current' buffers') = do-  traverse_ (\a -> vim_command' ("badd " ++ a)) buffers'   mapM_ edit current'+  traverse_ (\a -> vim_command' ("silent! badd " ++ a)) buffers'  loadBuffers' :: FilePath -> Proteome () loadBuffers' path = do

@@ -6,11 +6,11 @@ where  import UnliftIO.STM (TVar)-import Neovim+import Neovim (Plugin(..), function', Neovim, StartupConfig, NeovimConfig, NeovimPlugin, Synchronous(..), wrapPlugin) import Ribosome.Data.Ribosome (Ribosome(Ribosome)) import Proteome.Init import Proteome.Data.Env-import Proteome.Add (proAdd, proteomePoll)+import Proteome.Add (proAdd) import Proteome.Config (proReadConfig) import Proteome.Tags (proTags) import Proteome.Save (proSave)@@ -21,6 +21,7 @@     environment = Ribosome "proteome" env,     exports = [       $(function' 'proteomePoll) Sync,+      $(function' 'proteomeStage1) Async,       $(function' 'proteomeStage2) Async,       $(function' 'proteomeStage4) Async,       $(function' 'proAdd) Async,

@@ -2,15 +2,23 @@  module Proteome.Project.Resolve(   resolveProject,+  resolveProjectFromConfig, ) where +import Control.Monad (foldM, join)+import Control.Monad.Reader ((<=<))+import Control.Monad.IO.Class (liftIO) import Data.List (find) import Data.List.Utils (uniq) import Data.Maybe (fromMaybe) import Data.Map.Strict ((!?), Map)-import System.FilePath (takeDirectory)-import Ribosome.Data.Maybe (orElse)+import System.Directory (doesDirectoryExist)+import System.FilePath (takeDirectory, (</>))+import Ribosome.File (canonicalPaths) import Proteome.Config (ProjectConfig(ProjectConfig))+import Ribosome.Config.Setting (setting)+import Ribosome.Data.Maybe (orElse)+import Ribosome.Data.Ribo (Ribo) import Proteome.Data.Project (   Project(Project),   ProjectName(..),@@ -21,6 +29,7 @@   ) import Proteome.Data.ProjectSpec (ProjectSpec(ProjectSpec)) import qualified Proteome.Data.ProjectSpec as PS (ProjectSpec(..))+import qualified Proteome.Settings as S  projectFromSegments :: ProjectType -> ProjectName -> ProjectRoot -> Project projectFromSegments tpe name root =@@ -41,18 +50,36 @@ byProjectTypeName :: [ProjectSpec] -> ProjectName -> ProjectType -> Maybe ProjectSpec byProjectTypeName specs name tpe = find (hasProjectTypeName tpe name) specs -byProjectBases :: [FilePath] -> ProjectRoot -> Bool-byProjectBases baseDirs (ProjectRoot root) = (takeDirectory . takeDirectory) root `elem` baseDirs+matchProjectBases :: [FilePath] -> ProjectRoot -> Bool+matchProjectBases baseDirs (ProjectRoot root) = (takeDirectory . takeDirectory) root `elem` baseDirs +byProjectBaseSubpath :: ProjectName -> ProjectType -> FilePath -> IO (Maybe Project)+byProjectBaseSubpath n@(ProjectName name) t@(ProjectType tpe) base = do+  exists <- doesDirectoryExist root+  return $ if exists then Just $ projectFromSegments t n (ProjectRoot root) else Nothing+  where root = base </> tpe </> name++byProjectBasesSubpath :: [FilePath] -> ProjectName -> ProjectType -> IO (Maybe Project)+byProjectBasesSubpath baseDirs name tpe =+  foldM subpath Nothing baseDirs+  where+    subpath (Just p) _ = return (Just p)+    subpath Nothing a = byProjectBaseSubpath name tpe a+ virtualProject :: ProjectName -> Project virtualProject name = Project (VirtualProject name) [] Nothing [] -resolveByType :: [FilePath] -> [ProjectSpec] -> ProjectRoot -> ProjectName -> ProjectType -> Maybe Project-resolveByType baseDirs explicit root name tpe =-  orElse (if byPath then Just (projectFromSegments tpe name root) else Nothing) (fmap projectFromSpec byTypeName)+resolveByTypeAndPath :: [FilePath] -> ProjectName -> ProjectType -> ProjectRoot -> Maybe Project+resolveByTypeAndPath baseDirs name tpe root =+  if matchProjectBases baseDirs root then Just (projectFromSegments tpe name root) else Nothing++resolveByType :: [FilePath] -> [ProjectSpec] -> Maybe ProjectRoot -> ProjectName -> ProjectType -> IO (Maybe Project)+resolveByType baseDirs explicit root name tpe = do+  byBaseSubpath <- byProjectBasesSubpath baseDirs name tpe+  return $ orElse (orElse byPath byBaseSubpath) (fmap projectFromSpec byTypeName)   where     byTypeName = byProjectTypeName explicit name tpe-    byPath = byProjectBases baseDirs root+    byPath = root >>= resolveByTypeAndPath baseDirs name tpe  resolveByRoot :: [ProjectSpec] -> ProjectRoot -> Maybe Project resolveByRoot explicit root =@@ -83,14 +110,21 @@   [FilePath] ->   [ProjectSpec] ->   ProjectConfig ->-  ProjectRoot ->+  Maybe ProjectRoot ->   ProjectName ->   Maybe ProjectType ->-  Project-resolveProject baseDirs explicit config root name tpe =-  augmentFromConfig config project-  where-    project = fromMaybe byTypeOrVirtual byRoot-    byTypeOrVirtual = fromMaybe (virtualProject name) byType-    byType = tpe >>= resolveByType baseDirs explicit root name-    byRoot = resolveByRoot explicit root+  IO Project+resolveProject baseDirs explicit config root name tpe = do+  byType <- traverse (resolveByType baseDirs explicit root name) tpe+  let byTypeOrVirtual = fromMaybe (virtualProject name) (join byType)+  let byRoot = root >>= resolveByRoot explicit+  let project = fromMaybe byTypeOrVirtual byRoot+  return $ augmentFromConfig config project++resolveProjectFromConfig :: Maybe ProjectRoot -> ProjectName -> Maybe ProjectType -> Ribo e Project+resolveProjectFromConfig root name tpe = do+  baseDirs <- (canonicalPaths <=< setting) S.projectBaseDirs+  -- typeDirs <- setting S.projectTypeDirs+  explicit <- setting S.projects+  config <- setting S.projectConfig+  liftIO $ resolveProject baseDirs explicit config root name tpe

@@ -3,6 +3,10 @@ ) where  import Proteome.Data.Proteome (Proteome)+import Proteome.Tags (proTags)+import Proteome.PersistBuffers (storeBuffers)  proSave :: Proteome ()-proSave = return ()+proSave = do+  proTags+  storeBuffers

@@ -6,4 +6,4 @@ import Ribosome.Data.Ribo (Ribo)  edit :: FilePath -> Ribo e ()-edit path = vim_command' $ "edit " ++ path+edit path = vim_command' $ "silent! edit " ++ path

@@ -10,16 +10,18 @@  newtype ComponentName =   ComponentName String-  deriving (Eq, Ord)+  deriving (Eq, Ord, Show)  data Error =   Error {     errorTimestamp :: Int,     errorMessage :: [String]   }+  deriving Show  newtype Errors =   Errors (Map ComponentName [Error])+  deriving Show  instance Default Errors where   def = Errors Map.empty

@@ -0,0 +1,13 @@+module Ribosome.Monad(+  liftExceptTIO,+  liftExceptT,+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Except (ExceptT(ExceptT))++liftExceptTIO :: (MonadIO m) => IO a -> ExceptT e m a+liftExceptTIO fa = ExceptT $ Right <$> liftIO fa++liftExceptT :: (Functor m) => m a -> ExceptT e m a+liftExceptT fa = ExceptT $ Right <$> fa

@@ -6,11 +6,15 @@   persistLoad, ) where -import Control.Monad.IO.Class (liftIO)+import GHC.IO.Exception (IOException)+import Control.Exception (try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Except (ExceptT(ExceptT), catchE) import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode)-import qualified Data.ByteString.Lazy as B (writeFile, readFile)+import qualified Data.ByteString.Lazy as B (writeFile, readFile, ByteString) import System.FilePath (takeDirectory, (</>)) import System.Directory (getXdgDirectory, XdgDirectory(XdgCache), createDirectoryIfMissing)+import Ribosome.Monad (liftExceptT) import Ribosome.Data.Ribo (Ribo) import qualified Ribosome.Data.Ribo as Ribo (name) import Ribosome.Config.Setting (settingE)@@ -38,8 +42,14 @@   file <- persistenceFile path   liftIO $ B.writeFile file (encode a) -persistLoad :: FromJSON a => FilePath -> Ribo e (Either String a)+noSuchFile :: Monad m => FilePath -> ExceptT String m a+noSuchFile file = ExceptT $ return $ Left $ "persistence file " ++ file ++ " doesn't exist"++safeReadFile :: MonadIO m => FilePath -> m (Either IOException B.ByteString)+safeReadFile file = liftIO $ try $ B.readFile file++persistLoad :: FromJSON a => FilePath -> ExceptT String (Ribo e) a persistLoad path = do-  file <- persistenceFile path-  json <- liftIO $ B.readFile file-  return $ eitherDecode json+  file <- liftExceptT $ persistenceFile path+  json <- catchE (ExceptT $ safeReadFile file) (const $ noSuchFile file)+  ExceptT $ return $ eitherDecode json

@@ -0,0 +1,8 @@+module Ribosome.Unsafe(+  unsafeLog,+) where++import GHC.IO.Unsafe (unsafePerformIO)++unsafeLog :: Show a => a -> b -> b+unsafeLog a b = unsafePerformIO $ (print a) >> return b

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: a03ae37f8c9f55fb65ad8ea46b8d150f3c28a442c4202f2e49d4e3c1f938fab9+-- hash: ee165e2612b4794394cbe7da84f7fb9150ea73099aadb78e479de5bb1db4ea24  name:           proteome-version:        0.3.4.0+version:        0.3.5.0 synopsis:       neovim project manager description:    Please see the README on GitHub at <https://github.com/tek/proteome-hs> category:       Neovim@@ -30,6 +30,7 @@   exposed-modules:       Proteome.Add       Proteome.Config+      Proteome.Data.AddOptions       Proteome.Data.Env       Proteome.Data.Project       Proteome.Data.ProjectSpec@@ -59,12 +60,14 @@       Ribosome.Internal.IO       Ribosome.Internal.NvimObject       Ribosome.Log+      Ribosome.Monad       Ribosome.Persist       Ribosome.Test.Embed       Ribosome.Test.Exists       Ribosome.Test.File       Ribosome.Test.Functional       Ribosome.Test.Unit+      Ribosome.Unsafe   other-modules:       Paths_proteome   hs-source-dirs:@@ -94,6 +97,7 @@     , strings     , text     , time+    , transformers     , unliftio     , utf8-string   default-language: Haskell2010@@ -131,6 +135,7 @@     , strings     , text     , time+    , transformers     , unliftio     , utf8-string   default-language: Haskell2010@@ -139,6 +144,7 @@   type: exitcode-stdio-1.0   main-is: SpecMain.hs   other-modules:+      AddSpec       Config       ConfigSpec       InitSpec@@ -173,6 +179,7 @@     , strings     , text     , time+    , transformers     , unliftio     , utf8-string   default-language: Haskell2010@@ -181,6 +188,7 @@   type: exitcode-stdio-1.0   main-is: SpecMain.hs   other-modules:+      AddSpec       Config       PersistLoadSpec       PersistStoreSpec@@ -217,6 +225,7 @@     , strings     , text     , time+    , transformers     , unliftio     , utf8-string   default-language: Haskell2010

@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++module AddSpec(+  htf_thisModulesTests+) where++import qualified Data.Map as Map (fromList)+import Test.Framework+import Neovim (vim_call_function, toObject)+import Ribosome.Data.Ribo (Ribo)+import Proteome.Test.Functional (specWith)+import Config (vars)++addSpec :: Ribo env ()+addSpec = do+  _ <- vim_call_function "ProAdd" [toObject $ Map.fromList [("name", "bar"), ("tpe", "foo")]]+  return ()++test_add :: IO ()+test_add = do+  v <- vars+  specWith v addSpec

@@ -4,6 +4,7 @@  import {-@ HTF_TESTS @-} ConfigSpec import {-@ HTF_TESTS @-} InitSpec+import {-@ HTF_TESTS @-} AddSpec import Test.Framework import Test.Framework.BlackBoxTest () 

@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++module AddSpec(+  htf_thisModulesTests+) where++import Control.Monad.IO.Class (liftIO)+import System.FilePath ((</>))+import Test.Framework+import Ribosome.Config.Setting (updateSetting)+import qualified Ribosome.Data.Ribo as Ribo (inspect)+import Ribosome.Test.Unit (fixture)+import Proteome.Data.Proteome (Proteome)+import Proteome.Add (proAdd)+import Proteome.Data.Env (projects)+import Proteome.Data.AddOptions (AddOptions(AddOptions))+import Proteome.Data.Project (+  ProjectName(ProjectName),+  ProjectType(ProjectType),+  ProjectLang(ProjectLang),+  ProjectRoot(ProjectRoot),+  ProjectMetadata(DirProject),+  Project(Project),+  )+import qualified Proteome.Settings as S (projectBaseDirs)+import Proteome.Test.Unit (specWithDef)+import Config (vars)++flag :: String+flag = "flagellum"++hask :: String+hask = "haskell"++n :: ProjectName+n = ProjectName flag++tp :: ProjectType+tp = ProjectType hask++l :: ProjectLang+l = ProjectLang hask++addSpec :: Proteome ()+addSpec = do+  projectsDir <- fixture "projects"+  updateSetting S.projectBaseDirs [projectsDir]+  proAdd $ AddOptions n tp+  ps <- Ribo.inspect projects+  let root = projectsDir </> hask </> flag+  liftIO $ assertEqual [Project (DirProject n (ProjectRoot root) (Just tp)) [] (Just l) []] ps++test_add :: IO ()+test_add = vars >>= specWithDef addSpec

@@ -37,7 +37,7 @@   updateSetting persistenceDir persistDir   loadBuffers   buffers <- vim_get_buffers'-  liftIO $ assertEqual (length buffers) 4+  liftIO $ assertEqual 3 (length buffers)   active <- buffer_get_name' =<< vim_get_current_buffer'   liftIO $ assertEqual active (fixDir </> "file2") 

@@ -62,5 +62,5 @@  test_typeMap :: IO () test_typeMap = do-  let project = resolveProject ["/projects"] [] config root name (Just tpe)+  project <- resolveProject ["/projects"] [] config (Just root) name (Just tpe)   assertEqual targetProject project

@@ -6,6 +6,7 @@ import {-@ HTF_TESTS @-} ResolveSpec import {-@ HTF_TESTS @-} PersistLoadSpec import {-@ HTF_TESTS @-} PersistStoreSpec+import {-@ HTF_TESTS @-} AddSpec import Test.Framework import Test.Framework.BlackBoxTest ()