diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,34 @@ -The MIT License (MIT) +Copyright (c) 2021 Torsten Schmits -Copyright (c) 2018 Torsten Schmits +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the +following conditions are met: -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies -of the Software, and to permit persons to whom the Software is furnished to do -so, subject to the following conditions: + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following + disclaimer. + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided with the distribution. -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those +receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except +for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell, +import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired +or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by: -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. + (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of + contributors, in source or binary form) alone; or + (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such + copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to + be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution. + +Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this +license, whether expressly, by implication, estoppel or otherwise. + +DISCLAIMER + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,13 +0,0 @@ -# Intro - -A neovim plugin that provides project-specific configuration file loading and performs runtime tasks on projects. - -# Install - -Use the [chromatin] plugin manager with the spec `hackage:proteome`: - -```vim -let g:chromatin_rplugins += [{ 'spec': 'hackage:proteome', 'name': 'proteome' }] -``` - -[chromatin]: https://github.com/tek/chromatin.nvim diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,7 @@ -import Neovim +module Main where -import Proteome.Plugin (plugin) +import Proteome.Plugin (proteome) main :: IO () -main = neovim defaultConfig {plugins = [plugin]} +main = + proteome diff --git a/lib/Proteome/Add.hs b/lib/Proteome/Add.hs --- a/lib/Proteome/Add.hs +++ b/lib/Proteome/Add.hs @@ -1,50 +1,167 @@ -{-# LANGUAGE RecordWildCards #-} - -module Proteome.Add( - proAdd, - proAddCmd, -) -where +module Proteome.Add where -import Control.Monad (when) -import Control.Lens (over) -import Data.List.Utils (split) -import Neovim (nvim_err_writeln', CommandArguments(CommandArguments, bang)) -import qualified Ribosome.Control.Ribo as Ribo (modify) -import Proteome.Data.AddOptions (AddOptions(AddOptions)) -import Proteome.Data.Env (_projects) -import Proteome.Data.Project ( - meta, - ProjectMetadata(VirtualProject), - ProjectName(ProjectName), - ProjectType(ProjectType), +import qualified Data.Text as Text +import Path (Abs, Dir, Path, dirname, parent, stripProperPrefix) +import Path.IO (listDir) +import Ribosome ( + Bang (Bang), + Handler, + PluginName, + Rpc, + RpcError, + SettingError, + Settings, + mapReport, + pathText, + resumeReport, ) +import Ribosome.Menu ( + Filter (Fuzzy), + MenuItem (..), + MenuResult, + MenuWidget, + ModalState, + ModalWindowMenus, + modal, + staticWindowMenu, + traverseSelection_, + ) +import Ribosome.Scratch (scratch, syntax) +import qualified Ribosome.Settings as Settings + +import Proteome.Add.Syntax (addSyntax) +import qualified Proteome.Data.AddError as AddError +import Proteome.Data.AddError (AddError) +import Proteome.Data.AddItem (AddItem (AddItem)) +import Proteome.Data.AddOptions (AddOptions (AddOptions)) +import Proteome.Data.Env (Env) +import Proteome.Data.Project (Project (Project)) +import qualified Proteome.Data.ProjectConfig as ProjectConfig +import Proteome.Data.ProjectConfig (ProjectConfig) +import Proteome.Data.ProjectMetadata (ProjectMetadata (VirtualProject)) +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) +import Proteome.Data.ResolveError (ResolveError) +import Proteome.Path (dropSlash) import Proteome.Project.Activate (selectProject) -import Proteome.Project.Resolve (resolveProjectFromConfig) -import Proteome.Data.Proteome (Proteome) +import Proteome.Project.Resolve (fromNameSettings) +import qualified Proteome.Settings as Settings -add :: ProjectName -> Maybe ProjectType -> Bool -> Proteome () +type AddState = + ModalState AddItem + +add :: + Members [Settings, Rpc, AtomicState Env, Reader PluginName, Stop ResolveError, Log, Embed IO] r => + ProjectName -> + Maybe ProjectType -> + Bool -> + Sem r () 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) + addDirProject =<< fromNameSettings name tpe + when activate (selectProject (-1)) + where + addDirProject (Project (VirtualProject _) _ _ _) = + unit + addDirProject project = + atomicModify' (#projects <>~ [project]) -proAdd :: AddOptions -> Proteome () +proAdd :: + Members [Settings !! SettingError, Rpc !! RpcError, AtomicState Env, Reader PluginName, Log, Embed IO] r => + AddOptions -> + Handler r () proAdd (AddOptions name tpe activate) = - add name (Just tpe) activate + resumeReport @Settings $ resumeReport @Rpc $ mapReport do + add name (Just tpe) (fromMaybe False activate) -addFromName :: ProjectName -> Bool -> Proteome () -addFromName name = add name Nothing +addFromName :: + Members [Settings, Rpc, AtomicState Env, Reader PluginName, Stop ResolveError, Log, Embed IO] r => + ProjectName -> + Bool -> + Sem r () +addFromName name = + add name Nothing -proAddCmd :: CommandArguments -> String -> Proteome () -proAddCmd args spec = - case split "/" spec of - [tpe, name] -> add (ProjectName name) (Just (ProjectType tpe)) activate - [name] -> addFromName (ProjectName name) activate - _ -> nvim_err_writeln' $ "invalid project spec: " ++ spec +proAddCmd :: + Members [Settings !! SettingError, Rpc !! RpcError, AtomicState Env, Reader PluginName, Log, Embed IO] r => + Bang -> + Text -> + Handler r () +proAddCmd bang spec = + resumeReport @Settings $ resumeReport @Rpc $ mapReport @ResolveError $ mapReport @AddError do + process (Text.splitOn "/" spec) where - activate = case args of - CommandArguments { bang = Just True, .. } -> True - _ -> False + process [tpe, name] = + add (ProjectName name) (Just (ProjectType tpe)) activate + process [name] = + addFromName (ProjectName name) (bang == Bang) + process _ = + stop (AddError.InvalidProjectSpec spec) + activate = + bang == Bang + +availableProjectsInBase :: + Members [Stop AddError, Embed IO] r => + Path Abs Dir -> + Sem r [MenuItem AddItem] +availableProjectsInBase base = + fmap (fmap cons . join) . traverse list =<< list base + where + list d = + stopEitherWith AddError.Directory =<< tryAny (fst <$> listDir d) + cons proj = + MenuItem (AddItem tpe name) pt (maybe pt dropSlash (stripProperPrefix base proj)) + where + tpe = + dropSlash (dirname (parent proj)) + name = + dropSlash (dirname proj) + pt = + pathText proj + +availableProjects :: + Members [Stop AddError, Embed IO] r => + ProjectConfig -> + Sem r [MenuItem AddItem] +availableProjects (ProjectConfig.baseDirs -> dirs) = + join <$> traverse availableProjectsInBase dirs + +menuAdd :: + Members [Settings, Rpc, AtomicState Env, Reader PluginName, Stop ResolveError, Log, Embed IO] r => + MenuWidget AddState r () +menuAdd = + traverseSelection_ \ (AddItem tpe name) -> + add (ProjectName name) (Just (ProjectType tpe)) True + +type AddStack = + [ + ModalWindowMenus () AddItem !! RpcError, + AtomicState Env, + Reader PluginName, + Settings !! SettingError, + Rpc !! RpcError, + Log, + Embed IO + ] + +addMenu :: + Members AddStack r => + Members [Rpc, Settings, Stop ResolveError, Stop AddError, Stop RpcError] r => + Sem r (MenuResult ()) +addMenu = do + projectConfig <- Settings.get Settings.projectConfig + projects <- sort <$> availableProjects projectConfig + staticWindowMenu projects (modal Fuzzy) (def & #items .~ scratchOptions) [("", menuAdd)] + where + scratchOptions = + (scratch "proteome-add") { syntax = [addSyntax] } + +proAddMenu :: + Members AddStack r => + Handler r () +proAddMenu = + resumeReport @Rpc $ + resumeReport @Settings $ + mapReport @AddError $ + mapReport @ResolveError $ + mapReport @RpcError do + void $ addMenu diff --git a/lib/Proteome/Add/Syntax.hs b/lib/Proteome/Add/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Add/Syntax.hs @@ -0,0 +1,36 @@ +module Proteome.Add.Syntax where + +import qualified Data.Map.Strict as Map (fromList) +import Ribosome.Data.Syntax.Syntax (HiLink (HiLink), Syntax (Syntax)) +import Ribosome.Data.SyntaxItem (SyntaxItem (options, params)) +import Ribosome.Syntax (syntaxMatch, syntaxVerbatim) +import Text.RawString.QQ (r) + +asterisk :: SyntaxItem +asterisk = + item {options, params} + where + item = syntaxMatch "ProAddAsterisk" [r|^ \*|] + options = ["skipwhite"] + params = Map.fromList [("nextgroup", "ProAddName")] + +sync :: SyntaxItem +sync = + syntaxVerbatim "syntax sync minlines=1" + +hlAsterisk :: HiLink +hlAsterisk = + HiLink "ProAddAsterisk" "Todo" + +hlName :: HiLink +hlName = + HiLink "ProAddName" "Type" + +addSyntax :: Syntax +addSyntax = + Syntax items [] links + where + items = + [asterisk, sync] + links = + [hlAsterisk, hlName] diff --git a/lib/Proteome/BufEnter.hs b/lib/Proteome/BufEnter.hs --- a/lib/Proteome/BufEnter.hs +++ b/lib/Proteome/BufEnter.hs @@ -1,30 +1,62 @@ -module Proteome.BufEnter( - bufEnter, -) where +module Proteome.BufEnter where -import Data.List (intercalate) -import Data.Maybe (maybeToList) -import System.FilePath (()) -import Neovim (buffer_set_option', Neovim, vim_get_current_buffer', toObject) -import Ribosome.Config.Setting (setting) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project (Project(Project), ProjectMetadata(DirProject), ProjectRoot(ProjectRoot)) +import Conc (Lock, lock) +import Data.List.Extra (nub) +import qualified Data.Text as Text (intercalate) +import Path (Abs, Dir, File, Path, toFilePath, ()) +import Ribosome (Buffer, Handler, Rpc, RpcError, Settings, resumeReport) +import Ribosome.Api (bufferSetOption, vimGetCurrentBuffer) +import Ribosome.Api.Buffer (bufferIsFile, buflisted) +import Ribosome.Data.SettingError (SettingError) +import qualified Ribosome.Settings as Settings + +import Proteome.Data.Env (Env) +import qualified Proteome.Data.Env as Env (buffers) +import Proteome.Data.Project (Project (Project)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot)) import Proteome.Project (allProjects) import Proteome.Settings (tagsFileName) -setBufferTags :: [String] -> Neovim e () +data Mru = + Mru + deriving stock (Eq, Show) + +setBufferTags :: + Member Rpc r => + [Path Abs File] -> + Sem r () setBufferTags tags = do - buf <- vim_get_current_buffer' - buffer_set_option' buf "tags" (toObject $ intercalate "," tags) + buf <- vimGetCurrentBuffer + bufferSetOption buf "tags" (Text.intercalate "," (toText . toFilePath <$> tags)) -projectRoot :: Project -> Maybe FilePath +projectRoot :: Project -> Maybe (Path Abs Dir) projectRoot (Project (DirProject _ (ProjectRoot root) _) _ _ _) = Just root projectRoot _ = Nothing -bufEnter :: Proteome () -bufEnter = do - pros <- allProjects - name <- setting tagsFileName - let roots = pros >>= maybeToList . projectRoot - let tags = fmap ( name) roots - setBufferTags tags +updateBufferMru :: + Members [AtomicState Env, Lock @@ Mru, Rpc !! RpcError, Resource] r => + Buffer -> + Sem r () +updateBufferMru buffer = do + tag $ lock do + old <- atomicGets Env.buffers + new <- filterM buflisted (nub (buffer : old)) + atomicModify' (#buffers .~ new) + +updateBuffers :: + Members [AtomicState Env, Lock @@ Mru, Rpc, Rpc !! RpcError, Resource] r => + Sem r () +updateBuffers = do + current <- vimGetCurrentBuffer + whenM (bufferIsFile current) (updateBufferMru current) + +bufEnter :: + Members [AtomicState Env, Lock @@ Mru, Rpc !! RpcError, Settings !! SettingError, Resource] r => + Handler r () +bufEnter = + resumeReport @Rpc do + updateBuffers + roots <- mapMaybe projectRoot <$> allProjects + name <- resumeReport (Settings.get tagsFileName) + setBufferTags (( name) <$> roots) diff --git a/lib/Proteome/Buffers.hs b/lib/Proteome/Buffers.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Buffers.hs @@ -0,0 +1,211 @@ +module Proteome.Buffers where + +import Control.Lens (elemOf, view) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as Text +import Exon (exon) +import Ribosome ( + Handler, + Report, + Rpc, + RpcError, + ScratchId (ScratchId), + SettingError, + Settings, + mapReport, + pathText, + resumeReport, + ) +import Ribosome.Api ( + bufferGetName, + bufferGetNumber, + bufferIsFile, + buflisted, + ensureMainWindow, + nvimBufIsLoaded, + nvimCommand, + nvimCwd, + setCurrentBuffer, + vimGetCurrentBuffer, + vimGetCurrentWindow, + vimSetCurrentWindow, + ) +import Ribosome.Menu ( + Filter (Fuzzy), + Mappings, + MenuAction (Render), + MenuItem (MenuItem), + MenuWidget, + ModalState, + ModalWindowMenus, + deleteSelected, + menuState, + modal, + staticWindowMenu, + unselected, + use, + withFocus, + withSelection', + ) +import Ribosome.Scratch (ScratchOptions (..)) +import qualified Ribosome.Settings as Settings + +import Proteome.Buffers.Syntax (buffersSyntax) +import qualified Proteome.Data.Env as Env +import Proteome.Data.Env (Env) +import qualified Proteome.Data.ListedBuffer as ListedBuffer +import Proteome.Data.ListedBuffer (ListedBuffer (ListedBuffer)) +import Proteome.Menu (handleResult) +import qualified Proteome.Settings as Settings + +newtype BufferAction = + Load ListedBuffer + deriving stock (Eq, Show) + +type BuffersState = + ModalState ListedBuffer + +loadListedBuffer :: + Member Rpc r => + ListedBuffer -> + Sem r () +loadListedBuffer (ListedBuffer buffer number _) = + ifM (nvimBufIsLoaded buffer) (setCurrentBuffer buffer) (nvimCommand [exon|buffer #{show number}|]) + +load :: + MenuWidget BuffersState r BufferAction +load = + withFocus (pure . Load) + +compensateForMissingActiveBuffer :: + Member Rpc r => + NonEmpty ListedBuffer -> + [ListedBuffer] -> + Sem r () +compensateForMissingActiveBuffer _ [] = + nvimCommand "enew" +compensateForMissingActiveBuffer marked (next : _) = do + prev <- vimGetCurrentWindow + void ensureMainWindow + current <- vimGetCurrentBuffer + when (elemOf (each . #buffer) current marked) (loadListedBuffer next) + vimSetCurrentWindow prev + +deleteListedBuffersWith :: + Member Rpc r => + Text -> + NonEmpty ListedBuffer -> + Sem r () +deleteListedBuffersWith deleter bufs = + nvimCommand [exon|#{deleter} #{numbers}|] + where + numbers = + unwords (show . ListedBuffer.number <$> NonEmpty.toList bufs) + +deleteWith :: + Member Rpc r => + Text -> + MenuWidget BuffersState r a +deleteWith deleter = + menuState $ withSelection' \ delete -> do + keep <- fmap (view #meta) <$> use unselected + compensateForMissingActiveBuffer delete keep + deleteListedBuffersWith deleter delete + deleteSelected + pure Render + +moveCurrentLast :: + Member Rpc r => + [MenuItem ListedBuffer] -> + Sem r [MenuItem ListedBuffer] +moveCurrentLast items = do + current <- vimGetCurrentBuffer + pure $ spin current items [] + where + spin current (item : rest) result | item ^. lens == current = + result ++ rest ++ [item] + spin current (item : rest) result = + spin current rest (item : result) + spin _ [] result = + result + lens = + #meta . #buffer + +buffers :: + Members [AtomicState Env, Settings !! SettingError, Rpc, Rpc !! RpcError] r => + Sem r [MenuItem ListedBuffer] +buffers = do + cwd <- nvimCwd + bufs <- filterM bufferIsFile =<< filterM buflisted =<< atomicGets Env.buffers + numbers <- traverse bufferGetNumber bufs + names <- traverse bufferGetName bufs + let items = item (pathText cwd) (padding numbers) <$> zip3 bufs numbers names + ifM (Settings.or False Settings.buffersCurrentLast) (moveCurrentLast items) (pure items) + where + padding = + Text.length . show . maximum + item cwd pad (buf, num, name) = + MenuItem (ListedBuffer buf num name) text' text' + where + text' = + " * " <> padded pad (show num) <> " " <> strip cwd name + padded pad num = + Text.replicate (pad - Text.length num) " " <> num + strip cwd name = + fromMaybe name $ Text.stripPrefix cwd name + +actions :: + Member Rpc r => + Mappings BuffersState r BufferAction +actions = + [ + ("", load), + ("d", deleteWith "bdelete"), + ("D", deleteWith "bdelete!"), + ("w", deleteWith "bwipeout"), + ("W", deleteWith "bwipeout!") + ] + +bufferAction :: + Member Rpc r => + BufferAction -> + Sem r () +bufferAction = \case + Load buf -> + loadListedBuffer buf + +type BuffersStack = + [ + ModalWindowMenus () ListedBuffer !! RpcError, + AtomicState Env, + Settings !! SettingError, + Rpc !! RpcError, + Log + ] + +buffersMenu :: + ∀ r . + Members BuffersStack r => + Members [Rpc, Stop Report] r => + Sem r () +buffersMenu = do + items <- buffers + result <- mapReport do + staticWindowMenu items (modal Fuzzy) (def & #items .~ scratchOptions) actions + handleResult bufferAction result + where + scratchOptions = + def { + name = ScratchId name, + syntax = [buffersSyntax], + filetype = Just name + } + name = + "proteome-buffers" + +proBuffers :: + Members BuffersStack r => + Handler r () +proBuffers = + resumeReport @Rpc do + buffersMenu diff --git a/lib/Proteome/Buffers/Syntax.hs b/lib/Proteome/Buffers/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Buffers/Syntax.hs @@ -0,0 +1,54 @@ +module Proteome.Buffers.Syntax where + +import qualified Data.Map.Strict as Map (fromList) +import Ribosome.Data.SyntaxItem (SyntaxItem (options, params)) +import Ribosome.Syntax (HiLink (HiLink), Syntax (Syntax), syntaxMatch, syntaxVerbatim) +import Text.RawString.QQ (r) + +asterisk :: SyntaxItem +asterisk = + item {options, params} + where + item = syntaxMatch "ProBuffersAsterisk" [r|^ \*|] + options = ["skipwhite"] + params = Map.fromList [("nextgroup", "ProBuffersNumber")] + +number :: SyntaxItem +number = + item {options, params} + where + item = syntaxMatch "ProBuffersNumber" [r|\d\+|] + options = ["contained", "skipwhite"] + params = Map.fromList [("nextgroup", "ProBuffersName")] + +line :: SyntaxItem +line = + item {options} + where + item = syntaxMatch "ProBuffersName" ".*$" + options = ["contained"] + +sync :: SyntaxItem +sync = + syntaxVerbatim "syntax sync minlines=1" + +hlAsterisk :: HiLink +hlAsterisk = + HiLink "ProBuffersAsterisk" "Todo" + +hlNumber :: HiLink +hlNumber = + HiLink "ProBuffersNumber" "Directory" + +hlName :: HiLink +hlName = + HiLink "ProBuffersName" "Type" + +buffersSyntax :: Syntax +buffersSyntax = + Syntax items [] links + where + items = + [asterisk, number, line, sync] + links = + [hlAsterisk, hlNumber, hlName] diff --git a/lib/Proteome/Config.hs b/lib/Proteome/Config.hs --- a/lib/Proteome/Config.hs +++ b/lib/Proteome/Config.hs @@ -1,113 +1,105 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE RecordWildCards #-} - -module Proteome.Config( - proReadConfig, - readConfig, - ProjectConfig (..), - logConfig, -) -where - -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import Control.Lens (over) -import Control.Monad (join) -import qualified Data.Map as Map -import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe) -import Data.Text.Prettyprint.Doc ((<+>), viaShow) -import Neovim (NvimObject(..), Dictionary, Object(ObjectMap), vim_command') -import Ribosome.Control.Ribo (Ribo) -import qualified Ribosome.Control.Ribo as Ribo (modify) -import Ribosome.Api.Function (callFunction) -import Ribosome.Api.Option (optionString) -import Ribosome.Internal.NvimObject (extractObject) -import Proteome.Data.Env (_configLog) -import Proteome.Data.Project ( - Project(Project, types), - ProjectType(ProjectType, projectType), - ProjectLang, - ProjectName(ProjectName), - ProjectMetadata(DirProject), - ) -import Proteome.Data.Proteome -import Proteome.Env (getMainProject) +module Proteome.Config where -data ProjectConfig = - ProjectConfig { - projectTypes :: Map ProjectType [FilePath], - typeMap :: Map ProjectType [ProjectType], - langMap :: Map ProjectType ProjectLang, - langsMap :: Map ProjectLang [ProjectLang] - } - deriving (Generic, NFData) +import Exon (exon) +import Ribosome (Handler, Rpc, RpcError, msgpackArray, resumeReport) +import Ribosome.Api (nvimGetOption, vimCallFunction, vimCommand) -instance NvimObject ProjectConfig where - toObject ProjectConfig {..} = - (toObject :: Dictionary -> Object) . Map.fromList $ - [ - ("projectTypes", toObject projectTypes), - ("typeMap", toObject typeMap), - ("langMap", toObject langMap), - ("langsMap", toObject langsMap) - ] - fromObject (ObjectMap o) = do - projectTypes' <- extractObject "projectTypes" o - typeMap' <- extractObject "typeMap" o - langMap' <- extractObject "langMap" o - langsMap' <- extractObject "langsMap" o - return $ ProjectConfig projectTypes' typeMap' langMap' langsMap' - fromObject o = Left ("invalid type for ProjectConfig: " <+> viaShow o) +import qualified Proteome.Data.Env as Env +import Proteome.Data.Env (Env) +import qualified Proteome.Data.Project as Project +import Proteome.Data.Project (Project (Project)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject)) +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) -globRtp :: FilePath -> Ribo a [FilePath] +globRtp :: + Member Rpc r => + Text -> + Sem r [Text] globRtp path = do - rtp <- optionString "runtimepath" - callFunction "globpath" [toObject rtp, toObject path, toObject False, toObject True] + rtp :: Text <- nvimGetOption "runtimepath" + vimCallFunction "globpath" (msgpackArray rtp path False True) -runtime :: FilePath -> Ribo a [FilePath] +runtime :: + Member Rpc r => + Text -> + Sem r [Text] runtime path = do - vim_command' $ "runtime! " ++ fpath + vimCommand [exon|runtime! #{fpath}|] globRtp fpath - where fpath = path ++ ".vim" + where + fpath = path <> ".vim" -runtimeConf :: FilePath -> String -> Ribo a [FilePath] -runtimeConf confDir path = runtime (confDir ++ "/" ++ path) +runtimeConf :: + Member Rpc r => + Text -> + Text -> + Sem r [Text] +runtimeConf confDir path = + runtime [exon|#{confDir}/#{path}|] -typeProjectConf :: FilePath -> ProjectName -> ProjectType -> Ribo a [FilePath] +typeProjectConf :: + Member Rpc r => + Text -> + ProjectName -> + ProjectType -> + Sem r [Text] typeProjectConf confDir (ProjectName name') (ProjectType tpe') = do tpePaths <- runtimeConf confDir tpe' - namePaths <- runtimeConf confDir $ tpe' ++ "/" ++ name' - return $ tpePaths ++ namePaths + namePaths <- runtimeConf confDir $ tpe' <> "/" <> name' + pure $ tpePaths <> namePaths -readConfigMeta :: String -> Project -> Ribo a [FilePath] +readConfigMeta :: + Member Rpc r => + Text -> + Project -> + Sem r [Text] readConfigMeta confDir (Project (DirProject name' _ tpe') _ _ _) = do paths <- traverse (typeProjectConf confDir name') tpe' - return $ fromMaybe [] paths -readConfigMeta _ _ = return [] + pure $ fromMaybe [] paths +readConfigMeta _ _ = pure [] -readConfigProject :: String -> Project -> Ribo a [FilePath] +readConfigProject :: + Member Rpc r => + Text -> + Project -> + Sem r [Text] readConfigProject confDir project = do - paths <- traverse (runtimeConf confDir) (fmap projectType (types project)) + paths <- traverse (runtimeConf confDir . coerce) (Project.types project) metaPaths <- readConfigMeta confDir project - return $ join paths ++ metaPaths + pure $ join paths <> metaPaths -readConfig :: String -> Project -> Ribo a [FilePath] +readConfig :: + Member Rpc r => + Text -> + Project -> + Sem r [Text] readConfig confDir project = do allPaths <- runtimeConf confDir "all/*" projectPaths <- readConfigProject confDir project - return $ allPaths ++ projectPaths + pure $ allPaths <> projectPaths -logConfig :: [FilePath] -> Proteome () +logConfig :: + Member (AtomicState Env) r => + [Text] -> + Sem r () logConfig paths = - Ribo.modify $ over _configLog (paths ++) + atomicModify' (#configLog %~ (paths <>)) -proReadConfig :: Proteome () +proReadConfig :: + Members [Rpc !! RpcError, AtomicState Env] r => + Handler r () proReadConfig = do - main <- getMainProject - configs <- readConfig "project" main - logConfig configs - afterConfigs <- readConfig "project_after" main - logConfig afterConfigs + resumeReport @Rpc do + main <- atomicGets Env.mainProject + configs <- readConfig "project" main + logConfig configs + afterConfigs <- readConfig "project_after" main + logConfig afterConfigs + +defaultTypeMarkers :: Map ProjectType [Text] +defaultTypeMarkers = + [ + (ProjectType "haskell", ["stack.yaml", "*.cabal", "cabal.project"]), + (ProjectType "scala", ["*.sbt"]) + ] diff --git a/lib/Proteome/Data/ActiveProject.hs b/lib/Proteome/Data/ActiveProject.hs --- a/lib/Proteome/Data/ActiveProject.hs +++ b/lib/Proteome/Data/ActiveProject.hs @@ -1,22 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} +module Proteome.Data.ActiveProject where -module Proteome.Data.ActiveProject( - ActiveProject(ActiveProject), -) where +import Ribosome (MsgpackDecode, MsgpackEncode) -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import qualified Data.Map as Map (fromList) -import Neovim (Object) -import Neovim.Classes (NvimObject(..), Dictionary) -import Proteome.Data.Project( - ProjectName, - ProjectType, - ProjectLang - ) +import Proteome.Data.ProjectLang (ProjectLang) +import Proteome.Data.ProjectName (ProjectName) +import Proteome.Data.ProjectType (ProjectType) data ActiveProject = ActiveProject { @@ -24,14 +12,5 @@ tpe :: ProjectType, lang :: Maybe ProjectLang } - deriving (Eq, Show, Generic, NFData) - -instance NvimObject ActiveProject where - toObject ActiveProject {..} = - (toObject :: Dictionary -> Object) . Map.fromList $ - [ - ("name", toObject name), - ("tpe", toObject tpe), - ("lang", toObject lang) - ] - fromObject _ = Left "ActiveProject is write-only" + deriving stock (Eq, Show, Generic) + deriving anyclass (MsgpackDecode, MsgpackEncode) diff --git a/lib/Proteome/Data/AddError.hs b/lib/Proteome/Data/AddError.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/AddError.hs @@ -0,0 +1,18 @@ +module Proteome.Data.AddError where + +import Exon (exon) +import Log (Severity (Info)) +import Ribosome (Report (Report), Reportable (toReport)) + +data AddError = + InvalidProjectSpec Text + | + Directory Text + deriving stock (Eq, Show) + +instance Reportable AddError where + toReport = \case + InvalidProjectSpec spec -> + Report [exon|no such project: #{spec}|] ["AddError.InvalidProjectSpec:", spec] Info + Directory msg -> + Report [exon|Listing directories: #{msg}|] ["AddError.Directory:", msg] Info diff --git a/lib/Proteome/Data/AddItem.hs b/lib/Proteome/Data/AddItem.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/AddItem.hs @@ -0,0 +1,8 @@ +module Proteome.Data.AddItem where + +data AddItem = + AddItem { + projectType :: Text, + projectName :: Text + } + deriving stock (Eq, Show, Ord) 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 @@ -1,38 +1,15 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} +module Proteome.Data.AddOptions where -module Proteome.Data.AddOptions( - AddOptions(..), -) where +import Ribosome (MsgpackDecode, MsgpackEncode) -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, extractObjectOr) -import Proteome.Data.Project (ProjectName, ProjectType) +import Proteome.Data.ProjectName (ProjectName) +import Proteome.Data.ProjectType (ProjectType) data AddOptions = AddOptions { name :: ProjectName, tpe :: ProjectType, - activate :: Bool + activate :: Maybe Bool } - deriving (Eq, Show, Generic, NFData) - -instance NvimObject AddOptions where - toObject AddOptions {..} = - (toObject :: Dictionary -> Object) . Map.fromList $ - [ - ("name", toObject name), - ("tpe", toObject tpe), - ("activate", toObject activate) - ] - fromObject (ObjectMap o) = do - name' <- extractObject "name" o - tpe' <- extractObject "tpe" o - return $ AddOptions name' tpe' (extractObjectOr "activate" False o) - fromObject o = Left ("invalid type for AddOptions: " <+> viaShow o) + deriving stock (Eq, Show, Generic) + deriving anyclass (MsgpackDecode, MsgpackEncode) diff --git a/lib/Proteome/Data/CurrentTag.hs b/lib/Proteome/Data/CurrentTag.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/CurrentTag.hs @@ -0,0 +1,24 @@ +module Proteome.Data.CurrentTag where + +import qualified Data.List.NonEmpty.Zipper as Zipper +import Data.List.NonEmpty.Zipper (Zipper) +import Path (Abs, File, Path) + +import Proteome.Tags.State (TagLoc) + +data CurrentTag = + CurrentTag { + name :: Text, + locations :: Zipper (TagLoc (Path Abs File)) + } + deriving stock (Eq, Show, Generic) + +pattern CurrentLoc :: TagLoc (Path Abs File) -> CurrentTag +pattern CurrentLoc loc <- (Zipper.current . locations -> loc) +{-# complete CurrentLoc #-} + +cycleLoc :: + Zipper (TagLoc (Path Abs File)) -> + Zipper (TagLoc (Path Abs File)) +cycleLoc locs = + fromMaybe (Zipper.start locs) (Zipper.right locs) diff --git a/lib/Proteome/Data/Env.hs b/lib/Proteome/Data/Env.hs --- a/lib/Proteome/Data/Env.hs +++ b/lib/Proteome/Data/Env.hs @@ -1,30 +1,28 @@ -{-# LANGUAGE TemplateHaskell #-} +module Proteome.Data.Env where -module Proteome.Data.Env ( - Env(..), - _mainProject, - _projects, - _errors, - _currentProjectIndex, - _configLog, -) where +import Ribosome (Buffer) -import Control.Lens (makeClassy_) -import Data.Default.Class (Default(def)) -import Ribosome.Data.Errors (Errors) import Proteome.Data.Project(Project) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject, VirtualProject)) +import Proteome.Data.ProjectType (ProjectType) +import Proteome.Data.Replace (Replace) data Env = Env { mainProject :: Project, projects :: [Project], - errors :: Errors, currentProjectIndex :: Int, - configLog :: [FilePath] + configLog :: [Text], + buffers :: [Buffer], + replace :: Maybe Replace } - deriving Show - -makeClassy_ ''Env + deriving stock (Show, Generic) + deriving anyclass (Default) -instance Default Env where - def = Env def def def def def +mainType :: Env -> Maybe ProjectType +mainType env = + case env ^. (#mainProject . #meta) of + DirProject _ _ tpe -> + tpe + VirtualProject _ -> + Nothing diff --git a/lib/Proteome/Data/FileScanItem.hs b/lib/Proteome/Data/FileScanItem.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/FileScanItem.hs @@ -0,0 +1,11 @@ +module Proteome.Data.FileScanItem where + +import Path (Abs, Dir, File, Path) + +data FileScanItem = + FileScanItem { + _base :: Path Abs Dir, + _baseIndicator :: Maybe Text, + _path :: Path Abs File + } + deriving stock (Eq, Show) diff --git a/lib/Proteome/Data/FilenameError.hs b/lib/Proteome/Data/FilenameError.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/FilenameError.hs @@ -0,0 +1,38 @@ +module Proteome.Data.FilenameError where + +import Exon (exon) +import Log (Severity (Error, Warn)) +import Ribosome (Report (Report), Reportable (toReport)) + +data FilenameError = + BadCwd + | + InvalidPathSpec Text + | + BufferPathInvalid + | + CreateDir Text + | + Exists Text + | + ActionFailed Text Text + | + Remove Text + deriving stock (Eq, Show, Generic) + +instance Reportable FilenameError where + toReport = \case + BadCwd -> + Report "Could not determine current directory" ["FilenameError.BadCwd"] Error + InvalidPathSpec spec -> + Report [exon|Invalid path: #{spec}|] ["FilenameError.InvalidPathSpec:", spec] Warn + BufferPathInvalid -> + Report "Current buffer is not an existing file" ["FilenameError.BufferPathInvalid"] Warn + CreateDir dir -> + Report [exon|Could not create directory #{dir}|] ["FilenameError.CreateDir:", dir] Warn + Exists file -> + Report [exon|File already exists: #{file}|] ["FilenameError.Exists:", file] Warn + ActionFailed action err -> + Report "File system error" ["FilenameError.ActionFailed:", action, err] Warn + Remove err -> + Report "Couldn't remove the source file" ["FilenameError.Remove:", err] Warn diff --git a/lib/Proteome/Data/FilesConfig.hs b/lib/Proteome/Data/FilesConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/FilesConfig.hs @@ -0,0 +1,13 @@ +module Proteome.Data.FilesConfig where + +import Text.Regex.PCRE.Light (Regex) + +data FilesConfig = + FilesConfig { + useRg :: Bool, + ignoreHidden :: Bool, + ignoreFiles :: [Regex], + ignoreDirs :: [Regex], + wildignore :: [Text] + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Proteome/Data/FilesError.hs b/lib/Proteome/Data/FilesError.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/FilesError.hs @@ -0,0 +1,28 @@ +module Proteome.Data.FilesError where + +import Log (Severity (Error, Warn)) +import Ribosome (Report (Report), Reportable (toReport)) + +data FilesError = + BadCwd + | + NoSuchPath Text + | + BadRegex Text Text + | + InvalidFilePath Text + | + CouldntCreateDir Text + deriving stock (Eq, Show) + +instance Reportable FilesError where + toReport BadCwd = + Report "internal error" ["FilesError.BadCwd"] Error + toReport (NoSuchPath path) = + Report ("path doesn't exist: " <> path) ["FilesError.NoSuchPath:", path] Warn + toReport (BadRegex var re) = + Report ("bad regex in `g:proteome_" <> var <> "`: " <> re) ["FilesError.BadRegex:", var, re] Warn + toReport (InvalidFilePath path) = + Report ("invalid file path: " <> path) ["FilesError.InvalidFilePath:", path] Warn + toReport (CouldntCreateDir path) = + Report ("couldn't create directory: " <> path) ["FilesError.CouldntCreateDir:", path] Warn diff --git a/lib/Proteome/Data/FilesState.hs b/lib/Proteome/Data/FilesState.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/FilesState.hs @@ -0,0 +1,76 @@ +module Proteome.Data.FilesState where + +import Path (Abs, File, Path, filename, parent) +import Ribosome (pathText) +import Ribosome.Menu (Filter, MenuItem (MenuItem), Modal) +import qualified Ribosome.Menu.MenuState as MenuState +import Ribosome.Menu.MenuState (FilterMode (FilterMode), MenuMode (cycleFilter, renderFilter)) +import Exon (exon) + +data FileSegments = + FileSegments { + path :: Path Abs File, + name :: Text, + dir :: Text + } + deriving stock (Eq, Show, Generic) + +fileSegments :: Path Abs File -> FileSegments +fileSegments path = + FileSegments { + name = pathText (filename path), + dir = pathText (parent path), + .. + } + +data Segment = + Full + | + Name + | + Dir + deriving stock (Eq, Show, Ord) + +renderSegment :: Segment -> Text +renderSegment = \case + Full -> "full" + Name -> "name" + Dir -> "dir" + +segmentExtract :: MenuItem FileSegments -> Segment -> Text +segmentExtract (MenuItem FileSegments {..} _ render) = \case + Full -> render + Name -> name + Dir -> dir + +cycle :: Segment -> Segment +cycle = \case + Full -> Name + Name -> Dir + Dir -> Full + +data FilesMode = + FilesMode { + mode :: Filter, + segment :: Segment + } + deriving stock (Eq, Show, Ord, Generic) + +type FilesState = + Modal FilesMode FileSegments + +instance MenuMode FileSegments FilesMode where + type Filter FilesMode = + FilterMode Filter + + cycleFilter (FilesMode mode segment) = + FilesMode (cycleFilter mode) segment + + renderFilter (FilesMode mode _) = + renderFilter mode + + renderExtra (FilesMode _ segment) = + Just [exon|🔧 #{renderSegment segment}|] + + filterMode (FilesMode mode segment) = + FilterMode mode (Just . flip segmentExtract segment) diff --git a/lib/Proteome/Data/GrepError.hs b/lib/Proteome/Data/GrepError.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/GrepError.hs @@ -0,0 +1,31 @@ +module Proteome.Data.GrepError where + +import Exon (exon) +import Log (Severity (Warn)) +import Path (Abs, Dir, Path) +import Ribosome (Report (Report), Reportable (toReport), pathText) + +data GrepError = + Empty + | + NotInPath Text + | + NoSuchExecutable Text + | + NoSuchDestination (Path Abs Dir) + | + EmptyUserInput Text + deriving stock (Eq, Show) + +instance Reportable GrepError where + toReport = \case + Empty -> + Report "grep cmdline is empty" ["GrepError.Empty"] Warn + NotInPath exe -> + Report ("grep executable `" <> exe <> "` not found in $PATH") ["GrepError.NotInPath:", exe] Warn + NoSuchExecutable exe -> + Report ("grep executable `" <> exe <> "` does not exist") ["GrepError.NoSuchExecutable:", exe] Warn + NoSuchDestination (pathText -> dir) -> + Report [exon|grep destination `#{dir}` does not exist|] ["GrepError.NoSuchDestination:", dir] Warn + EmptyUserInput what -> + Report [exon|no #{what} given|] ["GrepError.EmptyPattern"] Warn diff --git a/lib/Proteome/Data/GrepOutputLine.hs b/lib/Proteome/Data/GrepOutputLine.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/GrepOutputLine.hs @@ -0,0 +1,18 @@ +module Proteome.Data.GrepOutputLine where + +import Path (Abs, File, Path) +import Ribosome (MsgpackEncode) + +data GrepOutputLine = + GrepOutputLine { + path :: Path Abs File, + line :: Int, + col :: Maybe Int, + content :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (MsgpackEncode) + +sameLine :: GrepOutputLine -> GrepOutputLine -> Bool +sameLine (GrepOutputLine p1 l1 _ _) (GrepOutputLine p2 l2 _ _) = + p1 == p2 && l1 == l2 diff --git a/lib/Proteome/Data/ListedBuffer.hs b/lib/Proteome/Data/ListedBuffer.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ListedBuffer.hs @@ -0,0 +1,11 @@ +module Proteome.Data.ListedBuffer where + +import Ribosome.Host.Api.Data (Buffer) + +data ListedBuffer = + ListedBuffer { + buffer :: Buffer, + number :: Int, + name :: Text + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Proteome/Data/PersistBuffers.hs b/lib/Proteome/Data/PersistBuffers.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/PersistBuffers.hs @@ -0,0 +1,11 @@ +module Proteome.Data.PersistBuffers where + +import Path (Abs, File, Path) + +data PersistBuffers = + PersistBuffers { + current :: Maybe (Path Abs File), + buffers :: [Path Abs File] + } + deriving stock (Eq, Generic, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/lib/Proteome/Data/Project.hs b/lib/Proteome/Data/Project.hs --- a/lib/Proteome/Data/Project.hs +++ b/lib/Proteome/Data/Project.hs @@ -1,74 +1,10 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} - -module Proteome.Data.Project( - ProjectMetadata (..), - Project (..), - ProjectType (..), - ProjectLang (..), - ProjectRoot (..), - ProjectName (..), - _meta, - _lang, - langOrType, -) where - -import GHC.Generics (Generic) -import Control.Lens (makeClassy_) -import Control.DeepSeq (NFData) -import Data.Default.Class (Default(def)) -import Neovim.Classes (NvimObject(..)) -import Ribosome.Internal.NvimObject (deriveString) - -newtype ProjectName = ProjectName String - deriving (Eq, Show, Generic, NFData) - -instance NvimObject ProjectName where - toObject (ProjectName s) = toObject s - fromObject = deriveString ProjectName - -newtype ProjectType = - ProjectType { - projectType :: String - } - deriving (Ord, Eq, Show, Generic, NFData) - -instance NvimObject ProjectType where - toObject (ProjectType s) = toObject s - fromObject = deriveString ProjectType - -newtype ProjectLang = - ProjectLang - { - projectLang :: String - } - deriving (Ord, Eq, Show, Generic, NFData) - -instance NvimObject ProjectLang where - toObject (ProjectLang s) = toObject s - fromObject = deriveString ProjectLang - -newtype ProjectRoot = ProjectRoot FilePath - deriving (Eq, Show, Generic, NFData) - -instance NvimObject ProjectRoot where - toObject (ProjectRoot s) = toObject s - fromObject = deriveString ProjectRoot +module Proteome.Data.Project where -data ProjectMetadata = - DirProject { - name :: ProjectName, - root :: ProjectRoot, - tpe :: Maybe ProjectType - } - | VirtualProject { - name :: ProjectName - } - deriving (Eq, Show) +import Ribosome (MsgpackDecode, MsgpackEncode) -instance Default ProjectMetadata where - def = VirtualProject (ProjectName "main") +import Proteome.Data.ProjectLang (ProjectLang (ProjectLang)) +import Proteome.Data.ProjectMetadata (ProjectMetadata) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) data Project = Project { @@ -77,12 +13,12 @@ lang :: Maybe ProjectLang, langs :: [ProjectLang] } - deriving (Eq, Show) - -makeClassy_ ''Project + deriving stock (Eq, Show, Generic) + deriving anyclass (MsgpackDecode, MsgpackEncode) instance Default Project where - def = Project def def def def + def = + Project def def def def langOrType :: Maybe ProjectLang -> Maybe ProjectType -> Maybe ProjectLang langOrType (Just lang') _ = Just lang' diff --git a/lib/Proteome/Data/ProjectConfig.hs b/lib/Proteome/Data/ProjectConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ProjectConfig.hs @@ -0,0 +1,20 @@ +module Proteome.Data.ProjectConfig where + +import Path (Abs, Dir, Path) +import Ribosome (MsgpackDecode, MsgpackEncode) + +import Proteome.Data.ProjectLang (ProjectLang) +import Proteome.Data.ProjectType (ProjectType) + +data ProjectConfig = + ProjectConfig { + baseDirs :: [Path Abs Dir], + typeDirs :: Map ProjectType [Path Abs Dir], + projectTypes :: Map ProjectType [Path Abs Dir], + typeMap :: Map ProjectType [ProjectType], + typeMarkers :: Map ProjectType [Text], + langMap :: Map ProjectType ProjectLang, + langsMap :: Map ProjectLang [ProjectLang] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (MsgpackDecode, MsgpackEncode, Default) diff --git a/lib/Proteome/Data/ProjectLang.hs b/lib/Proteome/Data/ProjectLang.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ProjectLang.hs @@ -0,0 +1,8 @@ +module Proteome.Data.ProjectLang where + +import Ribosome (MsgpackDecode, MsgpackEncode) + +newtype ProjectLang = + ProjectLang { unProjectLang :: Text } + deriving stock (Ord, Eq, Show, Generic) + deriving newtype (MsgpackEncode, MsgpackDecode, IsString) diff --git a/lib/Proteome/Data/ProjectMetadata.hs b/lib/Proteome/Data/ProjectMetadata.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ProjectMetadata.hs @@ -0,0 +1,24 @@ +module Proteome.Data.ProjectMetadata where + +import Ribosome (MsgpackDecode, MsgpackEncode) + +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectRoot (ProjectRoot) +import Proteome.Data.ProjectType (ProjectType) + +data ProjectMetadata = + DirProject { + name :: ProjectName, + root :: ProjectRoot, + tpe :: Maybe ProjectType + } + | + VirtualProject { + name :: ProjectName + } + deriving stock (Eq, Show, Generic) + deriving anyclass (MsgpackDecode, MsgpackEncode) + +instance Default ProjectMetadata where + def = + VirtualProject (ProjectName "main") diff --git a/lib/Proteome/Data/ProjectName.hs b/lib/Proteome/Data/ProjectName.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ProjectName.hs @@ -0,0 +1,8 @@ +module Proteome.Data.ProjectName where + +import Ribosome (MsgpackDecode, MsgpackEncode) + +newtype ProjectName = + ProjectName { unProjectName :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (MsgpackEncode, MsgpackDecode, IsString) diff --git a/lib/Proteome/Data/ProjectRoot.hs b/lib/Proteome/Data/ProjectRoot.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ProjectRoot.hs @@ -0,0 +1,9 @@ +module Proteome.Data.ProjectRoot where + +import Path (Abs, Dir, Path) +import Ribosome (MsgpackDecode, MsgpackEncode) + +newtype ProjectRoot = + ProjectRoot { unProjectRoot :: Path Abs Dir } + deriving stock (Eq, Show, Generic) + deriving newtype (MsgpackDecode, MsgpackEncode) diff --git a/lib/Proteome/Data/ProjectSpec.hs b/lib/Proteome/Data/ProjectSpec.hs --- a/lib/Proteome/Data/ProjectSpec.hs +++ b/lib/Proteome/Data/ProjectSpec.hs @@ -1,19 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE RecordWildCards #-} +module Proteome.Data.ProjectSpec where -module Proteome.Data.ProjectSpec( - ProjectSpec (..), -) where +import Ribosome (MsgpackDecode, MsgpackEncode) -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import qualified Data.Map as Map (fromList) -import Data.Maybe (catMaybes) -import Data.MessagePack -import Neovim.Classes (NvimObject(..), Dictionary) -import Proteome.Data.Project (ProjectName, ProjectType, ProjectLang, ProjectRoot) +import Proteome.Data.ProjectLang (ProjectLang) +import Proteome.Data.ProjectName (ProjectName) +import Proteome.Data.ProjectRoot (ProjectRoot) +import Proteome.Data.ProjectType (ProjectType) data ProjectSpec = ProjectSpec { @@ -24,18 +16,5 @@ lang :: Maybe ProjectLang, langs :: [ProjectLang] } - deriving (Generic, NFData) - -instance NvimObject ProjectSpec where - toObject ProjectSpec {..} = - (toObject :: Dictionary -> Object) . Map.fromList $ - [ - ("name", toObject name), - ("root", toObject root), - ("types", toObject types), - ("langs", toObject langs) - ] ++ catMaybes - [ - tpe >>= \a -> return ("tpe", toObject a), - lang >>= \a -> return ("lang", toObject a) - ] + deriving stock (Eq, Show, Generic) + deriving anyclass (MsgpackDecode, MsgpackEncode) diff --git a/lib/Proteome/Data/ProjectType.hs b/lib/Proteome/Data/ProjectType.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ProjectType.hs @@ -0,0 +1,8 @@ +module Proteome.Data.ProjectType where + +import Ribosome (MsgpackDecode, MsgpackEncode) + +newtype ProjectType = + ProjectType { unProjectType :: Text } + deriving stock (Ord, Eq, Show, Generic) + deriving newtype (MsgpackDecode, MsgpackEncode, IsString) diff --git a/lib/Proteome/Data/Proteome.hs b/lib/Proteome/Data/Proteome.hs deleted file mode 100644 --- a/lib/Proteome/Data/Proteome.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Proteome.Data.Proteome( - Proteome -) where - -import UnliftIO.STM (TVar) -import Ribosome.Control.Ribo (Ribo) -import Proteome.Data.Env (Env) - -type Proteome a = Ribo (TVar Env) a diff --git a/lib/Proteome/Data/Replace.hs b/lib/Proteome/Data/Replace.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/Replace.hs @@ -0,0 +1,13 @@ +module Proteome.Data.Replace where + +import Prelude hiding (lines) +import Ribosome (ScratchState) + +import Proteome.Data.GrepOutputLine (GrepOutputLine) + +data Replace = + Replace { + scratch :: ScratchState, + lines :: NonEmpty GrepOutputLine + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Proteome/Data/ReplaceError.hs b/lib/Proteome/Data/ReplaceError.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ReplaceError.hs @@ -0,0 +1,18 @@ +module Proteome.Data.ReplaceError where + +import Log (Severity (Error, Warn)) +import Path (Abs, File, Path) +import Ribosome (Report (Report), Reportable, toReport) +import Ribosome (pathText) + +data ReplaceError = + BadReplacement + | + CouldntLoadBuffer (Path Abs File) + deriving stock (Eq, Show) + +instance Reportable ReplaceError where + toReport BadReplacement = + Report "replacment line count does not match original" ["ReplaceError.BadReplacement"] Warn + toReport (CouldntLoadBuffer (pathText -> path)) = + Report ("could not load file " <> path) ["ReplaceError.CouldntLoadBuffer", path] Error diff --git a/lib/Proteome/Data/ResolveError.hs b/lib/Proteome/Data/ResolveError.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/ResolveError.hs @@ -0,0 +1,13 @@ +module Proteome.Data.ResolveError where + +import Exon (exon) +import Log (Severity (Warn)) +import Ribosome (Report (Report), Reportable (toReport)) + +newtype ResolveError = + ParsePath Text + deriving stock (Eq, Show) + +instance Reportable ResolveError where + toReport (ParsePath path) = + Report [exon|invalid path: #{path}|] ["ResolveError.ParsePath:", path] Warn diff --git a/lib/Proteome/Data/TagsError.hs b/lib/Proteome/Data/TagsError.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/TagsError.hs @@ -0,0 +1,26 @@ +module Proteome.Data.TagsError where + +import Exon (exon) +import Log (Severity (Warn)) +import Ribosome (Report (Report), Reportable (toReport), SettingError, reportMessages) + +data TagsError = + Process Text + | + TempName + | + RenameTags Text + | + Setting SettingError + deriving stock (Eq, Show) + +instance Reportable TagsError where + toReport = \case + Process msg -> + Report "tags process failed" ["TagsError.Process", msg] Warn + TempName -> + Report "failed to create temp dir for tags process" ["TagsError.TempName"] Warn + RenameTags msg -> + Report "Failed to rename temporary tags file" ["TagsError.RenameTags", msg] Warn + Setting e -> + Report [exon|tags failed: #{reportMessages (toReport e)}|] ["TagsError.Setting:", show e] Warn diff --git a/lib/Proteome/Data/TagsParams.hs b/lib/Proteome/Data/TagsParams.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Data/TagsParams.hs @@ -0,0 +1,11 @@ +module Proteome.Data.TagsParams where + +import Proteome.Data.ProjectLang (ProjectLang) +import Proteome.Data.ProjectRoot (ProjectRoot) + +data TagsParams = + TagsParams { + root :: ProjectRoot, + langs :: [ProjectLang] + } + deriving stock (Eq, Show) diff --git a/lib/Proteome/Diag.hs b/lib/Proteome/Diag.hs --- a/lib/Proteome/Diag.hs +++ b/lib/Proteome/Diag.hs @@ -1,96 +1,141 @@ -module Proteome.Diag( - proDiag, -) where +module Proteome.Diag where -import Data.Functor (void) -import Data.List (intercalate) -import Data.Map (foldMapWithKey) -import Neovim (CommandArguments) -import Ribosome.Data.ScratchOptions (defaultScratchOptions) -import Ribosome.Data.Errors (Error(Error), Errors(Errors), ComponentName(ComponentName)) -import Ribosome.Scratch (showInScratch) -import qualified Ribosome.Control.Ribo as Ribo (inspect) -import Proteome.Env (getMainProject) -import qualified Proteome.Data.Env as Env (configLog, projects, errors) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project ( - Project (Project), - ProjectLang(..), - ProjectRoot(ProjectRoot), - ProjectName(ProjectName), - ProjectType(..), - ProjectMetadata (DirProject, VirtualProject), +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Exon (exon) +import Path (toFilePath) +import Prettyprinter (Doc, line, nest, pretty, vsep) +import Ribosome ( + Handler, + Report (Report), + ReportContext, + Reports, + RpcError, + Scratch, + ScratchId (ScratchId), + Settings, + StoredReport (StoredReport), + reportContext, + resumeReport, + scratch, + storedReports, ) -import Proteome.Tags (tagsCommand) +import qualified Ribosome.Scratch as Scratch +import Ribosome.Scratch (ScratchOptions (filetype, focus)) -formatLang :: Maybe ProjectLang -> String +import qualified Proteome.Data.Env as Env +import Proteome.Data.Env (Env) +import Proteome.Data.Project (Project (Project)) +import Proteome.Data.ProjectLang (ProjectLang (ProjectLang, unProjectLang)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject, VirtualProject)) +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot)) +import Proteome.Data.ProjectType (ProjectType (ProjectType, unProjectType)) +import Proteome.Tags.Gen (tagsCommand) + +formatLang :: Maybe ProjectLang -> Text formatLang (Just (ProjectLang lang)) = lang formatLang Nothing = "none" -formatType :: Maybe ProjectType -> String +formatType :: Maybe ProjectType -> Text formatType (Just (ProjectType tpe)) = tpe formatType Nothing = "none" -formatMeta :: ProjectMetadata -> [ProjectLang] -> Proteome [String] -formatMeta (VirtualProject (ProjectName name)) _ = return ["name: " ++ name] -formatMeta (DirProject (ProjectName name) r@(ProjectRoot root) tpe) langs = do - (tagsCmd, tagsArgs) <- tagsCommand r langs - return [ - "name: " ++ name, - "root: " ++ root, - "type: " ++ formatType tpe, - "tags cmd: " ++ tagsCmd ++ " " ++ tagsArgs - ] +formatProject :: ProjectName -> ProjectRoot -> Maybe ProjectType -> [Text] +formatProject (ProjectName name) (ProjectRoot root) tpe = + [ + "name: " <> name, + "root: " <> (toText . toFilePath) root, + "type: " <> formatType tpe + ] -formatMain :: Project -> Proteome [String] +formatMeta :: + Member (Settings !! se) r => + ProjectMetadata -> + [ProjectLang] -> + Sem r [Text] +formatMeta (VirtualProject (ProjectName name)) _ = + pure ["name: " <> name] +formatMeta (DirProject name root tpe) langs = do + tags :: [Text] <- resumeAs [] do + runStop (tagsCommand root langs) >>= \case + Right (tagsCmd, tagsArgs) -> + pure [[exon|tags cmd: #{tagsCmd} #{tagsArgs}|]] + Left _ -> + pure [] + pure (formatProject name root tpe <> tags) + +formatMain :: + Member (Settings !! se) r => + Project -> + Sem r [Text] formatMain (Project meta types lang langs) = do metaContent <- formatMeta meta langs - return $ metaContent ++ [ - "types: " ++ intercalate ", " (fmap projectType types), - "main language: " ++ formatLang lang, - "languages: " ++ intercalate ", " (fmap projectLang langs) + pure $ metaContent <> [ + "types: " <> Text.intercalate ", " (unProjectType <$> types), + "main language: " <> formatLang lang, + "languages: " <> Text.intercalate ", " (unProjectLang <$> langs) ] -formatExtraProjects :: [Project] -> Proteome [String] +formatExtraProjects :: + Member (Settings !! se) r => + [Project] -> + Sem r [Text] formatExtraProjects projects = do formatted <- traverse formatMain projects - return $ ["", "Extra projects", ""] ++ intercalate [""] formatted + pure $ ["", "Extra projects", ""] <> intercalate [""] formatted -formatExtraProjectsIfNonempty :: Proteome [String] +formatExtraProjectsIfNonempty :: + Members [Settings !! se, AtomicState Env] r => + Sem r [Text] formatExtraProjectsIfNonempty = do - projects <- Ribo.inspect Env.projects + projects <- atomicGets Env.projects case projects of _ : _ -> formatExtraProjects projects - _ -> return [] - -formatError :: Error -> [String] -formatError (Error stamp (first:message)) = (show stamp ++ " | " ++ first) : message -formatError _ = [] + _ -> pure [] -formatComponentErrors :: ComponentName -> [Error] -> [String] -formatComponentErrors (ComponentName name) errors@(_ : _) = - [name ++ "", ""] ++ (errors >>= formatError) -formatComponentErrors _ _ = [] +storedError :: StoredReport -> Doc a +storedError (StoredReport (Report _ log _) _) = + case log of + [] -> mempty + (h : t) -> + nest 2 (vsep (pretty <$> ([exon|* #{h}|] : t))) +tagErrors :: ReportContext -> [StoredReport] -> Doc a +tagErrors ctx errs = + pretty [exon|### #{reportContext ctx}|] <> line <> vsep (storedError <$> errs) -formatErrorLog :: Errors -> [String] -formatErrorLog (Errors errors) = - case compErrors of - _ : _ -> ["", "Errors", ""] ++ compErrors - _ -> [] - where - compErrors = foldMapWithKey formatComponentErrors errors +errorDiagnostics :: Map ReportContext [StoredReport] -> Doc a +errorDiagnostics errs | null errs = + mempty +errorDiagnostics errs = + "## Reports" <> line <> line <> vsep (uncurry tagErrors <$> Map.toAscList errs) -diagnostics :: Proteome [String] +diagnostics :: + Members [Settings !! se, AtomicState Env, Reports] r => + Sem r [Text] diagnostics = do - main <- getMainProject >>= formatMain + main <- formatMain =<< atomicGets Env.mainProject extra <- formatExtraProjectsIfNonempty - confLog <- Ribo.inspect Env.configLog - errors <- Ribo.inspect Env.errors - return $ ["Diagnostics", "", "Main project", ""] ++ main ++ extra ++ ["", "loaded config files:"] ++ - confLog ++ formatErrorLog errors + confLog <- atomicGets Env.configLog + errors <- errorDiagnostics <$> storedReports + pure $ header <> main <> extra <> ["", "loaded config files:"] <> confLog <> Text.lines (show errors) + where + header = + ["Diagnostics", "", "Main project", ""] -proDiag :: CommandArguments -> Proteome () -proDiag _ = do - content <- diagnostics - void $ showInScratch content (defaultScratchOptions "proteome-diagnostics") +proDiag :: + Members [Settings !! se, Scratch !! RpcError, AtomicState Env, Reports] r => + Handler r () +proDiag = do + resumeReport @Scratch do + content <- diagnostics + void $ Scratch.show content options + where + options = + (scratch (ScratchId name)) { + focus = True, + filetype = Just name + } + name = + "proteome-diagnostics" diff --git a/lib/Proteome/Env.hs b/lib/Proteome/Env.hs deleted file mode 100644 --- a/lib/Proteome/Env.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Proteome.Env( - getMainProject, -) where - -import qualified Ribosome.Control.Ribo as Ribo (inspect) -import qualified Proteome.Data.Env as Env (mainProject) -import Proteome.Data.Project(Project) -import Proteome.Data.Proteome (Proteome) - -getMainProject :: Proteome Project -getMainProject = - Ribo.inspect Env.mainProject diff --git a/lib/Proteome/Filename.hs b/lib/Proteome/Filename.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Filename.hs @@ -0,0 +1,417 @@ +module Proteome.Filename where + +import qualified Chronos +import qualified Data.Text as Text +import Exon (exon) +import Path ( + Abs, + Dir, + File, + Path, + Rel, + addExtension, + dirname, + filename, + parent, + parseRelDir, + reldir, + relfile, + splitExtension, + (), + ) +import Path.IO (copyFile, doesDirExist, doesFileExist, ensureDir, removeFile) +import Ribosome ( + Bang (Bang), + Handler, + LogReport, + Rpc, + RpcError, + logReport, + mapReport, + pathText, + resumeReport, + rpcError, + ) +import Ribosome.Api (bufferSetName, vimCallFunction, vimCommand, vimGetCurrentBuffer, wipeBuffer) +import Ribosome.Api.Buffer (currentBufferName, edit) +import Ribosome.Api.Path (nvimCwd) +import Ribosome.Data.PersistPathError (PersistPathError) +import Ribosome.Host.Modify (silent) +import Ribosome.Persist (PersistPath, persistPath) + +import qualified Proteome.Data.FilenameError as FilenameError +import Proteome.Data.FilenameError (FilenameError) +import Proteome.Path ( + absoluteParse, + absoluteParseDir, + parseAbsDirMaybe, + parseAbsFileMaybe, + parseRelDirMaybe, + parseRelFileMaybe, + ) + +data BufPath = + BufPath (Path Abs File) [Text] + deriving stock (Eq, Show) + +bufDir :: BufPath -> Path Abs Dir +bufDir (BufPath f _) = + parent f + +data NameSpec = + Star (Path Rel File) + | + Literal (Path Rel File) + deriving stock (Eq, Show) + +rawNameSpec :: + NameSpec -> + Path Rel File +rawNameSpec = \case + Star f -> f + Literal f -> f + +data Modification = + Filename (Path Rel File) (Path Rel Dir) NameSpec [Text] + | + Dir (Path Abs Dir) + | + File (Path Abs File) + | + Container Int (Path Rel Dir) + deriving stock (Eq, Show) + +nameSpec :: Path Rel File -> NameSpec +nameSpec p = + if p == [relfile|*|] then Star p else Literal p + +dotsInPath :: Text -> Int +dotsInPath path = + Text.length (Text.filter (== '.') (Text.drop 1 path)) + +absoluteDir :: Text -> Maybe Modification +absoluteDir = + fmap Dir . parseAbsDirMaybe + +absoluteFile :: Text -> Maybe Modification +absoluteFile = + fmap File . parseAbsFileMaybe + +relativeDir :: Path Abs Dir -> Text -> Maybe Modification +relativeDir cwd spec = do + rel <- parseRelDirMaybe spec + pure (Dir (cwd rel)) + +relativeFile :: Path Abs Dir -> Text -> Maybe Modification +relativeFile cwd spec = do + rel <- parseRelFileMaybe spec + pure (File (cwd rel)) + +splitExtensions :: Path b File -> (Path b File, [Text]) +splitExtensions = + spin [] + where + spin exts f = + case splitExtension f of + Just (f', e) -> spin (toText e : exts) f' + Nothing -> (f, exts) + +addExtensions :: + Path b File -> + [Text] -> + Maybe (Path b File) +addExtensions name exts = + foldlM (flip addExtension) name (toString <$> exts) + +nameOnly :: Text -> Maybe Modification +nameOnly spec = do + rel <- parseRelFileMaybe spec + let (name, exts) = splitExtensions (filename rel) + Just (Filename rel (parent rel) (nameSpec name) exts) + +maybeDir :: + Member (Embed IO) r => + Path Abs Dir -> + Text -> + Sem r Bool +maybeDir cwd spec = + fromMaybe False <$> traverse doesDirExist (absoluteParseDir cwd spec) + +regularModification :: + Members [Stop FilenameError, Embed IO] r => + Path Abs Dir -> + Text -> + Sem r Modification +regularModification cwd spec = do + existingDir <- maybeDir cwd spec + stopNote (FilenameError.InvalidPathSpec spec) (cons existingDir spec) + where + cons existingDir + | name = nameOnly + | absolute = if explicitDir || existingDir then absoluteDir else absoluteFile + | explicitDir = relativeDir cwd + | otherwise = relativeFile cwd + name = + not (Text.any ('/' ==) spec) + absolute = + Text.take 1 spec == "/" + explicitDir = + Text.takeEnd 1 spec == "/" + +directorySelector :: Text -> (Int, Text) +directorySelector = + first Text.length . Text.span ('^' ==) + +modification :: + Members [Stop FilenameError, Embed IO] r => + Bool -> + Path Abs Dir -> + Text -> + Sem r Modification +modification raw cwd (Text.strip -> spec) = + case directorySelector spec of + (n, _) | n == 0 || raw -> + regularModification cwd spec + (n, name) -> do + dir <- stopNote (FilenameError.InvalidPathSpec name) (parseRelDir (toString name)) + pure (Container n dir) + +checkBufferPath :: + Members [Rpc, Stop FilenameError, Embed IO] r => + Path Abs Dir -> + Sem r (Path Abs File) +checkBufferPath cwd = do + name <- currentBufferName + path <- stopNote FilenameError.BufferPathInvalid (absoluteParse cwd name) + ifM (doesFileExist path) (pure path) (stop FilenameError.BufferPathInvalid) + +withExtension :: + BufPath -> + [Text] -> + NameSpec -> + Maybe (Path Rel File) +withExtension (BufPath bufName bufExts) exts = \case + Star _ -> + addExtensions (filename bufName) (take (length bufExts - length exts) bufExts ++ exts) + Literal name -> + addExtensions name (exts ++ drop (length exts) bufExts) + +renameInplace :: + Member (Stop FilenameError) r => + Bool -> + Path Rel File -> + BufPath -> + Path Rel Dir -> + NameSpec -> + [Text] -> + Sem r (Path Abs File) +renameInplace raw spec bufPath destDir newName exts = do + rel <- + if raw + then pure (destDir spec) + else stopNote FilenameError.BufferPathInvalid (withExtension bufPath exts newName) + pure (bufDir bufPath rel) + +replaceDir :: + Member (Stop FilenameError) r => + Int -> + Path Rel Dir -> + Path Abs File -> + Sem r (Path Abs File) +replaceDir index name file = do + dir <- spin (parent file) index + pure (dir filename file) + where + spin d _ | parent d == d = + stop (FilenameError.InvalidPathSpec "not enough directory segments in buffer path") + spin d i | i <= 1 = + pure (parent d name) + spin d i = do + sub <- spin (parent d) (i - 1) + pure (sub dirname d) + +assemblePath :: + Member (Stop FilenameError) r => + Bool -> + Path Abs File -> + Modification -> + Sem r (Path Abs File) +assemblePath raw bufPath = \case + Filename rawSpec destDir newName exts -> + renameInplace raw rawSpec (uncurry BufPath (splitExtensions bufPath)) destDir newName exts + Dir dir -> + pure (dir filename bufPath) + File file -> + pure file + Container index name -> + replaceDir index name bufPath + +ensureDestinationEmpty :: + Members [Stop FilenameError, Embed IO] r => + Path Abs File -> + Sem r () +ensureDestinationEmpty path = + whenM (doesFileExist path) (stop (FilenameError.Exists (pathText path))) + +prepareDestination :: + Members [Stop FilenameError, Embed IO] r => + Path Abs File -> + Sem r () +prepareDestination path = + ifM exists (ensureDestinationEmpty path) create + where + exists = + doesDirExist dir + create = + stopTryAny (const (FilenameError.CreateDir (pathText dir))) (ensureDir dir) + dir = + parent path + +getCwd :: + Members [Stop FilenameError, Rpc !! RpcError] r => + Sem r (Path Abs Dir) +getCwd = + resumeHoistAs FilenameError.BadCwd nvimCwd + +smartModification :: + Members [Stop FilenameError, Rpc !! RpcError, Embed IO] r => + Bool -> + Text -> + Sem r Modification +smartModification raw spec = do + cwd <- getCwd + modification raw cwd spec + +trashModification :: + Members [Stop FilenameError, Rpc, Rpc !! RpcError, PersistPath, Embed IO] r => + Sem r Modification +trashModification = do + cwd <- getCwd + bufPath <- checkBufferPath cwd + let original = pathText (filename bufPath) + Chronos.Time stamp <- liftIO Chronos.now + trashFile <- stopNote FilenameError.BufferPathInvalid (parseRelFileMaybe [exon|#{show stamp}_#{original}|]) + trashDir <- persistPath (Just [reldir|trash|]) + let trashPath = trashDir trashFile + stopTryAny (const (FilenameError.CreateDir (pathText trashDir))) (ensureDir trashDir) + pure (File trashPath) + +pathsForMod :: + Members [Stop FilenameError, Rpc, Rpc !! RpcError, Embed IO] r => + Bool -> + Modification -> + Sem r (Path Abs File, Path Abs File) +pathsForMod raw modi = do + cwd <- getCwd + bufPath <- checkBufferPath cwd + path <- assemblePath raw bufPath modi + prepareDestination path + pure (bufPath, path) + +writeBuffer :: + Members [Stop FilenameError, Rpc !! RpcError] r => + Text -> + Sem r () +writeBuffer action = + err "Couldn't write buffer" $ silent do + vimCommand "write!" + where + err msg = + resumeHoist \ e -> FilenameError.ActionFailed action [exon|#{msg}: #{rpcError e}|] + +updateBuffer :: + Member Rpc r => + Path Abs File -> + Sem r () +updateBuffer path = do + buf <- vimGetCurrentBuffer + bufferSetName buf (pathText path) + silent do + vimCommand "write!" + +relocate :: + Members [Stop FilenameError, Rpc, Rpc !! RpcError, Embed IO] r => + Bool -> + Modification -> + (Path Abs File -> Path Abs File -> Sem r ()) -> + Sem r () +relocate raw modi run = do + (bufPath, destPath) <- pathsForMod raw modi + run bufPath destPath + +copyOrFail :: + Members [Stop FilenameError, Embed IO] r => + Path Abs File -> + Path Abs File -> + Sem r () +copyOrFail src dest = + stopEitherWith copyFailed =<< tryAny (copyFile src dest) + where + copyFailed e = + FilenameError.ActionFailed "move" [exon|Couldn't copy file: #{e}|] + +moveFile :: + Members [Stop FilenameError, DataLog LogReport, Embed IO] r => + Path Abs File -> + Path Abs File -> + Sem r () +moveFile src dest = do + copyOrFail src dest + leftA (logReport . FilenameError.Remove) =<< tryAny (removeFile src) + +move :: + Members [Stop FilenameError, DataLog LogReport, Rpc, Rpc !! RpcError, Embed IO] r => + Bool -> + Modification -> + Sem r () +move raw modi = do + relocate raw modi \ buf dest -> do + writeBuffer "move" + moveFile buf dest + updateBuffer dest + +copy :: + Members [Stop FilenameError, Rpc, Rpc !! RpcError, Embed IO] r => + Bool -> + Modification -> + Sem r () +copy raw modi = + relocate raw modi \ src dest -> do + copyOrFail src dest + view <- vimCallFunction "winsaveview" [] + edit dest + vimCallFunction "winrestview" [view] + +proMove :: + Members [DataLog LogReport, Rpc !! RpcError, Embed IO] r => + Bang -> + Text -> + Handler r () +proMove bang spec = + mapReport @FilenameError $ resumeReport @Rpc do + move raw =<< smartModification raw spec + where + raw = + bang == Bang + +proCopy :: + Members [Rpc !! RpcError, Embed IO] r => + Bang -> + Text -> + Handler r () +proCopy bang spec = + mapReport @FilenameError $ resumeReport @Rpc do + copy raw =<< smartModification raw spec + where + raw = + bang == Bang + +proRemove :: + Members [Rpc !! RpcError, PersistPath !! PersistPathError, DataLog LogReport, Embed IO] r => + Handler r () +proRemove = + mapReport @FilenameError $ resumeReport @Rpc $ resumeReport @PersistPath do + move False =<< trashModification + buf <- vimGetCurrentBuffer + resume_ @RpcError do + wipeBuffer buf diff --git a/lib/Proteome/Files.hs b/lib/Proteome/Files.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Files.hs @@ -0,0 +1,313 @@ +module Proteome.Files where + +import Control.Lens (view) +import Control.Monad (foldM) +import Data.Either.Extra (eitherToMaybe) +import Data.List.Extra (dropEnd) +import qualified Data.List.NonEmpty as NonEmpty (toList, zip) +import Data.List.NonEmpty.Extra (maximumOn1) +import qualified Data.Text as Text +import Path (Abs, Dir, File, Path, Rel, parent, parseAbsDir, parseRelDir, parseRelFile, toFilePath, ()) +import Path.IO (createDirIfMissing, doesDirExist, listDirRel) +import Ribosome ( + Handler, + Report, + Rpc, + RpcError, + ScratchId (ScratchId), + SettingError, + Settings, + mapReport, + resumeReport, + ) +import Ribosome.Api (nvimGetOption) +import Ribosome.Api.Buffer (edit) +import Ribosome.Api.Path (nvimCwd) +import Ribosome.Data.ScratchOptions (ScratchOptions (filetype, name, syntax)) +import Ribosome.Data.Setting (Setting (Setting)) +import Ribosome.Host.Data.Args (ArgList (ArgList)) +import Ribosome.Menu ( + Filter (Fuzzy), + Mappings, + MenuAction, + MenuWidget, + Prompt (..), + PromptConfig (OnlyInsert), + PromptMode, + PromptText (PromptText), + WindowMenus, + menuOk, + menuState, + menuSuccess, + menuUpdatePrompt, + modal, + windowMenu, + withSelection, + (%=), + ) +import Ribosome.Menu.Mappings (insert, withInsert) +import Ribosome.Menu.MenuState (mode) +import qualified Ribosome.Settings as Settings +import Text.Regex.PCRE.Light (Regex, compileM) + +import Proteome.Data.FilesConfig (FilesConfig (FilesConfig)) +import Proteome.Data.FilesError (FilesError) +import qualified Proteome.Data.FilesError as FilesError (FilesError (..)) +import qualified Proteome.Data.FilesState as FilesState +import Proteome.Data.FilesState (FilesMode (FilesMode), FilesState, Segment (Full), fileSegments) +import Proteome.Files.Source (files) +import Proteome.Files.Syntax (filesSyntax) +import Proteome.Menu (handleResult) +import qualified Proteome.Settings as Settings + +data FileAction = + Create (Path Abs File) + | + Edit (NonEmpty (Path Abs File)) + | + NoAction + deriving stock (Eq, Show) + +editFile :: + MenuWidget FilesState r FileAction +editFile = + withSelection (pure . Edit . fmap (view #path)) + +matchingDirs :: + Member (Embed IO) r => + [Path Abs Dir] -> + Path Rel Dir -> + Sem r [Path Abs Dir] +matchingDirs bases path = + filterM (fmap (fromRight False) . tryAny . doesDirExist) (( path) <$> bases) + +dirsWithPrefix :: + Member (Embed IO) r => + Text -> + Path Abs Dir -> + Sem r [Path Rel Dir] +dirsWithPrefix (Text.toLower -> prefix) dir = + filter (Text.isPrefixOf prefix . Text.toLower . toText . toFilePath) . fst <$> listDirRel dir + +-- |Search all dirs in @bases@ for relative paths starting with @text@. +-- First, split the last path segment (after /) off and collect the subdirectories of @bases@ that start with the +-- remainder. If there is no / in the text, parsing the remainder fails with 'Nothing' and the @bases@ themselves are +-- used. +-- Then, search the resulting dirs for subdirs starting with the last segment. +-- Return the remainder and the relative subdir paths. +matchingPaths :: + Member (Embed IO) r => + [Path Abs Dir] -> + Text -> + Sem r (Text, [Path Rel Dir]) +matchingPaths bases text' = + (subpath,) . join <$> (traverse (dirsWithPrefix prefix) =<< dirs) + where + subpath = + maybe "" (toText . toFilePath) dir + dirs = + maybe (pure bases) (matchingDirs bases) dir + (dir, prefix) = + first (parseRelDir . toString) $ Text.breakOnEnd "/" text' + +commonPrefix :: [Text] -> Maybe Text +commonPrefix (h : t) = + foldM (\ p a -> view _1 <$> Text.commonPrefixes p a) h t +commonPrefix a = + listToMaybe a + +tabComplete :: + Member (Embed IO) r => + [Path Abs Dir] -> + Text -> + Sem r (Maybe Text) +tabComplete bases promptText = do + existingBases <- filterM doesDirExist bases + (subpath, paths) <- matchingPaths existingBases promptText + pure (mappend subpath <$> commonPrefix (toText . toFilePath <$> paths)) + +tabUpdatePrompt :: + PromptMode -> + Text -> + Prompt +tabUpdatePrompt st prefix = + Prompt (Text.length prefix) st (PromptText prefix) + +tab :: + Member (Embed IO) r => + [Path Abs Dir] -> + MenuWidget FilesState r FileAction +tab bases = do + Prompt _ promptState (PromptText promptText) <- ask + tabComplete bases promptText >>= \case + Just prefix -> + menuUpdatePrompt (tabUpdatePrompt promptState prefix) + Nothing -> + menuOk + +createAndEditFile :: + Members [Rpc, Stop FilesError, Embed IO] r => + Path Abs File -> + Sem r () +createAndEditFile path = do + stopTryAny (const err) create + edit path + where + err = + FilesError.CouldntCreateDir (toText (toFilePath dir)) + create = + createDirIfMissing True dir + dir = + parent path + +existingSubdirCount :: + Member (Embed IO) r => + [Text] -> + Path Abs Dir -> + Sem r Int +existingSubdirCount = + loop 0 + where + loop count [] _ = + pure count + loop count (h : t) dir = + case parseRelDir (toString h) of + Right f -> + ifM (doesDirExist sub) (loop (count + 1) t sub) (pure count) + where sub = dir f + Left _ -> + pure count + +createFile :: + Member (Reader Prompt) r => + Members [Stop FilesError, Embed IO] r => + NonEmpty (Path Abs Dir) -> + Sem r (Maybe (MenuAction FileAction)) +createFile bases = do + PromptText promptText <- view #text <$> ask + let + parse counts = + (base counts ) <$> parseRelFile (toString promptText) + subdirCounts <- traverse (existingSubdirCount (dirSegments promptText)) bases + maybe (err promptText) (menuSuccess . Create) (parse subdirCounts) + where + base counts = + fst $ maximumOn1 snd (NonEmpty.zip bases counts) + dirSegments = + dropEnd 1 . Text.splitOn "/" + err = + stop . FilesError.InvalidFilePath + +cycleSegment :: MenuWidget FilesState r FileAction +cycleSegment = + menuState do + mode . #segment %= FilesState.cycle + menuOk + +actions :: + Members [Stop FilesError, Embed IO] r => + NonEmpty (Path Abs Dir) -> + Mappings FilesState r FileAction +actions bases = + [ + (withInsert "", editFile), + (insert "", tab (NonEmpty.toList bases)), + (insert "", createFile bases), + (insert "", cycleSegment) + ] + +parsePath :: Path Abs Dir -> Text -> Maybe (Path Abs Dir) +parsePath _ path | Text.take 1 path == "/" = + parseAbsDir (toString path) +parsePath cwd path = + (cwd ) <$> parseRelDir (toString path) + +readRegex :: + Member (Stop FilesError) r => + Text -> + Text -> + Sem r Regex +readRegex name rgx = + stopNote (FilesError.BadRegex name rgx) (eitherToMaybe (compileM (encodeUtf8 rgx) mempty)) + +readRegexs :: + Members [Settings, Stop FilesError] r => + Setting [Text] -> + Sem r [Regex] +readRegexs s@(Setting name _ _) = + traverse (readRegex name) =<< Settings.get s + +filesConfig :: + Members [Rpc, Settings, Stop FilesError] r => + Sem r FilesConfig +filesConfig = + FilesConfig <$> useRg <*> hidden <*> fs <*> dirs <*> wildignore + where + useRg = + Settings.get Settings.filesUseRg + hidden = + Settings.get Settings.filesExcludeHidden + fs = + readRegexs Settings.filesExcludeFiles + dirs = + readRegexs Settings.filesExcludeDirectories + wildignore = + Text.splitOn "," <$> nvimGetOption "wildignore" + +fileAction :: + Members [Rpc, Stop FilesError, Stop Report, Embed IO] r => + FileAction -> + Sem r () +fileAction = \case + Create path -> + createAndEditFile path + Edit paths -> + traverse_ edit paths + NoAction -> + unit + +type FilesStack = + [ + WindowMenus () FilesState !! RpcError, + Log, + Async, + Embed IO + ] + +filesMenu :: + Members FilesStack r => + Members [Stop FilesError, Stop Report, Settings, Rpc] r => + Path Abs Dir -> + [Text] -> + Sem r () +filesMenu cwd pathSpecs = do + mapReport @RpcError do + conf <- filesConfig + items <- fmap (fmap fileSegments) <$> files conf nePaths + result <- windowMenu items (modal (FilesMode Fuzzy Full)) window (actions nePaths) + handleResult fileAction result + where + window = + def & #prompt .~ OnlyInsert & #items .~ opt + opt = + def { + name = ScratchId name, + syntax = [filesSyntax], + filetype = Just name + } + name = + "proteome-files" + nePaths = + fromMaybe (cwd :| []) (nonEmpty absPaths) + absPaths = + mapMaybe (parsePath cwd) pathSpecs + +proFiles :: + Members FilesStack r => + Members [Rpc !! RpcError, Settings !! SettingError] r => + ArgList -> + Handler r () +proFiles (ArgList paths) = + mapReport @FilesError $ resumeReport @Rpc $ resumeReport @Settings do + cwd <- resumeHoistAs FilesError.BadCwd nvimCwd + filesMenu cwd paths diff --git a/lib/Proteome/Files/Source.hs b/lib/Proteome/Files/Source.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Files/Source.hs @@ -0,0 +1,231 @@ +module Proteome.Files.Source where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TMChan (TMChan, closeTMChan, newTMChan, readTMChan, writeTMChan) +import Control.Lens.Regex.Text (match, regexing) +import qualified Data.List.NonEmpty as NonEmpty (toList, zip) +import qualified Data.Set as Set (fromList, toList) +import qualified Data.Text as Text +import Exon (exon) +import Path ( + Abs, + Dir, + File, + Path, + Rel, + dirname, + filename, + isProperPrefixOf, + parent, + parseAbsFile, + relfile, + stripProperPrefix, + toFilePath, + ) +import Path.IO (doesDirExist, findExecutable, walkDir) +import qualified Path.IO as WalkAction (WalkAction (WalkExclude)) +import Ribosome (pathText) +import Ribosome.Menu (MenuItem (MenuItem)) +import Ribosome.Menu.Stream.Util (takeUntilNothing) +import qualified Streamly.Prelude as Stream +import Streamly.Prelude (IsStream, SerialT) +import System.FilePattern ((?==)) +import Text.Regex.PCRE.Light (Regex) + +import Proteome.Data.FileScanItem (FileScanItem (FileScanItem)) +import Proteome.Data.FilesConfig (FilesConfig (FilesConfig)) +import Proteome.Grep.Process (processLines) +import Proteome.Path (dropSlash) + +-- TODO store traversals instead of Regexes? +matchPath :: [Regex] -> Path Abs t -> Bool +matchPath excludes path = + any check excludes + where + check rgx = + pathText path & has (regexing rgx . match) + +hiddenFilter :: + (Path Abs t -> Path Rel t) -> + Bool -> + Path Abs t -> + Bool +hiddenFilter lastSegment True = + Text.isPrefixOf "." . toText . toFilePath . lastSegment +hiddenFilter _ False = + const False + +filterFiles :: + Bool -> + [Regex] -> + [String] -> + [Path Abs File] -> + [Path Abs File] +filterFiles excludeHidden patterns wildignore = + filter (not . cond) + where + cond path = + matchPath patterns path || + hiddenFilter filename excludeHidden path || + any (?== name) wildignore + where + name = + toFilePath (filename path) + +filterDirs :: + Bool -> + [Regex] -> + [Path Abs Dir] -> + [Path Abs Dir] +filterDirs excludeHidden patterns = + filter pred' + where + pred' a = + matchPath patterns a || hiddenFilter dirname excludeHidden a + +scan :: + Member (Embed IO) r => + FilesConfig -> + TMChan FileScanItem -> + Path Abs Dir -> + Maybe Text -> + Sem r () +scan (FilesConfig _ excludeHidden ignoreFiles ignoreDirs wildignore) chan dir baseIndicator = + tryAny_ do + walkDir enqueue dir + where + enqueue _ dirs files' = + exclude <$ atomically (traverse_ (writeTMChan chan) filteredFiles) + where + filteredFiles = + cons <$> filterFiles excludeHidden ignoreFiles (toString <$> wildignore) files' + exclude = + WalkAction.WalkExclude (filterDirs excludeHidden ignoreDirs dirs) + cons = + FileScanItem dir baseIndicator + +runScanners :: + Members [Async, Embed IO] r => + FilesConfig -> + TMChan FileScanItem -> + NonEmpty (Path Abs Dir, Maybe Text) -> + Sem r () +runScanners conf chan paths = do + threads <- traverse (async . uncurry (scan conf chan)) paths + traverse_ await threads <* embed (atomically (closeTMChan chan)) + +withBaseIndicators :: + NonEmpty (Path Abs Dir) -> + NonEmpty (Path Abs Dir, Maybe Text) +withBaseIndicators bases@(_ :| []) = + (, Nothing) <$> bases +withBaseIndicators bases = + NonEmpty.zip bases (findSegment bases) + where + findSegment paths + | namesUnique paths = Just . dropSlash . dirname <$> paths + | allEqual next = Nothing <$ paths + | otherwise = findSegment next + where + next = parent <$> paths + namesUnique paths = + uniq names == NonEmpty.toList names + where + names = dirname <$> paths + allEqual paths = + length (uniq paths) == 1 + uniq as = + Set.toList (Set.fromList (NonEmpty.toList as)) + +fileMenuItem :: + Path Abs Dir -> + Maybe Text -> + Path Abs File -> + MenuItem (Path Abs File) +fileMenuItem base baseIndicator path = + MenuItem path text display + where + display = + " * " <> maybe "" indicator baseIndicator <> text + text = + toText (maybe (toFilePath path) toFilePath relativePath) + relativePath = + stripProperPrefix base path + indicator name = + "[" <> name <> "] " + +chanStream :: + IsStream t => + Functor (t IO) => + TMChan a -> + t IO a +chanStream chan = + takeUntilNothing (Stream.repeatM (liftIO (atomically (readTMChan chan)))) + +filesNative :: + Members [Async, Embed IO] r => + FilesConfig -> + NonEmpty (Path Abs Dir) -> + Sem r (SerialT IO (MenuItem (Path Abs File))) +filesNative conf paths = do + chan <- embed (atomically newTMChan) + void . async $ runScanners conf chan (withBaseIndicators paths) + pure (menuItem <$> chanStream chan) + where + menuItem (FileScanItem base baseIndicator path) = + fileMenuItem base baseIndicator path + +rgExcludes :: FilesConfig -> [Text] +rgExcludes (FilesConfig _ _ _ _ wilds) = + concat (wild <$> wilds) + where + wild i = + ["--glob", [exon|!#{i}|]] + +findBase :: + Path Abs File -> + NonEmpty (Path Abs Dir, Maybe Text) -> + Maybe (Path Abs Dir, Maybe Text) +findBase file = + find ((`isProperPrefixOf` file) . fst) + +rgMenuItem :: + NonEmpty (Path Abs Dir, Maybe Text) -> + Text -> + Maybe (MenuItem (Path Abs File)) +rgMenuItem bases file = do + path <- parseAbsFile (toString file) + (base, baseIndicator) <- findBase path bases + pure (fileMenuItem base baseIndicator path) + +filesRg :: + Path Abs File -> + FilesConfig -> + NonEmpty (Path Abs Dir) -> + SerialT IO (MenuItem (Path Abs File)) +filesRg rgExe conf paths = + Stream.mapMaybe item $ + processLines rgExe ("--files" : excludes <> patterns) + where + patterns = + toText . toFilePath <$> toList paths + excludes = + rgExcludes conf + item = + rgMenuItem (withBaseIndicators paths) + +files :: + Members [Async, Embed IO] r => + FilesConfig -> + NonEmpty (Path Abs Dir) -> + Sem r (SerialT IO (MenuItem (Path Abs File))) +files conf@(FilesConfig useRg _ _ _ _) paths = + filterM doesDirExist (toList paths) >>= \case + [] -> + pure Stream.nil + p : ps -> + findExecutable [relfile|rg|] >>= \case + Just rgExe | useRg -> + pure (filesRg rgExe conf (p :| ps)) + _ -> + filesNative conf (p :| ps) diff --git a/lib/Proteome/Files/Syntax.hs b/lib/Proteome/Files/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Files/Syntax.hs @@ -0,0 +1,54 @@ +module Proteome.Files.Syntax where + +import qualified Data.Map.Strict as Map (fromList) +import Ribosome.Data.SyntaxItem (SyntaxItem (options, params)) +import Ribosome.Syntax (HiLink (HiLink), Syntax (Syntax), syntaxMatch, syntaxVerbatim) +import Text.RawString.QQ (r) + +asterisk :: SyntaxItem +asterisk = + item {options, params} + where + item = syntaxMatch "ProFilesAsterisk" [r|^ \*|] + options = ["skipwhite"] + params = Map.fromList [("nextgroup", "ProFilesBase,ProFilesName")] + +base :: SyntaxItem +base = + item {options, params} + where + item = syntaxMatch "ProFilesBase" [r|\[[^]]\+\]|] + options = ["skipwhite", "contained"] + params = Map.fromList [("nextgroup", "ProFilesName")] + +name :: SyntaxItem +name = + item {options} + where + item = syntaxMatch "ProFilesName" ".*" + options = ["contained"] + +sync :: SyntaxItem +sync = + syntaxVerbatim "syntax sync minlines=1" + +hlAsterisk :: HiLink +hlAsterisk = + HiLink "ProFilesAsterisk" "Todo" + +hlBase :: HiLink +hlBase = + HiLink "ProFilesBase" "Directory" + +hlName :: HiLink +hlName = + HiLink "ProFilesName" "Type" + +filesSyntax :: Syntax +filesSyntax = + Syntax items [] links + where + items = + [asterisk, base, name, sync] + links = + [hlAsterisk, hlBase, hlName] diff --git a/lib/Proteome/Grep.hs b/lib/Proteome/Grep.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Grep.hs @@ -0,0 +1,290 @@ +module Proteome.Grep where + +import Control.Lens (view) +import qualified Data.Text as Text +import Exon (exon) +import Path (Abs, Dir, File, Path) +import Ribosome ( + Args, + Handler, + Report, + Rpc, + RpcError, + Scratch, + ScratchId (ScratchId), + Settings, + mapReport, + pathText, + pluginLogReports, + resumeReport, + toMsgpack, + unArgs, + ) +import Ribosome.Api (nvimCallFunction, nvimCommand, nvimDir) +import Ribosome.Api.Buffer (edit) +import Ribosome.Api.Path (nvimCwd) +import Ribosome.Api.Register (setregLine) +import Ribosome.Api.Window (setCurrentCursor) +import qualified Ribosome.Data.Register as Register (Register (Special)) +import Ribosome.Data.ScratchOptions (ScratchOptions (..)) +import Ribosome.Data.SettingError (SettingError) +import Ribosome.Menu ( + Filter (Fuzzy), + Mappings, + MenuItem, + MenuWidget, + ModalState, + ModalWindowMenus, + menuState, + modal, + windowMenu, + withFocus, + withSelection, + ) +import qualified Ribosome.Settings as Settings +import qualified Streamly.Internal.Data.Stream.IsStream as Stream +import Streamly.Prelude (IsStream, SerialT) + +import Proteome.Data.Env (Env) +import Proteome.Data.GrepError (GrepError) +import qualified Proteome.Data.GrepError as GrepError (GrepError (EmptyUserInput)) +import qualified Proteome.Data.GrepOutputLine as GrepOutputLine +import Proteome.Data.GrepOutputLine (GrepOutputLine (GrepOutputLine)) +import Proteome.Data.ReplaceError (ReplaceError) +import Proteome.Grep.Process (defaultCmdline, grepCmdline, grepMenuItems) +import Proteome.Grep.Replace (deleteLines, replaceBuffer) +import Proteome.Grep.Syntax (grepSyntax) +import Proteome.Menu (handleResult) +import qualified Proteome.Settings as Settings (grepCmdline) + +type GrepState = + ModalState GrepOutputLine + +data GrepAction = + Select (Path Abs File) Int (Maybe Int) + | + Replace (NonEmpty GrepOutputLine) + | + Delete (NonEmpty GrepOutputLine) + | + NoAction + deriving stock (Eq, Show) + +navigate :: + Member Rpc r => + Path Abs File -> + Int -> + Maybe Int -> + Sem r () +navigate path line col = do + edit path + setCurrentCursor line (fromMaybe 0 col) + nvimCommand "normal! zv" + nvimCommand "normal! zz" + +selectResult :: + MenuWidget GrepState r GrepAction +selectResult = do + withFocus \ (GrepOutputLine path line col _) -> + pure (Select path line col) + +yankResult :: + Members [Rpc, Resource, Embed IO] r => + MenuWidget GrepState r GrepAction +yankResult = + withFocus \ (GrepOutputLine _ _ _ txt) -> + NoAction <$ setregLine (Register.Special "\"") [txt] + +replaceResult :: + MenuWidget GrepState r GrepAction +replaceResult = + menuState $ withSelection (pure . Replace) + +deleteResult :: + MenuWidget GrepState r GrepAction +deleteResult = + menuState $ withSelection (pure . Delete) + +menuItemSameLine :: MenuItem GrepOutputLine -> MenuItem GrepOutputLine -> Bool +menuItemSameLine l r = + GrepOutputLine.sameLine (l ^. #meta) (r ^. #meta) + +uniqBy :: + Functor (t IO) => + IsStream t => + (a -> a -> Bool) -> + t IO a -> + t IO a +uniqBy f = + Stream.catMaybes . + Stream.smapM (flip check) (pure Nothing) + where + check new = + pure . \case + Just old | f old new -> + (Just old, Nothing) + Just _ -> + (Just new, Just new) + Nothing -> + (Just new, Just new) + +uniqueGrepLines :: + Functor (t IO) => + IsStream t => + t IO (MenuItem GrepOutputLine) -> + t IO (MenuItem GrepOutputLine) +uniqueGrepLines = + uniqBy menuItemSameLine + +grepItems :: + Members [Settings !! SettingError, Rpc, Stop GrepError, Log, Embed IO, Final IO] r => + Path Abs Dir -> + Text -> + [Text] -> + Sem r (SerialT IO (MenuItem GrepOutputLine)) +grepItems path patt opt = do + cwd <- nvimCwd + userCmd <- Settings.maybe Settings.grepCmdline + grepper <- maybe defaultCmdline pure userCmd + (exe, args) <- grepCmdline grepper patt path opt + items <- grepMenuItems cwd exe args + pure (uniqueGrepLines items) + +actions :: + Members [Scratch, Rpc, Rpc !! RpcError, AtomicState Env, Stop ReplaceError, Resource, Embed IO] r => + Mappings GrepState r GrepAction +actions = + [ + ("", selectResult), + ("y", yankResult), + ("r", replaceResult), + ("d", deleteResult) + ] + +grepAction :: + Members [Scratch, Rpc, Rpc !! RpcError, AtomicState Env, Stop ReplaceError, Resource, Embed IO] r => + GrepAction -> + Sem r () +grepAction = \case + Select path line col -> + navigate path line col + Replace results -> + replaceBuffer results + Delete results -> + deleteLines (toList results) + NoAction -> + unit + +type GrepErrorStack = + [Scratch, Settings, Rpc, Stop ReplaceError, Stop GrepError] + +handleErrors :: + Members [Settings !! SettingError, Scratch !! RpcError, Rpc !! RpcError, Stop Report] r => + InterpretersFor GrepErrorStack r +handleErrors = + mapReport @GrepError . + mapReport @ReplaceError . + pluginLogReports + +type GrepStack = + [ + ModalWindowMenus () GrepOutputLine !! RpcError, + Settings !! SettingError, + Scratch !! RpcError, + Rpc !! RpcError, + AtomicState Env, + Log, + Resource, + Embed IO, + Final IO + ] + +grepWith :: + Members GrepStack r => + Members GrepErrorStack r => + Member (Stop Report) r => + [Text] -> + Path Abs Dir -> + Text -> + Sem r () +grepWith opt path patt = + mapReport @RpcError do + items <- grepItems path patt opt + result <- windowMenu items (modal Fuzzy) (def & #items .~ scratchOptions) actions + handleResult grepAction result + where + scratchOptions = + def { + name = ScratchId name, + syntax = [grepSyntax], + filetype = Just name + } + name = + "proteome-grep" + +askUser :: + Members [Rpc, Stop GrepError] r => + Text -> + [Text] -> + Sem r Text +askUser purpose args = do + spec <- nvimCallFunction "input" (toMsgpack <$> [exon|#{purpose}: |] : args) + if Text.null spec then stop (GrepError.EmptyUserInput purpose) else pure spec + +grepWithNative :: + Members GrepStack r => + [Text] -> + Maybe Text -> + Maybe Args -> + Handler r () +grepWithNative opt pathSpec pattSpec = do + handleErrors do + path <- nvimDir =<< maybe (askUser "directory" [".", "dir"]) pure pathSpec + patt <- resumeReport @Rpc $ mapReport @GrepError do + maybe (askUser "pattern" []) (pure . unArgs) pattSpec + grepWith opt path patt + +proGrepIn :: + Members GrepStack r => + Maybe Text -> + Maybe Args -> + Handler r () +proGrepIn = + grepWithNative [] + +proGrepOpt :: + Members GrepStack r => + Text -> + Maybe Args -> + Handler r () +proGrepOpt opt patt = do + cwd <- resumeReport @Rpc $ mapReport @GrepError do + nvimCwd + grepWithNative (Text.words opt) (Just (pathText cwd)) patt + +proGrepOptIn :: + Members GrepStack r => + Text -> + Maybe Text -> + Maybe Args -> + Handler r () +proGrepOptIn opt = + grepWithNative (Text.words opt) + +proGrep :: + Members GrepStack r => + Maybe Args -> + Handler r () +proGrep = + proGrepOpt "" + +proGrepList :: + Members GrepStack r => + Text -> + Maybe Text -> + Maybe Text -> + Handler r [GrepOutputLine] +proGrepList patt pathSpec opt = do + path <- resumeReport @Rpc (nvimDir (fromMaybe "." pathSpec)) + items <- handleErrors (grepItems path patt (Text.words (fold opt))) + fmap (view #meta) <$> embed (Stream.toList items) diff --git a/lib/Proteome/Grep/Parse.hs b/lib/Proteome/Grep/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Grep/Parse.hs @@ -0,0 +1,56 @@ +module Proteome.Grep.Parse where + +import Chiasma.Data.Ident (generateIdent, identText) +import Data.Attoparsec.Text (parseOnly) +import qualified Data.Text as Text (strip) +import Exon (exon) +import qualified Log +import Path (Abs, Dir, Path, parseAbsFile, parseRelFile, stripProperPrefix, ()) +import Ribosome (pathText) +import Ribosome.Menu.Data.MenuItem (MenuItem (MenuItem)) +import Text.Parser.Char (anyChar, char, noneOf) +import Text.Parser.Combinators (manyTill) +import Text.Parser.Token (TokenParsing, natural) + +import Proteome.Data.GrepOutputLine (GrepOutputLine (GrepOutputLine)) +import Proteome.Grep.Syntax (lineNumber) + +grepParser :: + MonadFail m => + TokenParsing m => + Path Abs Dir -> + m GrepOutputLine +grepParser cwd = + GrepOutputLine <$> path <*> (subtract 1 <$> number) <*> optional number <*> (toText <$> many anyChar) + where + path = do + s <- manyTill (noneOf ":") (char ':') + maybe (fail "not a path") pure (parseAbsFile s <|> ((cwd ) <$> parseRelFile s)) + number = + (fromInteger <$> natural) <* char ':' + +formatGrepLine :: Path Abs Dir -> GrepOutputLine -> Text +formatGrepLine cwd (GrepOutputLine path line col text) = + [exon|#{relativePath} #{lineNumber} #{show line}:#{show (fromMaybe 1 col)} #{Text.strip text}|] + where + relativePath = + maybe (pathText path) pathText (stripProperPrefix cwd path) + +parseGrepOutput :: + Members [Log, Embed IO] r => + Path Abs Dir -> + Text -> + Sem r (Maybe (MenuItem GrepOutputLine)) +parseGrepOutput cwd = + item . parseOnly (grepParser cwd) + where + item (Right a) = do + ident <- identText <$> generateIdent + pure (Just (convert ident a)) + item (Left err) = + Nothing <$ Log.debug [exon|parsing grep output failed: #{toText err}|] + convert _ file = + MenuItem file text [exon| * #{text}|] + where + text = + formatGrepLine cwd file diff --git a/lib/Proteome/Grep/Process.hs b/lib/Proteome/Grep/Process.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Grep/Process.hs @@ -0,0 +1,124 @@ +module Proteome.Grep.Process where + +import qualified Data.Text as Text +import Data.Text (isInfixOf) +import Path (Abs, Dir, File, Path, parseAbsFile, relfile, toFilePath) +import Path.IO (findExecutable, isLocationOccupied) +import Ribosome (pathText) +import Ribosome.Final (inFinal_) +import Ribosome.Menu (MenuItem) +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Internal.Unicode.Stream as Stream +import qualified Streamly.Prelude as Stream +import Streamly.Prelude (IsStream) +import qualified Streamly.System.Process as Process +import Streamly.System.Process (ProcessFailure) + +import qualified Proteome.Data.GrepError as GrepError (GrepError (..)) +import Proteome.Data.GrepError (GrepError) +import Proteome.Data.GrepOutputLine (GrepOutputLine) +import Proteome.Grep.Parse (parseGrepOutput) +import Proteome.System.Path (findExe) + +defaultGrepCmdline :: Text +defaultGrepCmdline = + "grep -Hnr {pattern} {path}" + +defaultRgCmdline :: Text +defaultRgCmdline = + "rg --vimgrep --no-heading -e {pattern} {path}" + +defaultCmdline :: + Member (Embed IO) r => + Sem r Text +defaultCmdline = + findExecutable [relfile|rg|] <&> \case + Just _ -> + defaultRgCmdline + _ -> + defaultGrepCmdline + +patternPlaceholder :: Text +patternPlaceholder = + "{pattern}" + +pathPlaceholder :: Text +pathPlaceholder = + "{path}" + +replaceOrAppend :: Text -> Text -> [Text] -> [Text] +replaceOrAppend placeholder target segments | any (placeholder `isInfixOf`) segments = + Text.replace placeholder target <$> segments +replaceOrAppend _ target segments = + segments <> [target] + +parseAbsExe :: + Member (Stop GrepError) r => + Text -> + Sem r (Path Abs File) +parseAbsExe exe = + stopEitherAs (GrepError.NoSuchExecutable exe) $ parseAbsFile (toString exe) + +grepCmdline :: + Members [Stop GrepError, Embed IO] r => + Text -> + Text -> + Path Abs Dir -> + [Text] -> + Sem r (Path Abs File, [Text]) +grepCmdline cmdline patt destination opt = do + when (Text.null exe) do + stop GrepError.Empty + absExe <- if absolute exe then parseAbsExe exe else findExe exe + unlessM (isLocationOccupied destination) do + stop destError + pure (absExe, withDir destination) + where + absolute a = + Text.take 1 a == "/" + argSegments = + opt <> Text.words (Text.strip args) + (exe, args) = + Text.breakOn " " (Text.strip cmdline) + withDir dir = + replaceOrAppend pathPlaceholder (pathText dir) withPattern + withPattern = + replaceOrAppend patternPlaceholder patt argSegments + destError = + GrepError.NoSuchDestination destination + +processOutput :: + IsStream t => + String -> + [Text] -> + t IO Word8 +processOutput exe args = + Process.toBytes exe (toString <$> args) + +processLines :: + IsStream t => + Path Abs File -> + [Text] -> + t IO Text +processLines exe args = + Stream.lines (toText <$> Fold.toList) $ + Stream.decodeUtf8 $ + processOutput (toFilePath exe) args + +grepMenuItems :: + Functor (t IO) => + Members [Log, Embed IO, Final IO] r => + IsStream t => + Path Abs Dir -> + Path Abs File -> + [Text] -> + Sem r (t IO (MenuItem GrepOutputLine)) +grepMenuItems cwd exe args = + inFinal_ \ lower _ pur -> + pur $ + Stream.handle processFailure $ + Stream.mapMaybeM (fmap join . lower . parseGrepOutput cwd) $ + processLines exe args + where + processFailure (_ :: ProcessFailure) = + Stream.nil diff --git a/lib/Proteome/Grep/Replace.hs b/lib/Proteome/Grep/Replace.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Grep/Replace.hs @@ -0,0 +1,175 @@ +module Proteome.Grep.Replace where + +import qualified Data.List.NonEmpty as NonEmpty (toList) +import qualified Data.Text as Text +import Path (parseAbsFile) +import Prelude hiding (group) +import Ribosome ( + Buffer, + Handler, + Rpc, + RpcError, + Scratch, + ScratchId (ScratchId), + ScratchState (ScratchState), + mapReport, + pathText, + resumeReport, + toMsgpack, + ) +import Ribosome.Api (bufferGetLines, bufferSetLines, bufferSetOption, nvimCommand, vimCallFunction) +import Ribosome.Api.Autocmd (bufferAutocmd) +import Ribosome.Api.Buffer (addBuffer, bufferContent, bufferForFile, wipeBuffer) +import Ribosome.Api.Option (withOption) +import Ribosome.Data.FileBuffer (FileBuffer (FileBuffer)) +import qualified Ribosome.Data.FloatOptions as FloatBorder +import Ribosome.Data.FloatOptions (FloatOptions (FloatOptions)) +import Ribosome.Host.Data.RpcType (group) +import qualified Ribosome.Scratch as Scratch + +import qualified Proteome.Data.Env as Env (replace) +import Proteome.Data.Env (Env) +import qualified Proteome.Data.GrepOutputLine as GrepOutputLine +import Proteome.Data.GrepOutputLine (GrepOutputLine (GrepOutputLine)) +import Proteome.Data.Replace (Replace (Replace)) +import qualified Proteome.Data.ReplaceError as ReplaceError (ReplaceError (BadReplacement, CouldntLoadBuffer)) +import Proteome.Data.ReplaceError (ReplaceError) + +scratchName :: Text +scratchName = + "proteome-replace" + +replaceBuffer :: + Members [Scratch, Rpc, AtomicState Env] r => + NonEmpty GrepOutputLine -> + Sem r () +replaceBuffer lines' = do + scratch <- Scratch.show content options + let buffer = Scratch.buffer scratch + bufferSetOption buffer "buftype" ("acwrite" :: Text) + bufferAutocmd buffer "BufWriteCmd" def { group = Just "ProteomeReplace" } "silent! ProReplaceSave" + bufferAutocmd buffer "BufUnload" def { group = Just "ProteomeReplace" } "silent! ProReplaceQuit" + atomicModify' (#replace ?~ Replace scratch lines') + where + content = + GrepOutputLine.content <$> lines' + options = + def { + Scratch.name = ScratchId scratchName, + Scratch.modify = True, + Scratch.focus = True, + Scratch.filetype = Just scratchName + } + +-- If the deleted line was surrounded by blank lines or buffer edges, there will be extraneous whitespace. +-- First check whether the line number of the deleted line was line 0 and its content is now empty. +-- Then do the same for the last line. +-- Finally, check if both the preceding and current line are empty. +deleteExtraBlankLine :: + Member Rpc r => + Buffer -> + Int -> + Sem r () +deleteExtraBlankLine buffer line = do + check (line - 2) line [""] + check line (line + 1) [""] + check (line - 1) line ["", ""] + where + check l r target = do + content <- readLines l (r + 1) + when (content == target) delete + readLines l r = + bufferGetLines buffer (clamp0 l) r False + delete = + bufferSetLines buffer line (line + 1) False [] + clamp0 a | a < 0 = 0 + clamp0 a = a + +fileBuffer :: + Member Rpc r => + Text -> + Sem r (Maybe FileBuffer) +fileBuffer path = + join <$> traverse bufferForFile (parseAbsFile (toString path)) + +replaceLine :: + Members [Rpc, Stop ReplaceError] r => + Text -> + GrepOutputLine -> + Sem r (Maybe Buffer) +replaceLine updatedLine (GrepOutputLine path line _ _) = do + exists <- isJust <$> bufferForFile path + unless exists (addBuffer (pathText path)) + () <- vimCallFunction "bufload" [toMsgpack path] + FileBuffer buffer _ <- stopNote (ReplaceError.CouldntLoadBuffer path) =<< bufferForFile path + bufferSetLines buffer line (line + 1) False replacement + deleteExtraBlankLine buffer line + pure (bool (Just buffer) Nothing exists) + where + replacement = + [updatedLine | not (Text.null updatedLine)] + +lineNumberDesc :: (Text, GrepOutputLine) -> Int +lineNumberDesc (_, GrepOutputLine _ number _ _) = + -number + +replaceFloatOptions :: FloatOptions +replaceFloatOptions = + FloatOptions def 1 1 0 0 False def Nothing FloatBorder.None True False (Just def) (Just 1) + +withReplaceEnv :: + Members [Rpc !! RpcError, Rpc, Resource] r => + Sem r [Maybe Buffer] -> + Sem r () +withReplaceEnv run = do + withOption "hidden" True do + transient <- run + resume_ (nvimCommand "noautocmd wall") + traverse_ wipeBuffer (catMaybes transient) + +replaceLines :: + Members [Rpc !! RpcError, Rpc, Resource, Stop ReplaceError] r => + Buffer -> + [(Text, GrepOutputLine)] -> + Sem r () +replaceLines scratchBuffer lines' = do + bufferSetOption scratchBuffer "buftype" ("nofile" :: Text) + withReplaceEnv do + traverse (uncurry replaceLine) (sortOn lineNumberDesc lines') + bufferSetOption scratchBuffer "buftype" ("acwrite" :: Text) + bufferSetOption scratchBuffer "modified" False + +deleteLines :: + Members [Rpc !! RpcError, Rpc, Resource, Stop ReplaceError] r => + [GrepOutputLine] -> + Sem r () +deleteLines lines' = + withReplaceEnv do + traverse (uncurry replaceLine) (sortOn lineNumberDesc (zip (repeat "") lines')) + +replaceSave :: + Members [Rpc !! RpcError, Rpc, Resource, Stop ReplaceError] r => + Replace -> + Sem r () +replaceSave (Replace (ScratchState _ _ buffer _ _ _ _) lines') = do + updatedLines <- bufferContent buffer + if length updatedLines /= length lines' + then badReplacement + else replaceLines buffer (zip updatedLines (NonEmpty.toList lines')) + where + badReplacement = + stop ReplaceError.BadReplacement + +-- TODO quit after saving, controlled by setting +proReplaceSave :: + Members [AtomicState Env, Rpc !! RpcError, Resource] r => + Handler r () +proReplaceSave = + resumeReport $ mapReport do + traverse_ replaceSave =<< atomicGets Env.replace + +proReplaceQuit :: + Member (AtomicState Env) r => + Handler r () +proReplaceQuit = + atomicModify' (#replace .~ Nothing) diff --git a/lib/Proteome/Grep/Syntax.hs b/lib/Proteome/Grep/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Grep/Syntax.hs @@ -0,0 +1,103 @@ +module Proteome.Grep.Syntax where + +import qualified Data.Map.Strict as Map (fromList) +import Ribosome.Data.Syntax.Syntax (HiLink (HiLink), Syntax (Syntax)) +import Ribosome.Data.SyntaxItem (SyntaxItem (options, params)) +import Ribosome.Syntax (syntaxMatch, syntaxVerbatim) +import Text.RawString.QQ (r) + +lineNumber :: Text +lineNumber = + "\57505" + +asterisk :: SyntaxItem +asterisk = + item {options, params} + where + item = syntaxMatch "ProGrepAsterisk" [r|^ \*|] + options = ["skipwhite"] + params = Map.fromList [("nextgroup", "ProGrepPath")] + +path :: SyntaxItem +path = + item {options, params} + where + item = syntaxMatch "ProGrepPath" ([r|.*\ze|] <> lineNumber) + options = ["contained", "skipwhite"] + params = Map.fromList [("nextgroup", "ProGrepLN")] + +ln :: SyntaxItem +ln = + item {options, params} + where + item = syntaxMatch "ProGrepLN" lineNumber + options = ["contained", "skipwhite"] + params = Map.fromList [("nextgroup", "ProGrepLine")] + +line :: SyntaxItem +line = + item {options, params} + where + item = syntaxMatch "ProGrepLine" [r|\d\+\ze:|] + options = ["contained"] + params = Map.fromList [("nextgroup", "ProGrepColon")] + +colon :: SyntaxItem +colon = + item {options, params} + where + item = syntaxMatch "ProGrepColon" [r|:|] + options = ["contained"] + params = Map.fromList [("nextgroup", "ProGrepCol")] + +col :: SyntaxItem +col = + item {options, params} + where + item = syntaxMatch "ProGrepCol" [r|\d\+|] + options = ["contained", "skipwhite"] + params = Map.fromList [("nextgroup", "ProGrepText")] + +text_ :: SyntaxItem +text_ = + item { options } + where + item = syntaxMatch "ProGrepText" [r|.\+|] + options = ["contained"] + +sync :: SyntaxItem +sync = + syntaxVerbatim "syntax sync minlines=1" + +hlAsterisk :: HiLink +hlAsterisk = + HiLink "ProGrepAsterisk" "Todo" + +hlPath :: HiLink +hlPath = + HiLink "ProGrepPath" "Type" + +hlLn :: HiLink +hlLn = + HiLink "ProGrepLN" "LineNr" + +hlLine :: HiLink +hlLine = + HiLink "ProGrepLine" "Constant" + +hlCol :: HiLink +hlCol = + HiLink "ProGrepCol" "Constant" + +hlText :: HiLink +hlText = + HiLink "ProGrepText" "Directory" + +grepSyntax :: Syntax +grepSyntax = + Syntax items [] links + where + items = + [asterisk, path, ln, line, col, colon, text_, sync] + links = + [hlAsterisk, hlPath, hlLn, hlLine, hlCol, hlText] diff --git a/lib/Proteome/Init.hs b/lib/Proteome/Init.hs --- a/lib/Proteome/Init.hs +++ b/lib/Proteome/Init.hs @@ -1,105 +1,96 @@ -module Proteome.Init( - initialize, - proteomeStage2, - proteomeStage4, - proteomePoll, - proteomeStage1, - resolveMainProject, - initWithMain, - resolveAndInitMain, -) where +module Proteome.Init where -import Data.Default.Class (Default(def)) -import qualified Control.Lens as Lens (set) -import Data.Maybe (fromMaybe) -import Data.Either (fromRight) -import System.Log.Logger (updateGlobalLogger, setLevel, Priority(ERROR)) -import Control.Monad.IO.Class (liftIO) -import UnliftIO.Directory (getCurrentDirectory) -import UnliftIO.STM (TVar) -import Neovim (Neovim, vim_call_function', fromObject) -import Neovim.Context.Internal (Config(customConfig), asks') -import Ribosome.Config.Setting (settingE, updateSetting) -import Ribosome.Control.Ribo (Ribo) -import qualified Ribosome.Control.Ribo as Ribo (inspect, modify) -import Ribosome.Control.Ribosome (newRibosome, Ribosome) -import Ribosome.Internal.IO (retypeNeovim) -import qualified Proteome.Data.Env as Env (mainProject, _mainProject) +import Exon (exon) +import qualified Log +import Ribosome (Handler, Rpc, RpcError, SettingError, Settings, resumeReport) +import Ribosome.Api (nvimCallFunction, uautocmd) +import qualified Ribosome.Settings as Settings + +import Proteome.Config (logConfig, readConfig) import Proteome.Data.Env (Env) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project ( - Project(meta), - ProjectType(..), - ProjectMetadata(DirProject, VirtualProject), - ) -import Proteome.Project (pathData) -import Proteome.Project.Resolve (resolveProjectFromConfig) +import qualified Proteome.Data.Env as Env (mainProject) +import Proteome.Data.Project (Project (Project)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject, VirtualProject)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot)) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) +import Proteome.Data.ResolveError (ResolveError) import Proteome.Project.Activate (activateProject) -import Proteome.Config (readConfig, logConfig) -import Proteome.PersistBuffers (loadBuffers) -import qualified Proteome.Log as Log -import qualified Proteome.Settings as S +import Proteome.Project.Resolve (fromRootSettings) +import qualified Proteome.Settings as Settings (mainName, mainProjectDir, mainType) -resolveMainProject :: Ribo e Project +resolveMainProject :: + Members [Settings, Settings !! SettingError, Rpc, Stop ResolveError, Embed IO] r => + Sem r Project resolveMainProject = do - mainDir <- settingE S.mainProjectDir - vimCwd <- vim_call_function' "getcwd" [] - cwd <- getCurrentDirectory - (root, name, tpe) <- pathData (fromRight (fromRight cwd (fromObject vimCwd)) mainDir) - resolveProjectFromConfig (Just root) name (Just tpe) - -setMainProject :: Project -> Proteome () -setMainProject project = - Ribo.modify $ Lens.set Env._mainProject project + mainDir <- Settings.maybe Settings.mainProjectDir + vimCwd <- nvimCallFunction "getcwd" [] + fromRootSettings (ProjectRoot (fromMaybe vimCwd mainDir)) -updateMainType :: Maybe ProjectType -> Proteome () -updateMainType tpe = updateSetting S.mainType (fromMaybe (ProjectType "none") tpe) +updateMainType :: + Member Settings r => + Maybe ProjectType -> + Sem r () +updateMainType tpe = + Settings.update Settings.mainType (fromMaybe (ProjectType "none") tpe) -setMainProjectVars :: ProjectMetadata -> Proteome () -setMainProjectVars (DirProject name _ tpe) = do - updateSetting S.mainName name - updateMainType tpe -setMainProjectVars (VirtualProject name) = do - updateSetting S.mainName name - updateMainType (Just (ProjectType "virtual")) +setMainProjectVars :: + Member Settings r => + ProjectMetadata -> + Sem r () +setMainProjectVars = \case + DirProject name _ tpe -> do + Settings.update Settings.mainName name + updateMainType tpe + VirtualProject name -> do + Settings.update Settings.mainName name + updateMainType (Just (ProjectType "virtual")) -initWithMain :: Project -> Proteome () -initWithMain main = do - Log.debugS $ "initializing with main project: " ++ show main - setMainProject main - setMainProjectVars (meta main) +initWithMain :: + Members [AtomicState Env, Settings, Rpc, Log, Embed IO] r => + Project -> + Sem r () +initWithMain main@(Project meta _ _ _) = do + Log.debug [exon|initializing with main project: #{show main}|] + atomicModify' (#mainProject .~ main) + setMainProjectVars meta activateProject main -resolveAndInitMain :: Proteome () -resolveAndInitMain = do - main <- resolveMainProject - initWithMain main - -initialize' :: Proteome (Ribosome (TVar Env)) -initialize' = do - resolveAndInitMain - asks' customConfig +resolveAndInitMain :: + Members [AtomicState Env, Settings !! SettingError, Settings, Rpc, Stop ResolveError, Log, Embed IO] r => + Sem r () +resolveAndInitMain = + initWithMain =<< resolveMainProject -initialize :: Neovim e (Ribosome (TVar Env)) -initialize = do - liftIO $ updateGlobalLogger "Neovim.Plugin" (setLevel ERROR) - ribo <- newRibosome "proteome" def - retypeNeovim (const ribo) initialize' +loadConfig :: + Members [AtomicState Env, Rpc] r => + Text -> + Sem r () +loadConfig dir = + logConfig =<< readConfig dir =<< atomicGets Env.mainProject -proteomeStage1 :: Proteome () -proteomeStage1 = loadBuffers +projectConfig :: + Members [AtomicState Env, Rpc] r => + Sem r () +projectConfig = do + loadConfig "project" + uautocmd "ProteomeProject" -proteomeStage2 :: Proteome () -proteomeStage2 = do - main <- Ribo.inspect Env.mainProject - paths <- readConfig "project" main - logConfig paths +projectConfigAfter :: + Members [AtomicState Env, Rpc] r => + Sem r () +projectConfigAfter = do + loadConfig "project_after" + uautocmd "ProteomeProjectAfter" + uautocmd "RibosomeUpdateVariables" -proteomeStage4 :: Proteome () -proteomeStage4 = do - main <- Ribo.inspect Env.mainProject - paths <- readConfig "project_after" main - logConfig paths +proLoad :: + Members [AtomicState Env, Rpc !! RpcError] r => + Handler r () +proLoad = + resumeReport @Rpc projectConfig -proteomePoll :: Neovim e Bool -proteomePoll = return True +proLoadAfter :: + Members [AtomicState Env, Rpc !! RpcError] r => + Handler r () +proLoadAfter = + resumeReport @Rpc projectConfigAfter diff --git a/lib/Proteome/Log.hs b/lib/Proteome/Log.hs deleted file mode 100644 --- a/lib/Proteome/Log.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Proteome.Log( - debug, - info, - debugS, - infoS, - R.p, -) where - -import Ribosome.Control.Ribo (Ribo) -import qualified Ribosome.Log as R (debug, info, p) - -debug :: String -> Ribo e () -debug = R.debug "proteome" - -info :: String -> Ribo e () -info = R.info "proteome" - -debugS :: Show a => a -> Ribo e () -debugS = R.debug "proteome" - -infoS :: Show a => a -> Ribo e () -infoS = R.info "proteome" diff --git a/lib/Proteome/Menu.hs b/lib/Proteome/Menu.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Menu.hs @@ -0,0 +1,17 @@ +module Proteome.Menu where + +import Ribosome (Report, Rpc) +import Ribosome.Menu (MenuResult (Aborted, Error, Success)) + +handleResult :: + Members [Rpc, Stop Report] r => + (a -> Sem r ()) -> + MenuResult a -> + Sem r () +handleResult handle = \case + Success a -> + handle a + Aborted -> + unit + Error e -> + stop (fromText e) diff --git a/lib/Proteome/Path.hs b/lib/Proteome/Path.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Path.hs @@ -0,0 +1,103 @@ +module Proteome.Path where + +import qualified Data.Text as Text +import Path ( + Abs, + Dir, + File, + Path, + Rel, + parent, + parseAbsDir, + parseAbsFile, + parseRelDir, + parseRelFile, + (), + ) +import Path.IO (doesFileExist) +import Ribosome (pathText) + +parsePathMaybe :: + (FilePath -> Either a (Path b t)) -> + Text -> + Maybe (Path b t) +parsePathMaybe parser = + rightToMaybe . parser . toString + +parseAbsDirMaybe :: + Text -> + Maybe (Path Abs Dir) +parseAbsDirMaybe = + parsePathMaybe parseAbsDir + +parseAbsFileMaybe :: + Text -> + Maybe (Path Abs File) +parseAbsFileMaybe = + parsePathMaybe parseAbsFile + +parseRelDirMaybe :: + Text -> + Maybe (Path Rel Dir) +parseRelDirMaybe = + parsePathMaybe parseRelDir + +parseRelFileMaybe :: + Text -> + Maybe (Path Rel File) +parseRelFileMaybe = + parsePathMaybe parseRelFile + +absoluteParseDir :: + Path Abs Dir -> + Text -> + Maybe (Path Abs Dir) +absoluteParseDir cwd spec = + tryAbsolute <|> tryRelative + where + specS = + toString spec + tryAbsolute = + rightToMaybe (parseAbsDir specS) + tryRelative = + makeAbsolute <$> rightToMaybe (parseRelDir specS) + makeAbsolute path = + cwd path + +absoluteParse :: + Path Abs Dir -> + Text -> + Maybe (Path Abs File) +absoluteParse cwd spec = + tryAbsolute <|> tryRelative + where + specS = + toString spec + tryAbsolute = + rightToMaybe (parseAbsFile specS) + tryRelative = + makeAbsolute <$> rightToMaybe (parseRelFile specS) + makeAbsolute path = + cwd path + +existingFile :: + MonadIO m => + Path Abs Dir -> + Text -> + m (Maybe (Path Abs File)) +existingFile cwd spec = + join <$> traverse check (absoluteParse cwd spec) + where + check path = do + exists <- doesFileExist path + pure $ if exists then Just path else Nothing + +dropSlash :: Path b t -> Text +dropSlash = + Text.dropWhileEnd ('/' ==) . pathText + +rootPathSegment :: Path b Dir -> Path b Dir +rootPathSegment p = + if parent (parent p) == parent p + then p + else rootPathSegment (parent p) diff --git a/lib/Proteome/PersistBuffers.hs b/lib/Proteome/PersistBuffers.hs --- a/lib/Proteome/PersistBuffers.hs +++ b/lib/Proteome/PersistBuffers.hs @@ -1,90 +1,87 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Proteome.PersistBuffers( - loadBuffers, - storeBuffers, - PersistBuffers(PersistBuffers), -) where - -import GHC.Generics -import Control.Monad (filterM, when) -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) -import System.FilePath (()) -import Neovim (vim_get_current_buffer', vim_get_buffers', buffer_get_name', vim_command') -import Ribosome.Api.Buffer (edit, buflisted) -import Ribosome.Persist (persistStore, persistLoad) -import Ribosome.Control.Ribo (lockOrSkip) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project ( - Project(Project), - ProjectMetadata(DirProject), - ProjectName(ProjectName), - ProjectType(ProjectType) - ) -import Proteome.Env (getMainProject) - -data PersistBuffers = - PersistBuffers { - current :: Maybe FilePath, - buffers :: [FilePath] - } - deriving (Eq, Generic, Show) - -instance ToJSON PersistBuffers where - toEncoding = genericToEncoding defaultOptions +module Proteome.PersistBuffers where -instance FromJSON PersistBuffers +import Conc (Lock, lockOrSkip_) +import qualified Data.Text as Text (null) +import Exon (exon) +import qualified Log +import Path (Abs, Dir, File, Path, Rel, parseRelDir, relfile, toFilePath, ()) +import Ribosome (Rpc, RpcError) +import Ribosome.Api (bufferGetName, vimCommand, vimGetCurrentBuffer) +import Ribosome.Api.Buffer (bufferForFile, buflisted, edit) +import qualified Ribosome.Data.FileBuffer as FileBuffer +import Ribosome.Effect.Persist (Persist) +import qualified Ribosome.Persist as Persist -projectSubPath :: Proteome (Maybe FilePath) -projectSubPath = do - main <- getMainProject - return $ case main of - Project (DirProject (ProjectName name) _ (Just (ProjectType tpe))) _ _ _ -> Just $ tpe name - _ -> Nothing +import Proteome.Data.Env (Env) +import qualified Proteome.Data.Env as Env (buffers, mainProject) +import Proteome.Data.PersistBuffers (PersistBuffers (PersistBuffers)) +import Proteome.Data.Project (Project (Project)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject)) +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot)) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) +import Proteome.Path (existingFile) -unsafeStoreBuffers :: FilePath -> Proteome () -unsafeStoreBuffers path = do - active <- vim_get_current_buffer' - activeName <- buffer_get_name' active - activeIsFile <- liftIO $ doesFileExist activeName - let current' = if activeIsFile then Just activeName else Nothing - all' <- vim_get_buffers' >>= filterM buflisted >>= traverse buffer_get_name' - files <- liftIO $ filterM doesFileExist all' - persistStore (path "buffers") (PersistBuffers current' files) +data StoreBuffersLock = + StoreBuffersLock + deriving stock (Eq, Show) -safeStoreBuffers :: FilePath -> Proteome () -safeStoreBuffers path = - lockOrSkip "store-buffers" $ unsafeStoreBuffers path +data LoadBuffersLock = + LoadBuffersLock + deriving stock (Eq, Show) -decodePersistBuffers :: FilePath -> Proteome (Either String PersistBuffers) -decodePersistBuffers path = runExceptT $ persistLoad (path "buffers") +file :: Path Rel File +file = + [relfile|buffers.json|] -restoreBuffers :: PersistBuffers -> Proteome () -restoreBuffers (PersistBuffers current' buffers') = do - active <- vim_get_current_buffer' - name <- buffer_get_name' active - when (null name) $ mapM_ edit current' - traverse_ (\a -> vim_command' ("silent! badd " ++ a)) buffers' +projectPaths :: + Member (AtomicState Env) r => + Sem r (Maybe (Path Abs Dir, Path Rel Dir)) +projectPaths = + examine <$> atomicGets Env.mainProject + where + examine (Project (DirProject (ProjectName name) (ProjectRoot root) (Just (ProjectType tpe))) _ _ _) = + (root,) <$> (() <$> parseRelDir (toString tpe) <*> parseRelDir (toString name)) + examine _ = + Nothing -unsafeLoadBuffers :: FilePath -> Proteome () -unsafeLoadBuffers path = do - pb <- decodePersistBuffers path - mapM_ restoreBuffers pb +storeBuffers :: + Member (Persist PersistBuffers) r => + Members [Lock @@ StoreBuffersLock, AtomicState Env, Rpc, Rpc !! RpcError, Resource, Embed IO] r => + Sem r () +storeBuffers = + tag $ lockOrSkip_ $ projectPaths >>= traverse_ \ (cwd, path) -> do + names <- traverse bufferGetName =<< filterM buflisted =<< atomicGets Env.buffers + files <- catMaybes <$> traverse (existingFile cwd) names + Persist.store (Just (path file)) (PersistBuffers (listToMaybe files) files) -safeLoadBuffers :: FilePath -> Proteome () -safeLoadBuffers path = - lockOrSkip "load-buffers" $ unsafeLoadBuffers path +decodePersistBuffers :: + Member (Persist PersistBuffers) r => + Path Rel Dir -> + Sem r (Maybe PersistBuffers) +decodePersistBuffers path = + Persist.load (Just (path file)) -storeBuffers :: Proteome () -storeBuffers = do - sub <- projectSubPath - mapM_ safeStoreBuffers sub +restoreBuffers :: + Members [Rpc, AtomicState Env, Log] r => + PersistBuffers -> + Sem r () +restoreBuffers (PersistBuffers active rest) = do + Log.debug [exon|Restoring buffers. Active: #{show active}|] + traverse_ loadActive active + traverse_ add rest + buffers <- traverse bufferForFile rest + atomicModify' (#buffers .~ (FileBuffer.buffer <$> catMaybes buffers)) + where + add a = + vimCommand ("silent! badd " <> toText (toFilePath a)) + loadActive path = do + currentBufferName <- bufferGetName =<< vimGetCurrentBuffer + when (Text.null currentBufferName) (edit path) -loadBuffers :: Proteome () -loadBuffers = do - sub <- projectSubPath - mapM_ safeLoadBuffers sub +loadBuffers :: + Members [Persist PersistBuffers, Lock @@ LoadBuffersLock, Rpc, AtomicState Env, Log, Resource] r => + Sem r () +loadBuffers = + tag $ lockOrSkip_ $ projectPaths >>= traverse_ \ (_, path) -> + traverse_ restoreBuffers =<< decodePersistBuffers path diff --git a/lib/Proteome/Plugin.hs b/lib/Proteome/Plugin.hs --- a/lib/Proteome/Plugin.hs +++ b/lib/Proteome/Plugin.hs @@ -1,61 +1,194 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} - -module Proteome.Plugin( - plugin, -) -where +module Proteome.Plugin where -import Data.Default.Class (Default(def)) -import UnliftIO.STM (TVar) -import Neovim ( - Plugin(..), - function, - function', - command, - command', - autocmd, - Neovim, - StartupConfig, - NeovimConfig, - NeovimPlugin, - Synchronous(..), - wrapPlugin, - CommandOption(CmdBang), +import Conc (ConcStack, Lock, Restoration, interpretAtomic, interpretLockReentrant, withAsync_) +import Polysemy.Chronos (ChronosTime) +import Ribosome ( + BootError, + Event, + Execution (Async, Sync), + Persist, + PersistError, + PluginName, + Reports, + Rpc, + RpcError, + RpcHandler, + Scratch, + SettingError, + Settings, + completeBuiltin, + interpretPersist, + interpretPersistPath, + logReport, + resumeLogReport, + rpc, + rpcAutocmd, + rpcCommand, + rpcFunction, + runNvimPluginIO, ) -import Ribosome.Control.Ribosome (Ribosome) -import Proteome.Init (proteomePoll, proteomeStage1, proteomeStage2, proteomeStage4, initialize) -import Proteome.Data.Env (Env) -import Proteome.Add (proAdd, proAddCmd) +import Ribosome.Data.PersistPathError (PersistPathError) +import Ribosome.Effect.PersistPath (PersistPath) +import Ribosome.Host.Data.Report (LogReport) +import Ribosome.Menu (ModalWindowMenus, NvimMenus, WindowMenus, interpretMenus, interpretWindowMenu) + +import Proteome.Add (proAdd, proAddCmd, proAddMenu) +import Proteome.BufEnter (Mru, bufEnter) +import Proteome.Buffers (proBuffers) import Proteome.Config (proReadConfig) -import Proteome.Tags (proTags) -import Proteome.Save (proSave) -import Proteome.BufEnter (bufEnter) -import Proteome.Project.Activate (proNext, proPrev) +import Proteome.Data.AddItem (AddItem) +import Proteome.Data.CurrentTag (CurrentTag) +import Proteome.Data.Env (Env) +import Proteome.Data.FilesState (FilesState) +import Proteome.Data.GrepOutputLine (GrepOutputLine) +import Proteome.Data.ListedBuffer (ListedBuffer) +import Proteome.Data.PersistBuffers (PersistBuffers) +import Proteome.Data.ResolveError (ResolveError) import Proteome.Diag (proDiag) +import Proteome.Filename (proCopy, proMove, proRemove) +import Proteome.Files (proFiles) +import Proteome.Grep (proGrep, proGrepIn, proGrepList, proGrepOpt, proGrepOptIn) +import Proteome.Grep.Replace (proReplaceQuit, proReplaceSave) +import Proteome.Init (proLoad, proLoadAfter, projectConfig, projectConfigAfter, resolveAndInitMain) +import Proteome.PersistBuffers (LoadBuffersLock, StoreBuffersLock, loadBuffers) +import Proteome.Project.Activate (proNext, proPrev) +import Proteome.Quit (proQuit) +import Proteome.Save (proSave) +import Proteome.Tags.Cycle (proNextTag) +import Proteome.Tags.Gen (TagsLock, proGenTags) +import Proteome.Tags.Menu (proTag, proTags) +import Proteome.Tags.State (TagsState) -plugin' :: Ribosome (TVar Env) -> Plugin (Ribosome (TVar Env)) -plugin' env = - Plugin { - environment = env, - exports = [ - $(function' 'proteomePoll) Sync, - $(function' 'proteomeStage1) Async, - $(function' 'proteomeStage2) Async, - $(function' 'proteomeStage4) Async, - $(function "ProAddProject" 'proAdd) Sync, - $(command "ProAdd" 'proAddCmd) [CmdBang], - $(function' 'proSave) Async, - $(function' 'proTags) Async, - $(command' 'proNext) [], - $(command' 'proPrev) [], - $(function' 'proReadConfig) Sync, - $(command' 'proDiag) [], - $(autocmd 'bufEnter) "BufEnter" def - ] - } +type ProteomeStack = + [ + AtomicState Env, + AtomicState (Maybe CurrentTag), + Lock @@ LoadBuffersLock, + Lock @@ StoreBuffersLock, + Lock @@ TagsLock, + Lock @@ Mru + ] -plugin :: Neovim (StartupConfig NeovimConfig) NeovimPlugin -plugin = do - env <- initialize - wrapPlugin $ plugin' env +type ProteomeProdStack = + [ + Persist PersistBuffers !! PersistError, + PersistPath !! PersistPathError, + ModalWindowMenus () AddItem !! RpcError, + ModalWindowMenus () ListedBuffer !! RpcError, + ModalWindowMenus () GrepOutputLine !! RpcError, + WindowMenus () FilesState !! RpcError, + WindowMenus () TagsState !! RpcError + ] ++ NvimMenus ++ ProteomeStack + +handlers :: + Members ProteomeProdStack r => + Members [Settings !! SettingError, Scratch !! RpcError, Rpc !! RpcError, Reports, Reader PluginName] r => + Members ConcStack r => + Members [DataLog LogReport, ChronosTime, Log, Mask Restoration, Race, Resource, Async, Embed IO, Final IO] r => + [RpcHandler r] +handlers = + rpc "ProDiag" Async proDiag + <> + rpc "ProSave" Async proSave + <> + rpc "ProGenTags" Async proGenTags + <> + rpc "ProTags" Async proTags + <> + rpc "ProTag" Async proTag + <> + rpc "ProNextTag" Async proNextTag + <> + rpc "ProGrep" Async proGrep + <> + rpc "ProGrepIn" Async proGrepIn + <> + rpc "ProGrepOpt" Async proGrepOpt + <> + rpc "ProGrepOptIn" Async proGrepOptIn + <> + rpc "ProReplaceSave" Async proReplaceSave + <> + rpc "ProReplaceQuit" Async proReplaceQuit + <> + rpc "ProBuffers" Async proBuffers + <> + rpc "ProFiles" Async proFiles + <> + rpc "ProPrev" Async proPrev + <> + rpc "ProNext" Async proNext + <> + rpc "ProReadConfig" Async proReadConfig + <> + rpc "ProLoad" Async proLoad + <> + rpc "ProLoadAfter" Async proLoadAfter + <> + [ + rpcFunction "ProGrepList" Sync proGrepList, + rpcFunction "ProAdd" Async proAdd, + rpcCommand "ProAdd" Async proAddCmd, + rpcCommand "ProAddMenu" Async proAddMenu, + completeBuiltin "file" (rpcCommand "ProMove" Async proMove), + completeBuiltin "file" (rpcCommand "ProCopy" Async proCopy), + rpcCommand "ProRemove" Async proRemove, + rpcAutocmd "BufEnter" Async "BufEnter" def bufEnter, + rpcAutocmd "ProSave" Async "BufWritePost" def proSave, + -- If this is Async, Neovim quits before the handler has run + rpcAutocmd "ProQuit" Sync "VimLeave" def proQuit + ] + +resolveError :: + Member (DataLog LogReport) r => + Sem (Stop ResolveError : r) () -> + Sem r () +resolveError sem = + runStop sem >>= \case + Left e -> + logReport e + Right () -> + unit + +prepare :: + Members [Persist PersistBuffers !! PersistError, Log, Resource, Embed IO] r => + Members [AtomicState Env, Settings !! SettingError, Rpc !! RpcError, Lock @@ LoadBuffersLock, DataLog LogReport] r => + Sem r () +prepare = do + resolveError $ resumeLogReport @Settings $ resumeLogReport @Rpc do + resolveAndInitMain + resumeLogReport @(Persist _) (resumeLogReport @Rpc loadBuffers) + resumeLogReport @Rpc projectConfig + resumeLogReport @Rpc projectConfigAfter + +interpretProteomeStack :: + Members [Race, Resource, Mask Restoration, Embed IO] r => + InterpretersFor ProteomeStack r +interpretProteomeStack = + interpretLockReentrant . untag . + interpretLockReentrant . untag . + interpretLockReentrant . untag . + interpretLockReentrant . untag . + interpretAtomic def . + interpretAtomic def + +interpretProteomeProdStack :: + Member (EventConsumer eres Event) r => + Members [Rpc !! RpcError, Settings !! SettingError, Scratch !! RpcError, Reader PluginName, DataLog LogReport] r => + Members [Error BootError, Race, Log, Resource, Mask Restoration, Async, Embed IO, Final IO] r => + InterpretersFor ProteomeProdStack r +interpretProteomeProdStack = + interpretProteomeStack . + interpretWindowMenu . + interpretMenus . + interpretMenus . + interpretMenus . + interpretMenus . + interpretMenus . + interpretPersistPath True . + interpretPersist "buffers" . + withAsync_ prepare + +proteome :: IO () +proteome = + runNvimPluginIO @ProteomeProdStack "proteome" interpretProteomeProdStack handlers diff --git a/lib/Proteome/Project.hs b/lib/Proteome/Project.hs --- a/lib/Proteome/Project.hs +++ b/lib/Proteome/Project.hs @@ -1,40 +1,35 @@ -module Proteome.Project( - allProjects, - currentProject, - pathData, -) where +module Proteome.Project where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Safe (atMay) -import System.Directory (makeAbsolute) -import System.FilePath (takeFileName, takeDirectory) -import qualified Ribosome.Control.Ribo as Ribo (inspect) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project ( - Project, - ProjectName(..), - ProjectRoot(..), - ProjectType(..), - ) -import Proteome.Data.Env (Env(mainProject, projects, currentProjectIndex)) +import qualified Control.Lens as Lens (element, firstOf) +import Path (Abs, Dir, Path, dirname, parent) -allProjects :: Proteome [Project] +import Proteome.Data.Env (Env) +import qualified Proteome.Data.Env as Env (currentProjectIndex, mainProject, projects) +import Proteome.Data.Project (Project) +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot)) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) +import Proteome.Path (dropSlash) + +allProjects :: + Member (AtomicState Env) r => + Sem r [Project] allProjects = do - main <- Ribo.inspect mainProject - extra <- Ribo.inspect projects - return $ main : extra + main <- atomicGets Env.mainProject + extra <- atomicGets Env.projects + pure $ main : extra -currentProject :: Proteome (Maybe Project) +currentProject :: + Member (AtomicState Env) r => + Sem r (Maybe Project) currentProject = do - index <- Ribo.inspect currentProjectIndex - pros <- allProjects - return $ atMay pros index + index <- atomicGets Env.currentProjectIndex + Lens.firstOf (Lens.element index) <$> allProjects -pathData :: MonadIO m => FilePath -> m (ProjectRoot, ProjectName, ProjectType) -pathData root = do - absMainDir <- liftIO $ makeAbsolute root - return ( - ProjectRoot absMainDir, - ProjectName $ takeFileName absMainDir, - ProjectType $ (takeFileName . takeDirectory) absMainDir - ) +pathData :: Path Abs Dir -> (ProjectRoot, ProjectName, ProjectType) +pathData root = + ( + ProjectRoot root, + ProjectName . dropSlash . dirname $ root, + ProjectType . dropSlash . dirname . parent $ root + ) 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 @@ -1,85 +1,101 @@ -module Proteome.Project.Activate( - activateProject, - activateCurrentProject, - proPrev, - proNext, - selectProject, -) where +module Proteome.Project.Activate where -import qualified Control.Lens as Lens (over, set) -import Control.Monad (when) -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (fromMaybe) -import System.Directory (doesDirectoryExist) -import Neovim (vim_command', CommandArguments, Neovim) -import Ribosome.Config.Setting (updateSetting) -import Ribosome.Control.Ribo (Ribo) -import qualified Ribosome.Control.Ribo as Ribo (modify) -import Proteome.Data.Project ( - Project(Project, meta), - ProjectMetadata(DirProject, VirtualProject), - ProjectType(ProjectType), - ProjectRoot(ProjectRoot), - ProjectName(ProjectName), - ) -import Proteome.Data.ActiveProject (ActiveProject(ActiveProject)) -import Proteome.Data.Proteome (Proteome) -import Proteome.Project (currentProject, allProjects) -import qualified Proteome.Data.Env as Env (_currentProjectIndex) -import qualified Proteome.Settings as S (active) +import Exon (exon) +import Path.IO (doesDirExist) +import Ribosome (Handler, Rpc, RpcError, SettingError, Settings, pathText, resumeReport) +import Ribosome.Api (echo, nvimCommand) +import Ribosome.Data.PluginName (PluginName) +import qualified Ribosome.Settings as Settings +import Proteome.Data.ActiveProject (ActiveProject (ActiveProject)) +import Proteome.Data.Env (Env) +import Proteome.Data.Project (Project (Project)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject, VirtualProject)) +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot)) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) +import Proteome.Project (allProjects, currentProject) +import qualified Proteome.Settings as Settings + activeProject :: Project -> ActiveProject activeProject (Project (DirProject name _ tpe) _ lang _) = ActiveProject name (fromMaybe (ProjectType "none") tpe) lang activeProject (Project (VirtualProject name) _ lang _) = ActiveProject name (ProjectType "virtual") lang -activateDirProject :: ProjectMetadata -> Ribo e () +activateDirProject :: + Members [Rpc, Embed IO] r => + ProjectMetadata -> + Sem r () activateDirProject (DirProject _ (ProjectRoot root) _) = do - exists <- liftIO $ doesDirectoryExist root - when exists $ vim_command' $ "chdir " ++ root -activateDirProject _ = return () + whenM (doesDirExist root) do + nvimCommand [exon|chdir #{pathText root}|] +activateDirProject _ = + unit -activateProject :: Project -> Ribo e () -activateProject project = do - updateSetting S.active $ activeProject project - activateDirProject (meta project) +activateProject :: + Members [Settings, Rpc, Embed IO] r => + Project -> + Sem r () +activateProject project@(Project meta _ _ _) = do + Settings.update Settings.active (activeProject project) + activateDirProject meta -describeProject :: ProjectMetadata -> String -describeProject (DirProject (ProjectName name) _ (Just (ProjectType tpe))) = tpe ++ "/" ++ name +describeProject :: ProjectMetadata -> Text +describeProject (DirProject (ProjectName name) _ (Just (ProjectType tpe))) = tpe <> "/" <> name describeProject (DirProject (ProjectName name) _ Nothing) = name describeProject (VirtualProject (ProjectName name)) = name -echoProjectActivation :: Project -> Neovim e () -echoProjectActivation pro = - vim_command' $ "echo 'activated project " ++ describeProject (meta pro) ++ "'" +echoProjectActivation :: + Members [Reader PluginName, Rpc] r => + Project -> + Sem r () +echoProjectActivation (Project meta _ _ _) = + echo [exon|activated project #{describeProject meta}|] -activateCurrentProject :: Proteome () +activateCurrentProject :: + Members [Settings, AtomicState Env, Reader PluginName, Rpc, Embed IO] r => + Sem r () activateCurrentProject = do pro <- currentProject mapM_ activateProject pro mapM_ echoProjectActivation pro -setProjectIndex :: Int -> Proteome () +setProjectIndex :: + Member (AtomicState Env) r => + Int -> + Sem r () setProjectIndex index = do pros <- allProjects - Ribo.modify $ Lens.set Env._currentProjectIndex $ index `mod` length pros + for_ (index `mod` length pros) \ i -> + atomicModify' (#currentProjectIndex .~ i) -cycleProjectIndex :: (Int -> Int) -> Proteome () +cycleProjectIndex :: + Member (AtomicState Env) r => + (Int -> Int) -> + Sem r () cycleProjectIndex f = do pros <- allProjects - let trans a = f a `rem` length pros - Ribo.modify $ Lens.over Env._currentProjectIndex trans + atomicModify' $ #currentProjectIndex %~ \ i -> fromMaybe i (f i `rem` length pros) -selectProject :: Int -> Proteome () +selectProject :: + Members [Settings, AtomicState Env, Reader PluginName, Rpc, Embed IO] r => + Int -> + Sem r () selectProject index = do setProjectIndex index activateCurrentProject -proPrev :: CommandArguments -> Proteome () -proPrev _ = do - cycleProjectIndex (subtract 1) - activateCurrentProject +proPrev :: + Members [Settings !! SettingError, AtomicState Env, Reader PluginName, Rpc !! RpcError, Embed IO] r => + Handler r () +proPrev = + resumeReport @Rpc $ resumeReport @Settings do + cycleProjectIndex (subtract 1) + activateCurrentProject -proNext :: CommandArguments -> Proteome () -proNext _ = do - cycleProjectIndex (+1) - activateCurrentProject +proNext :: + Members [Settings !! SettingError, AtomicState Env, Reader PluginName, Rpc !! RpcError, Embed IO] r => + Handler r () +proNext = + resumeReport @Rpc $ resumeReport @Settings do + cycleProjectIndex (+1) + activateCurrentProject diff --git a/lib/Proteome/Project/Resolve.hs b/lib/Proteome/Project/Resolve.hs --- a/lib/Proteome/Project/Resolve.hs +++ b/lib/Proteome/Project/Resolve.hs @@ -1,39 +1,37 @@ -{-# LANGUAGE NamedFieldPuns #-} +module Proteome.Project.Resolve where -module Proteome.Project.Resolve( - resolveProject, - resolveProjectFromConfig, -) where +import Control.Monad (foldM) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Data.List (nub) +import Data.List.Extra (firstJust) +import Data.Map.Strict ((!?)) +import qualified Data.Map.Strict as Map (toList, union) +import Exon (exon) +import qualified Log +import Path (Abs, Dir, Path, dirname, isProperPrefixOf, parent, parseRelDir, stripProperPrefix, toFilePath, ()) +import Path.IO (doesDirExist) +import Ribosome (Settings) +import qualified Ribosome.Settings as Settings +import System.FilePath.Glob (globDir1) +import qualified System.FilePath.Glob as Glob (compile) +import System.FilePattern.Directory (getDirectoryFiles) -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, isJust) -import Data.Map.Strict ((!?), Map) -import Safe (headMay) -import System.Directory (doesDirectoryExist) -import System.FilePath (takeDirectory, ()) -import System.Path.Glob (glob) -import Ribosome.File (canonicalPaths) -import Ribosome.Config.Setting (setting) -import Ribosome.Data.Foldable (findMapMaybeM) -import Ribosome.Data.Maybe (orElse) -import Ribosome.Control.Ribo (Ribo) -import Proteome.Config (ProjectConfig(ProjectConfig)) -import Proteome.Data.Project ( - Project(Project), - ProjectName(..), - ProjectRoot(..), - ProjectType(..), - ProjectLang(..), - ProjectMetadata(DirProject, VirtualProject), - ) -import Proteome.Data.ProjectSpec (ProjectSpec(ProjectSpec)) -import qualified Proteome.Data.ProjectSpec as PS (ProjectSpec(..)) +import Proteome.Config (defaultTypeMarkers) +import Proteome.Data.Project (Project (Project)) +import qualified Proteome.Data.ProjectConfig as ProjectConfig +import Proteome.Data.ProjectConfig (ProjectConfig (ProjectConfig)) +import Proteome.Data.ProjectLang (ProjectLang (ProjectLang)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject, VirtualProject)) +import Proteome.Data.ProjectName (ProjectName (ProjectName)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot), unProjectRoot) +import Proteome.Data.ProjectSpec (ProjectSpec (ProjectSpec)) +import qualified Proteome.Data.ProjectSpec as PS (ProjectSpec (..)) +import Proteome.Data.ProjectType (ProjectType (ProjectType)) +import qualified Proteome.Data.ResolveError as ResolveError (ResolveError (..)) +import Proteome.Data.ResolveError (ResolveError) +import Proteome.Path (dropSlash, parseAbsDirMaybe, rootPathSegment) import Proteome.Project (pathData) -import qualified Proteome.Settings as S +import qualified Proteome.Settings as Settings (projectConfig, projects) projectFromSegments :: ProjectType -> ProjectName -> ProjectRoot -> Project projectFromSegments tpe name root = @@ -54,103 +52,270 @@ byProjectTypeName :: [ProjectSpec] -> ProjectName -> ProjectType -> Maybe ProjectSpec byProjectTypeName specs name tpe = find (hasProjectTypeName tpe name) specs -matchProjectBases :: [FilePath] -> ProjectRoot -> Bool -matchProjectBases baseDirs (ProjectRoot root) = (takeDirectory . takeDirectory) root `elem` baseDirs +matchProjectBases :: [Path Abs Dir] -> ProjectRoot -> Bool +matchProjectBases baseDirs (ProjectRoot root) = (parent . parent) root `elem` baseDirs -byProjectBaseSubpath :: ProjectName -> ProjectType -> FilePath -> IO (Maybe Project) +byProjectBaseSubpath :: + Members [Stop ResolveError, Embed IO] r => + ProjectName -> + ProjectType -> + Path Abs Dir -> + Sem r (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 + tpePath <- stopEitherAs (ResolveError.ParsePath tpe) $ parseRelDir (toString tpe) + namePath <- stopEitherAs (ResolveError.ParsePath name) $ parseRelDir (toString name) + let root = base tpePath namePath + exists <- doesDirExist root + pure $ if exists then Just $ projectFromSegments t n (ProjectRoot root) else Nothing -byProjectBasesSubpath :: [FilePath] -> ProjectName -> ProjectType -> IO (Maybe Project) +byProjectBasesSubpath :: + Members [Stop ResolveError, Embed IO] r => + [Path Abs Dir] -> + ProjectName -> + ProjectType -> + Sem r (Maybe Project) byProjectBasesSubpath baseDirs name tpe = foldM subpath Nothing baseDirs where - subpath (Just p) _ = return (Just p) + subpath (Just p) _ = pure (Just p) subpath Nothing a = byProjectBaseSubpath name tpe a virtualProject :: ProjectName -> Project -virtualProject name = Project (VirtualProject name) [] Nothing [] +virtualProject name = + Project (VirtualProject name) [] Nothing [] -resolveByTypeAndPath :: [FilePath] -> ProjectName -> ProjectType -> ProjectRoot -> Maybe Project +resolveByTypeAndPath :: [Path Abs Dir] -> 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 +resolveByType :: + Members [Stop ResolveError, Embed IO] r => + [Path Abs Dir] -> + [ProjectSpec] -> + ProjectName -> + ProjectType -> + Sem r (Maybe Project) +resolveByType baseDirs explicit name tpe = do byBaseSubpath <- byProjectBasesSubpath baseDirs name tpe - return $ orElse (orElse byPath byBaseSubpath) (fmap projectFromSpec byTypeName) + pure (byBaseSubpath <|> projectFromSpec <$> byTypeName) where - byTypeName = byProjectTypeName explicit name tpe - byPath = root >>= resolveByTypeAndPath baseDirs name tpe + byTypeName = + byProjectTypeName explicit name tpe -fromProjectRoot :: FilePath -> IO Project -fromProjectRoot dir = do - (root, name, tpe) <- pathData dir - return $ projectFromSegments tpe name root +fromProjectRoot :: Path Abs Dir -> Project +fromProjectRoot dir = + projectFromSegments tpe name root + where + (root, name, tpe) = pathData dir -projectFromNameIn :: ProjectName -> FilePath -> IO (Maybe Project) -projectFromNameIn (ProjectName name) base = do - candidates <- glob $ base ++ "/*/" ++ name - mapM fromProjectRoot (headMay candidates) +projectFromNameIn :: + Members [Stop ResolveError, Embed IO] r => + ProjectName -> + Path Abs Dir -> + Sem r (Maybe Project) +projectFromNameIn (ProjectName name) base = + fmap fromProjectRoot . join . find isJust <$> matches + where + matches = + fmap (parseAbsDirMaybe . toText) <$> glob + glob = + embed $ globDir1 (Glob.compile ("*/" <> toString name)) (toFilePath base) -resolveByName :: [FilePath] -> ProjectName -> IO (Maybe Project) +resolveByName :: + Members [Stop ResolveError, Embed IO] r => + [Path Abs Dir] -> + ProjectName -> + Sem r (Maybe Project) resolveByName baseDirs name = - findMapMaybeM (projectFromNameIn name) baseDirs + firstJustM (projectFromNameIn name) baseDirs -resolveByRoot :: [ProjectSpec] -> ProjectRoot -> Maybe Project -resolveByRoot explicit root = - fmap projectFromSpec byRoot +globDir :: + Members [Stop ResolveError, Embed IO] r => + Path Abs Dir -> + [Text] -> + Sem r (Maybe FilePath) +globDir root patterns = + (head =<<) <$> tryMaybe (getDirectoryFiles (toFilePath root) (toString <$> patterns)) + +resolveFromDirContents :: + Members [Stop ResolveError, Embed IO] r => + Map ProjectType [Text] -> + ProjectName -> + ProjectRoot -> + Sem r (Maybe Project) +resolveFromDirContents typeMarkers name projectRoot@(ProjectRoot root) = + fmap cons <$> firstJustM match (Map.toList typeMarkers) where - byRoot = find (hasProjectRoot root) explicit + cons projectType = + projectFromSegments projectType name projectRoot + match (tpe, patterns) = + (tpe <$) <$> globDir root patterns -augment :: (Eq a, Ord k) => Map k [a] -> k -> [a] -> [a] +resolveByRoot :: + Members [Stop ResolveError, Embed IO] r => + ProjectConfig -> + ProjectName -> + [ProjectSpec] -> + ProjectRoot -> + Sem r (Maybe Project) +resolveByRoot (ProjectConfig _ _ _ _ typeMarkers _ _) name explicit root = + maybe (resolveFromDirContents typeMarkers name root) (pure . Just . projectFromSpec) fromExplicit + where + fromExplicit = find (hasProjectRoot root) explicit + +augment :: + Eq a => + Ord k => + Map k [a] -> + k -> + [a] -> + [a] augment m tpe as = case m !? tpe of - Just extra -> uniq $ as ++ extra + Just extra -> nub $ as ++ extra Nothing -> as augmentTypes :: ProjectConfig -> ProjectType -> [ProjectType] -> [ProjectType] -augmentTypes (ProjectConfig _ typeMap _ _) = +augmentTypes (ProjectConfig _ _ _ typeMap _ _ _) = augment typeMap -realLang :: ProjectConfig -> ProjectType -> ProjectLang -realLang (ProjectConfig _ _ langMap _) t@(ProjectType tpe) = +resolveLanguage :: ProjectConfig -> ProjectType -> ProjectLang +resolveLanguage (ProjectConfig _ _ _ _ _ langMap _) t@(ProjectType tpe) = fromMaybe (ProjectLang tpe) (langMap !? t) augmentLangs :: ProjectConfig -> ProjectLang -> [ProjectLang] -> [ProjectLang] -augmentLangs (ProjectConfig _ _ _ langsMap) = +augmentLangs (ProjectConfig _ _ _ _ _ _ langsMap) = augment langsMap augmentFromConfig :: ProjectConfig -> Project -> Project augmentFromConfig config (Project meta@(DirProject _ _ (Just tpe)) types lang langs) = - Project meta (augmentTypes config tpe types) (Just realLang') (augmentLangs config realLang' langs) + Project meta (augmentTypes config tpe types) (Just lang') (augmentLangs config lang' langs) where - realLang' = fromMaybe (realLang config tpe) lang -augmentFromConfig _ project = project + lang' = fromMaybe (resolveLanguage config tpe) lang +augmentFromConfig _ project = + project -resolveProject :: - [FilePath] -> +fromName :: + Members [Stop ResolveError, Log, Embed IO] r => [ProjectSpec] -> ProjectConfig -> - Maybe ProjectRoot -> ProjectName -> Maybe ProjectType -> - IO Project -resolveProject baseDirs explicit config root name tpe = do - byType <- traverse (resolveByType baseDirs explicit root name) tpe - byName <- if isJust root then return Nothing else resolveByName baseDirs name + Sem r Project +fromName explicit config name tpe = do + let baseDirs = ProjectConfig.baseDirs config + byType <- join <$> traverse (resolveByType baseDirs explicit name) tpe + byName <- resolveByName baseDirs name let byNameOrVirtual = fromMaybe (virtualProject name) byName - let byTypeOrName = fromMaybe byNameOrVirtual (join byType) - let byRoot = root >>= resolveByRoot explicit - let project = fromMaybe byTypeOrName byRoot - return $ augmentFromConfig config project + let project = fromMaybe byNameOrVirtual byType + Log.debug (logMsg byType byName) + pure (augmentFromConfig config project) + where + logMsg byType byName = + [exon|resolved project: byType(#{show byType}) byName(#{show byName})|] -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 +fromNameSettings :: + Members [Settings, Stop ResolveError, Log, Embed IO] r => + ProjectName -> + Maybe ProjectType -> + Sem r Project +fromNameSettings name tpe = do + explicit <- Settings.get Settings.projects + config <- projectConfig + fromName explicit config name tpe + +projectConfig :: + Member Settings r => + Sem r ProjectConfig +projectConfig = + (#typeMarkers %~ (`Map.union` defaultTypeMarkers)) <$> Settings.get Settings.projectConfig + +rootExplicit :: [ProjectSpec] -> ProjectRoot -> Maybe Project +rootExplicit explicit root = + projectFromSpec <$> find (hasProjectRoot root) explicit + +rootProjectTypes :: + Map ProjectType [Path Abs Dir] -> + ProjectName -> + ProjectRoot -> + Maybe Project +rootProjectTypes tpes name root@(ProjectRoot rootDir) = + cons . fst <$> find (elem rootDir . snd) (Map.toList tpes) + where + cons tpe = + projectFromSegments tpe name root + +rootTypeDirs :: + Map ProjectType [Path Abs Dir] -> + ProjectName -> + ProjectRoot -> + Maybe Project +rootTypeDirs types name root@(ProjectRoot rootDir) = + cons . fst <$> find (matchType . snd) (Map.toList types) + where + cons tpe = + projectFromSegments tpe name root + matchType = + any match + match base = do + isProperPrefixOf base rootDir + +rootBaseDirs :: + [Path Abs Dir] -> + ProjectName -> + ProjectRoot -> + Maybe Project +rootBaseDirs bases name root@(ProjectRoot rootDir) = + firstJust match bases + where + match base = do + rel <- stripProperPrefix base rootDir + let tpe = rootPathSegment (parent rel) + if rel /= tpe + then Just (projectFromSegments (ProjectType (dropSlash tpe)) name root) + else Nothing + +projectName :: ProjectRoot -> ProjectName +projectName = + ProjectName . dropSlash . dirname . unProjectRoot + +firstJustMOr :: + Monad m => + a -> + [m (Maybe a)] -> + m a +firstJustMOr fallback = + fmap (fromMaybe fallback) . runMaybeT . asum @[] . fmap MaybeT + +fromRoot :: + Members [Stop ResolveError, Embed IO] r => + [ProjectSpec] -> + ProjectConfig -> + ProjectRoot -> + Sem r Project +fromRoot explicit config@ProjectConfig {..} root = do + let + byRoot = + asum @[] [ + rootExplicit explicit root, + rootProjectTypes projectTypes name root, + rootTypeDirs typeDirs name root, + rootBaseDirs baseDirs name root + ] + project <- firstJustMOr (virtualProject name) [ + pure byRoot, + resolveFromDirContents typeMarkers name root + ] + pure (augmentFromConfig config project) + where + name = + projectName root + +fromRootSettings :: + Members [Settings, Stop ResolveError, Embed IO] r => + ProjectRoot -> + Sem r Project +fromRootSettings root = do + explicit <- Settings.get Settings.projects + config <- projectConfig + fromRoot explicit config root diff --git a/lib/Proteome/Quit.hs b/lib/Proteome/Quit.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Quit.hs @@ -0,0 +1,17 @@ +module Proteome.Quit where + +import Conc (Lock) +import Ribosome (Handler, PersistError, Rpc, RpcError, resumeReport) +import Ribosome.Effect.Persist (Persist) + +import Proteome.Data.Env (Env) +import Proteome.Data.PersistBuffers (PersistBuffers) +import Proteome.PersistBuffers (StoreBuffersLock, storeBuffers) + +proQuit :: + Member (Persist PersistBuffers !! PersistError) r => + Members [Lock @@ StoreBuffersLock, AtomicState Env, Rpc !! RpcError, Resource, Embed IO] r => + Handler r () +proQuit = + resumeReport @(Persist _) $ resumeReport @Rpc do + storeBuffers diff --git a/lib/Proteome/Save.hs b/lib/Proteome/Save.hs --- a/lib/Proteome/Save.hs +++ b/lib/Proteome/Save.hs @@ -1,12 +1,19 @@ -module Proteome.Save( - proSave, -) where +module Proteome.Save where -import Proteome.Data.Proteome (Proteome) -import Proteome.Tags (proTags) -import Proteome.PersistBuffers (storeBuffers) +import Conc (Lock) +import Ribosome (Reports, Handler, LogReport, PersistError, Rpc, RpcError, SettingError, Settings, resumeReport) +import Ribosome.Effect.Persist (Persist) -proSave :: Proteome () +import Proteome.Data.Env (Env) +import Proteome.Data.PersistBuffers (PersistBuffers) +import Proteome.PersistBuffers (StoreBuffersLock, storeBuffers) +import Proteome.Tags.Gen (TagsLock, proGenTags) + +proSave :: + Member (Persist PersistBuffers !! PersistError) r => + Members [Settings !! SettingError, AtomicState Env, Lock @@ TagsLock, DataLog LogReport] r => + Members [Lock @@ StoreBuffersLock, AtomicState Env, Rpc !! RpcError, Reports, Resource, Log, Async, Embed IO] r => + Handler r () proSave = do - proTags - storeBuffers + proGenTags + resumeReport @Rpc $ resumeReport @(Persist _) $ storeBuffers diff --git a/lib/Proteome/Settings.hs b/lib/Proteome/Settings.hs --- a/lib/Proteome/Settings.hs +++ b/lib/Proteome/Settings.hs @@ -1,39 +1,22 @@ -module Proteome.Settings( - mainProjectDir, - projects, - projectTypeDirs, - projectBaseDirs, - projectConfig, - mainName, - mainType, - tagsCommand, - tagsArgs, - tagsFork, - tagsFileName, - active, -) where +module Proteome.Settings where -import Data.Default.Class (Default(def)) -import Ribosome.Config.Setting -import Proteome.Data.Project (ProjectName, ProjectType) +import Path (Abs, Dir, File, Path, Rel, relfile) +import Ribosome.Data.Setting (Setting (Setting)) + import Proteome.Data.ActiveProject (ActiveProject) +import Proteome.Data.ProjectConfig (ProjectConfig (ProjectConfig)) +import Proteome.Data.ProjectName (ProjectName) import Proteome.Data.ProjectSpec (ProjectSpec) -import Proteome.Config +import Proteome.Data.ProjectType (ProjectType) -mainProjectDir :: Setting String +mainProjectDir :: Setting (Path Abs Dir) mainProjectDir = Setting "main_project_dir" True Nothing projects :: Setting [ProjectSpec] projects = Setting "projects" True (Just []) -projectBaseDirs :: Setting [FilePath] -projectBaseDirs = Setting "project_base_dirs" True (Just []) - -projectTypeDirs :: Setting [FilePath] -projectTypeDirs = Setting "project_type_dirs" True (Just []) - projectConfig :: Setting ProjectConfig -projectConfig = Setting "project_config" True (Just (ProjectConfig def def def def)) +projectConfig = Setting "project_config" True (Just (ProjectConfig def def def def def def def)) mainName :: Setting ProjectName mainName = Setting "main_name" True Nothing @@ -44,14 +27,45 @@ active :: Setting ActiveProject active = Setting "active" True Nothing -tagsCommand :: Setting String +tagsEnable :: Setting Bool +tagsEnable = Setting "tags_enable" True (Just True) + +tagsCommand :: Setting Text tagsCommand = Setting "tags_command" True (Just "ctags") -tagsArgs :: Setting String +tagsArgs :: Setting Text tagsArgs = Setting "tags_args" True (Just "-R --languages={langsComma} -f {tagFile} {root}") tagsFork :: Setting Bool tagsFork = Setting "tags_fork" True (Just True) -tagsFileName :: Setting FilePath -tagsFileName = Setting "tags_file_name" True (Just ".tags") +tagsFileName :: Setting (Path Rel File) +tagsFileName = Setting "tags_file_name" True (Just [relfile|.tags|]) + +grepCmdline :: Setting Text +grepCmdline = + Setting "grep_cmdline" True Nothing + +filesUseRg :: Setting Bool +filesUseRg = + Setting "files_use_rg" True (Just True) + +filesExcludeHidden :: Setting Bool +filesExcludeHidden = + Setting "files_exclude_hidden" True (Just True) + +filesExcludeFiles :: Setting [Text] +filesExcludeFiles = + Setting "files_exclude_files" True (Just []) + +filesExcludeDirectories :: Setting [Text] +filesExcludeDirectories = + Setting "files_exclude_directories" True (Just []) + +filesExcludeWildIgnore :: Setting Bool +filesExcludeWildIgnore = + Setting "files_exclude_wildignore" True (Just True) + +buffersCurrentLast :: Setting Bool +buffersCurrentLast = + Setting "buffers_current_last" True (Just False) diff --git a/lib/Proteome/System/Path.hs b/lib/Proteome/System/Path.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/System/Path.hs @@ -0,0 +1,20 @@ +module Proteome.System.Path where + +import Path (Abs, File, Path, parseRelFile) +import Path.IO (findExecutable) + +import Proteome.Data.GrepError (GrepError) +import qualified Proteome.Data.GrepError as GrepError (GrepError (NoSuchExecutable, NotInPath)) + +findExe :: + Members [Stop GrepError, Embed IO] r => + Text -> + Sem r (Path Abs File) +findExe exe = do + path <- stopEitherAs parseError (parseRelFile (toString exe)) + stopNote notInPath =<< findExecutable path + where + parseError = + GrepError.NoSuchExecutable exe + notInPath = + GrepError.NotInPath exe diff --git a/lib/Proteome/Tags.hs b/lib/Proteome/Tags.hs deleted file mode 100644 --- a/lib/Proteome/Tags.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Proteome.Tags( - proTags, - tagsCommand, -) where - -import GHC.IO.Exception (ExitCode(..)) -import Control.Monad (when) -import Control.Monad.IO.Class (liftIO) -import Control.Lens (over) -import Data.Foldable (traverse_) -import Data.List (intercalate) -import qualified Data.Map.Strict as Map (adjust) -import Data.Maybe (maybeToList) -import Data.String.Utils (replace) -import System.Process (readCreateProcessWithExitCode) -import qualified System.Process as Proc (proc, CreateProcess(cwd)) -import System.FilePath (()) -import System.Directory (doesFileExist, removePathForcibly, renameFile) -import UnliftIO (tryIO) -import Ribosome.Config.Setting (setting) -import Ribosome.Control.Ribo (lockOrSkip) -import qualified Ribosome.Control.Ribo as Ribo (inspect, modify) -import Ribosome.Data.Errors (Errors(Errors), Error(Error), ComponentName(ComponentName)) -import Ribosome.Internal.IO (forkNeovim) -import Proteome.Data.Env (Env(mainProject, projects)) -import qualified Proteome.Data.Env as Env (_errors) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project ( - Project (Project), - ProjectLang(ProjectLang), - ProjectRoot(ProjectRoot), - ProjectMetadata (DirProject), - langOrType, - ) -import qualified Proteome.Settings as S (tagsCommand, tagsArgs, tagsFork, tagsFileName) -import qualified Proteome.Log as Log - -replaceFormatItem :: String -> (String, String) -> String -replaceFormatItem original (placeholder, replacement) = - replace ("{" ++ placeholder ++ "}") replacement original - -formatTagsArgs :: [ProjectLang] -> ProjectRoot -> FilePath -> String -> String -formatTagsArgs langs (ProjectRoot root) fileName formatString = - foldl replaceFormatItem formatString formats - where - formats = [ - ("langsComma", intercalate "," $ fmap (\(ProjectLang l) -> l) langs), - ("tagFile", root fileName), - ("root", root) - ] - -tempname :: String -> String -tempname name = name ++ ".tmp" - -deleteTags :: ProjectRoot -> Proteome () -deleteTags (ProjectRoot root) = do - name <- setting S.tagsFileName - let path = root tempname name - exists <- liftIO $ doesFileExist path - when exists $ liftIO $ removePathForcibly path - -replaceTags :: ProjectRoot -> Proteome () -replaceTags (ProjectRoot root) = do - name <- setting S.tagsFileName - let temppath = root tempname name - let path = root name - _ <- liftIO $ tryIO $ renameFile temppath path - return () - -storeError :: ComponentName -> [String] -> Errors -> Errors -storeError name msg (Errors errors) = - Errors (Map.adjust (err:) name errors) - where - err = Error time msg - time = 0 - -notifyError :: String -> Proteome () -notifyError e = do - Log.info $ "tags failed: " ++ e - Ribo.modify $ over Env._errors (storeError (ComponentName "ctags") [e]) - -tagsProcess :: ProjectRoot -> String -> String -> IO (ExitCode, String, String) -tagsProcess (ProjectRoot root) cmd args = - readCreateProcessWithExitCode (Proc.proc cmd (words args)) { Proc.cwd = Just root } "" - -executeTags :: ProjectRoot -> String -> String -> Proteome () -executeTags root@(ProjectRoot rootS) cmd args = do - deleteTags root - Log.debugS $ "executing tags: `" ++ cmd ++ " " ++ args ++ "` in directory " ++ rootS - (exitcode, _, stderr) <- liftIO $ tagsProcess root cmd args - case exitcode of - ExitSuccess -> replaceTags root - ExitFailure _ -> notifyError stderr - -tagsCommand :: ProjectRoot -> [ProjectLang] -> Proteome (String, String) -tagsCommand root langs = do - cmd <- setting S.tagsCommand - args <- setting S.tagsArgs - fileName <- setting S.tagsFileName - return (cmd, formatTagsArgs langs root (tempname fileName) args) - -regenerateTags :: ProjectRoot -> [ProjectLang] -> Proteome () -regenerateTags root langs = do - (cmd, args) <- tagsCommand root langs - let thunk = executeTags root cmd args - fork <- setting S.tagsFork - _ <- if fork then forkNeovim thunk else thunk - return () - -projectTags :: Project -> Proteome () -projectTags (Project (DirProject _ root tpe) _ lang langs) = - regenerateTags root (maybeToList (langOrType lang tpe) ++ langs) -projectTags _ = return () - -proTags :: Proteome () -proTags = do - main <- Ribo.inspect mainProject - extra <- Ribo.inspect projects - lockOrSkip "tags" $ traverse_ projectTags (main : extra) diff --git a/lib/Proteome/Tags/Cycle.hs b/lib/Proteome/Tags/Cycle.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Cycle.hs @@ -0,0 +1,96 @@ +module Proteome.Tags.Cycle where + +import qualified Data.List.NonEmpty.Zipper as Zipper +import Exon (exon) +import Log (Severity (Info)) +import Path (Abs, File, Path) +import Ribosome (Args (Args), Report (Report), Rpc, toMsgpack, Handler, RpcError, resumeReport) +import Ribosome.Api (currentBufferPath, currentLine, nvimCallFunction) + +import qualified Proteome.Data.CurrentTag as CurrentTag +import Proteome.Data.CurrentTag (pattern CurrentLoc, CurrentTag (CurrentTag), cycleLoc) +import Proteome.Data.Env (Env) +import Proteome.Tags.Nav (loadOrEdit) +import Proteome.Tags.Query (tagLocsPath) +import qualified Proteome.Tags.State as State +import Proteome.Tags.State (TagLoc (TagLoc)) + +nav :: + Member Rpc r => + CurrentTag -> + Sem r () +nav (CurrentLoc TagLoc {..}) = + loadOrEdit path line + +continue :: + Member Rpc r => + CurrentTag -> + Text -> + Sem r Bool +continue CurrentTag {locations = Zipper.current -> TagLoc {..}} newName = do + bufLine <- currentLine + bufPath <- currentBufferPath + pure (elem path bufPath && bufLine == line && name == newName) + +cycle :: + Members [AtomicState (Maybe CurrentTag), Rpc] r => + CurrentTag -> + Sem r () +cycle cur = do + atomicPut (Just newCur) + nav newCur + where + newCur = + cur & #locations %~ cycleLoc + +storeAndNav :: + Members [AtomicState (Maybe CurrentTag), Rpc] r => + Text -> + NonEmpty (TagLoc (Path Abs File)) -> + Sem r () +storeAndNav name locs = do + atomicPut (Just cur) + nav cur + where + cur = + CurrentTag name (Zipper.fromNonEmpty locs) + +start :: + Members [AtomicState (Maybe CurrentTag), AtomicState Env, Rpc, Stop Report, Embed IO] r => + Text -> + Sem r () +start name = do + file <- currentBufferPath + tags <- nonEmpty <$> tagLocsPath (Just [exon|^#{name}$|]) file + maybe (stop (Report err [err] Info)) (storeAndNav name) tags + where + err = + [exon|No matching tag for #{name}|] + +nextTag :: + Members [AtomicState (Maybe CurrentTag), AtomicState Env, Rpc, Stop Report, Embed IO] r => + Text -> + Sem r () +nextTag name = + atomicGet >>= \case + Just cur -> + ifM (continue cur name) (cycle cur) (start name) + Nothing -> + start name + +cword :: + Member Rpc r => + Sem r Text +cword = + nvimCallFunction "expand" [toMsgpack @Text ""] + +proNextTag :: + Members [AtomicState (Maybe CurrentTag), AtomicState Env, Rpc !! RpcError, Embed IO] r => + Args -> + Handler r () +proNextTag = + resumeReport . \case + Args "" -> + nextTag =<< cword + Args name -> + nextTag name diff --git a/lib/Proteome/Tags/Gen.hs b/lib/Proteome/Tags/Gen.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Gen.hs @@ -0,0 +1,181 @@ +module Proteome.Tags.Gen where + +import Conc (Lock, lockOrSkip_) +import qualified Data.List as List +import Data.Sequence ((|>)) +import qualified Data.Text as Text (intercalate, replace) +import Exon (exon) +import GHC.IO.Exception (ExitCode (..)) +import qualified Log +import Log (Severity (Warn)) +import Path (File, Path, Rel, addExtension, toFilePath, ()) +import Path.IO (doesFileExist, removeFile, renameFile) +import Polysemy.Process (SysProcConf, SystemProcess, SystemProcessScopeError, interpretSystemProcessNativeSingle) +import qualified Polysemy.Process.SystemProcess as Process +import Ribosome ( + Handler, + LogReport, + Report (Report), + Reports, + SettingError, + Settings, + mapReport, + reportStop, + resumeReport, + ) +import Ribosome.Report (storeReport) +import qualified Ribosome.Settings as Settings +import System.Process.Typed (proc, setWorkingDir) + +import Proteome.Data.Env (Env) +import qualified Proteome.Data.Env as Env (mainProject, projects) +import Proteome.Data.Project (Project (Project), langOrType) +import Proteome.Data.ProjectLang (ProjectLang (unProjectLang)) +import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject)) +import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot)) +import qualified Proteome.Data.TagsError as TagsError +import Proteome.Data.TagsError (TagsError) +import qualified Proteome.Settings as Settings + +data TagsLock = + TagsLock + deriving stock (Eq, Show) + +replaceFormatItem :: Text -> (Text, Text) -> Text +replaceFormatItem original (placeholder, replacement) = + Text.replace ("{" <> placeholder <> "}") replacement original + +formatTagsArgs :: + [ProjectLang] -> + ProjectRoot -> + Path Rel File -> + Text -> + Text +formatTagsArgs langs (ProjectRoot root) fileName formatString = + foldl' @[] replaceFormatItem formatString formats + where + formats = [ + ("langsComma", Text.intercalate "," (fmap unProjectLang langs)), + ("tagFile", toText . toFilePath $ root fileName), + ("root", toText . toFilePath $ root) + ] + +tempname :: + Member (Stop TagsError) r => + Path Rel File -> + Sem r (Path Rel File) +tempname name = + stopEitherWith (const err) (addExtension ".tmp" name) + where + err = + TagsError.TempName + +deleteTempTags :: + Members [Settings !! SettingError, Stop TagsError, Embed IO] r => + ProjectRoot -> + Sem r () +deleteTempTags (ProjectRoot root) = do + name <- resumeHoist TagsError.Setting (Settings.get Settings.tagsFileName) + path <- (root ) <$> tempname name + whenM (doesFileExist path) do + tryAny_ (removeFile path) + +replaceTags :: + Members [Settings !! SettingError, Stop TagsError, Embed IO] r => + ProjectRoot -> + Sem r () +replaceTags (ProjectRoot root) = do + name <- resumeHoist TagsError.Setting (Settings.get Settings.tagsFileName) + temppath <- (root ) <$> tempname name + whenM (doesFileExist temppath) do + stopTryIOError TagsError.RenameTags (renameFile temppath (root name)) + +notifyError :: + Member Reports r => + [Text] -> + Sem r () +notifyError out = + storeReport "tags" (Report "tag generation failed" ("tag subprocess failed: " : out) Warn) + +tagsCommand :: + Members [Settings, Stop TagsError] r => + ProjectRoot -> + [ProjectLang] -> + Sem r (Text, Text) +tagsCommand root langs = do + cmd <- Settings.get Settings.tagsCommand + args <- Settings.get Settings.tagsArgs + fileName <- Settings.get Settings.tagsFileName + tmp <- tempname fileName + pure (cmd, formatTagsArgs langs root tmp args) + +tagsProcess :: + Members [Settings !! SettingError, Stop TagsError, Log] r => + ProjectRoot -> + [ProjectLang] -> + Sem r SysProcConf +tagsProcess projectRoot@(ProjectRoot root) langs = do + (cmd, args) <- resumeHoist TagsError.Setting (tagsCommand projectRoot langs) + Log.debug [exon|executing tags: `#{cmd} #{args}` in directory #{show root}|] + pure (setWorkingDir (toFilePath root) (proc (toString cmd) (List.words (toString args)))) + +readStderr :: + Member (SystemProcess !! err) r => + Sem r [Text] +readStderr = + spin mempty + where + spin buf = + resumeEither Process.readStderr >>= \case + Right l -> spin (buf |> decodeUtf8 l) + Left _ -> pure (toList buf) + +executeTags :: + Members [Settings !! SettingError, Reports, Stop TagsError, Log, Resource, Embed IO] r => + ProjectRoot -> + [ProjectLang] -> + Sem r () +executeTags projectRoot langs = do + deleteTempTags projectRoot + procConf <- tagsProcess projectRoot langs + mapStop @SystemProcessScopeError (TagsError.Process . show) $ interpretSystemProcessNativeSingle procConf do + resumeHoist (TagsError.Process . show) Process.wait >>= \case + ExitSuccess -> do + Log.debug "success" + replaceTags projectRoot + ExitFailure _ -> do + Log.debug "failure" + notifyError =<< readStderr + +projectTags :: + Members [Settings !! SettingError, Settings, Reports, Stop TagsError, Log, Resource, Embed IO] r => + Project -> + Sem r () +projectTags (Project (DirProject _ root tpe) _ lang langs) = + executeTags root (maybeToList (langOrType lang tpe) <> langs) +projectTags _ = + unit + +execution :: + Members [Settings !! SettingError, DataLog LogReport, Async, Stop Report] r => + Bool -> + Sem (Stop TagsError : r) () -> + Sem r () +execution = \case + True -> + void . async . reportStop + False -> + mapReport + +proGenTags :: + Members [AtomicState Env, Settings !! SettingError, DataLog LogReport, Lock @@ TagsLock, Reports] r => + Members [Log, Resource, Async, Embed IO] r => + Handler r () +proGenTags = + resumeReport @Settings $ whenM (Settings.get Settings.tagsEnable) do + main <- atomicGets Env.mainProject + extra <- atomicGets Env.projects + fork <- Settings.get Settings.tagsFork + execution fork $ tag $ lockOrSkip_ do + res <- sequenceConcurrently (runStop . projectTags <$> main : extra) + traverse (void . stopEither . fromMaybe unit) res diff --git a/lib/Proteome/Tags/Mappings.hs b/lib/Proteome/Tags/Mappings.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Mappings.hs @@ -0,0 +1,54 @@ +module Proteome.Tags.Mappings where + +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Exon (exon) +import Path (Abs, File, Path) +import Path.IO (doesFileExist) +import Ribosome (Rpc) +import Ribosome.Api (parseNvimFile) +import Ribosome.Host.Data.Report (ReportLog) +import qualified Ribosome.Menu as Menu +import Ribosome.Menu (Mappings, MenuWidget, menuOk, menuState, withFocus', (%=)) +import qualified Ribosome.Menu.Data.MenuAction as MenuAction +import Ribosome.Menu.MenuState (mode) +import qualified Ribosome.Report as Report + +import Proteome.Tags.State (Tag (Tag, line, path), TagsState, cycle) + +data TagsAction = + Navigate (Path Abs File) Int + deriving stock (Eq, Show) + +checkPath :: + Members [Rpc, Embed IO] r => + Text -> + Sem r (Maybe (Path Abs File)) +checkPath path = + runMaybeT do + file <- MaybeT (parseNvimFile path) + ifM (doesFileExist file) (pure file) empty + +navigate :: + Members [Rpc, ReportLog, Embed IO] r => + MenuWidget TagsState r TagsAction +navigate = + withFocus' \ Tag {..} -> + checkPath path >>= \case + Just file -> + pure (Menu.success (Navigate file line)) + Nothing -> + MenuAction.Continue <$ Report.info [exon|File doesn't exist: #{path}|] [ + [exon|Tag file focused in menu doesn't exist: #{path}|] + ] + +cycleSegment :: MenuWidget TagsState r TagsAction +cycleSegment = + menuState do + mode . #segment %= cycle + menuOk + +mappings :: + Members [Rpc, ReportLog, Embed IO] r => + Mappings TagsState r TagsAction +mappings = + [("", navigate), ("", cycleSegment)] diff --git a/lib/Proteome/Tags/Menu.hs b/lib/Proteome/Tags/Menu.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Menu.hs @@ -0,0 +1,132 @@ +module Proteome.Tags.Menu where + +import qualified Data.Text as Text +import Exon (exon) +import Path.IO (doesFileExist) +import Prelude hiding (tag) +import Ribosome ( + Args (Args), + Handler, + Report, + Rpc, + RpcError, + ScratchId (ScratchId), + SettingError, + Settings, + mapReport, + pathText, + resumeReport, + ) +import Ribosome.Host.Data.Report (ReportLog) +import Ribosome.Menu (Filter (Fuzzy), MenuItem, MenuResult, WindowMenus, modal, windowMenu) +import qualified Streamly.Prelude as Stream +import Streamly.Prelude (SerialT) + +import Proteome.Data.Env (Env, mainType) +import Proteome.Menu (handleResult) +import Proteome.Tags.Cycle (cword) +import Proteome.Tags.Mappings (TagsAction (Navigate), mappings) +import Proteome.Tags.Nav (loadOrEdit) +import Proteome.Tags.Query (query) +import Proteome.Tags.State ( + RawTagSegments, + Segment (Module, Name), + Tag, + TagSegments, + TagsMode (TagsMode), + TagsState, + tagSegmentsFor, + ) +import Proteome.Tags.Stream (readTags) +import Proteome.Tags.Syntax (tagsSyntax) + +getTags :: + Members [AtomicState Env, Rpc] r => + (RawTagSegments -> TagSegments) -> + Maybe Text -> + Sem r (SerialT IO (MenuItem Tag)) +getTags mkSegments = \case + Just rex -> do + Stream.fromList <$> query mkSegments rex + Nothing -> + readTags mkSegments + +tagsAction :: + Members [Rpc, Stop Report, Embed IO] r => + TagsAction -> + Sem r () +tagsAction = \case + Navigate path line -> do + unlessM (doesFileExist path) do + stop (fromText [exon|File doesn't exist: #{pathText path}|]) + loadOrEdit path line + +type TagsStack = + [ + WindowMenus () TagsState !! RpcError, + Settings !! SettingError, + Rpc !! RpcError, + Log + ] + +tagsMenu :: + Members TagsStack r => + Members [AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r => + Maybe Text -> + Sem r (MenuResult TagsAction) +tagsMenu rex = do + tpe <- atomicGets mainType + tags <- getTags (tagSegmentsFor tpe) rex + mapReport do + windowMenu tags (modal (TagsMode Fuzzy mode)) (def & #items .~ scratchOptions) mappings + where + mode = + if isJust rex then Module else Name + scratchOptions = + def + & #name .~ ScratchId name + & #syntax .~ [tagsSyntax] + & #filetype ?~ name + name = + "proteome-tags" + +tagsMenuHandle :: + Members TagsStack r => + Members [AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r => + Maybe Text -> + Sem r () +tagsMenuHandle = + handleResult tagsAction <=< tagsMenu + +proTags :: + Members TagsStack r => + Members [AtomicState Env, ReportLog, Embed IO] r => + Args -> + Handler r () +proTags (Args rex) = + resumeReport @Rpc do + tagsMenuHandle (if Text.null rex then Nothing else Just rex) + +exactQuery :: + Member Rpc r => + Text -> + Sem r Text +exactQuery = + fmap exact . \case + "" -> + cword + rex -> + pure rex + where + exact rex = + [exon|^#{rex}$|] + +proTag :: + Members TagsStack r => + Members [AtomicState Env, ReportLog, Embed IO] r => + Args -> + Handler r () +proTag (Args name) = do + resumeReport @Rpc do + rex <- exactQuery name + tagsMenuHandle (Just rex) diff --git a/lib/Proteome/Tags/Nav.hs b/lib/Proteome/Tags/Nav.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Nav.hs @@ -0,0 +1,29 @@ +module Proteome.Tags.Nav where + +import Path (Abs, File, Path) +import Prelude hiding (tag) +import Ribosome (Buffer, Rpc) +import Ribosome.Api (bufferForFile, edit, nvimBufIsLoaded, nvimCommand, nvimGetCurrentWin, nvimWinSetBuf, setCursor) +import qualified Ribosome.Data.FileBuffer as FileBuffer + +filterUnloaded :: + Member Rpc r => + Buffer -> + Sem r (Maybe Buffer) +filterUnloaded buffer = + nvimBufIsLoaded buffer <&> \case + True -> Just buffer + False -> Nothing + +loadOrEdit :: + Member Rpc r => + Path Abs File -> + Int -> + Sem r () +loadOrEdit file line = do + existingBuffer <- join <$> (traverse (filterUnloaded . FileBuffer.buffer) =<< bufferForFile file) + window <- nvimGetCurrentWin + maybe (edit file) (nvimWinSetBuf window) existingBuffer + setCursor window line 0 + nvimCommand "normal! zv" + nvimCommand "normal! zz" diff --git a/lib/Proteome/Tags/Query.hs b/lib/Proteome/Tags/Query.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Query.hs @@ -0,0 +1,95 @@ +module Proteome.Tags.Query where + +import Control.Monad.Extra (mapMaybeM) +import qualified Data.Text as Text +import Exon (exon) +import Path (Abs, File, Path) +import Prelude hiding (tag) +import Ribosome (Rpc) +import Ribosome.Api (taglist) +import Ribosome.Menu (MenuItem (MenuItem)) + +import Proteome.Tags.Mappings (checkPath) +import qualified Proteome.Tags.State as State +import Proteome.Tags.State ( + RawTagSegments (RawTagSegments), + Tag (Tag), + TagLoc (TagLoc), + TagSegments (TagSegments), + tagLoc, + ) + +truncAndPad :: Int -> Text -> Text +truncAndPad n t = + trunced <> extra + where + extra = + if tooLong then "…" else Text.replicate (diff + 1) " " + tooLong = + diff < 0 + diff = + n - Text.length trunced + trunced = + Text.take n t + +renderTag :: Tag -> Text +renderTag Tag {path, segments = TagSegments {..}} = + [exon|#{maybe "" renderPackage package}#{fromMaybe path modulePath}|] + where + renderPackage p = + [exon|📦 #{truncAndPad 20 p} |] + +createTag :: + (RawTagSegments -> TagSegments) -> + Text -> + Text -> + Int -> + Maybe (MenuItem Tag) +createTag mkSegments name path line = do + let + segments = mkSegments (RawTagSegments name path) + tag = Tag {..} + rendered = renderTag tag + pure (MenuItem tag "" [exon| 🟣 #{truncedName} #{rendered}|]) + where + truncedName = + truncAndPad 20 name + +parseTaglistTag :: + (RawTagSegments -> TagSegments) -> + TagLoc Text -> + Maybe (MenuItem Tag) +parseTaglistTag mkSegments loc = + createTag mkSegments (loc ^. #name) (loc ^. #path) (loc ^. #line) + +tagLocs :: + Member Rpc r => + Maybe Text -> + Maybe (Path Abs File) -> + Sem r [TagLoc Text] +tagLocs rex file = do + result <- taglist rex file + pure (mapMaybe tagLoc result) + +checkLocPath :: + Members [Rpc, Embed IO] r => + TagLoc Text -> + Sem r (Maybe (TagLoc (Path Abs File))) +checkLocPath TagLoc {..} = + checkPath path <&> fmap \ f -> TagLoc {path = f, ..} + +tagLocsPath :: + Members [Rpc, Embed IO] r => + Maybe Text -> + Maybe (Path Abs File) -> + Sem r [TagLoc (Path Abs File)] +tagLocsPath rex file = + mapMaybeM checkLocPath =<< tagLocs rex file + +query :: + Member Rpc r => + (RawTagSegments -> TagSegments) -> + Text -> + Sem r [MenuItem Tag] +query mkSegments rex = + mapMaybe (parseTaglistTag mkSegments) <$> tagLocs (Just rex) Nothing diff --git a/lib/Proteome/Tags/State.hs b/lib/Proteome/Tags/State.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/State.hs @@ -0,0 +1,149 @@ +module Proteome.Tags.State where + +import Control.Lens.Regex.Text (Match, group, regex) +import Data.Char (isUpper) +import Data.List.Extra (takeWhileEnd) +import qualified Data.Text as Text +import Exon (exon) +import Lens.Micro.Extras (preview, view) +import Prelude hiding (group) +import qualified Ribosome +import Ribosome.Menu (Filter, MenuItem, Modal) +import qualified Ribosome.Menu.MenuState as MenuState +import Ribosome.Menu.MenuState (FilterMode (FilterMode), MenuMode (cycleFilter, filterMode, renderExtra, renderFilter)) + +import Proteome.Data.ProjectType (ProjectType (ProjectType)) + +data TagLoc p = + TagLoc { + name :: Text, + path :: p, + line :: Int + } + deriving stock (Eq, Show, Generic) + +tagLoc :: Ribosome.Tag -> Maybe (TagLoc Text) +tagLoc t = do + line <- readMaybe (toString (t ^. #cmd)) + pure TagLoc {name = t ^. #name, path = t ^. #filename, line = line - 1} + +data RawTagSegments = + RawTagSegments { + name :: Text, + path :: Text + } + deriving stock (Eq, Show, Generic) + +data TagSegments = + TagSegments { + name :: Text, + package :: Maybe Text, + modulePath :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data Tag = + Tag { + path :: Text, + line :: Int, + segments :: TagSegments + } + deriving stock (Eq, Show, Generic) + +data Segment = + Name + | + Package + | + Module + deriving stock (Eq, Show, Ord) + +genericSegments :: RawTagSegments -> TagSegments +genericSegments RawTagSegments {..} = + TagSegments {package = Nothing, modulePath = Nothing, ..} + +nixPackageRegex :: Traversal' Text Match +nixPackageRegex = + [regex|/nix/store/[^-]+-([^/]+?)(-[\d.]+)?(-tags)?/|] + +nixPackage :: Text -> Maybe Text +nixPackage = + preview (nixPackageRegex . group 0) + +haskellModule :: Text -> Maybe Text +haskellModule = + Just . + Text.dropEnd 3 . + Text.intercalate "." . + takeWhileEnd firstUpper . + Text.split ('/' ==) + where + firstUpper seg = + any (isUpper . fst) (Text.uncons seg) + +haskellSegments :: RawTagSegments -> TagSegments +haskellSegments RawTagSegments {..} = + TagSegments {package = nixPackage path, modulePath = haskellModule path, ..} + +tagSegmentsForProject :: ProjectType -> RawTagSegments -> TagSegments +tagSegmentsForProject = \case + ProjectType "haskell" -> + haskellSegments + _ -> + genericSegments + +tagSegmentsForFile :: RawTagSegments -> TagSegments +tagSegmentsForFile segs = + case Text.takeWhileEnd (/= '.') (segs ^. #path) of + "hs" -> + haskellSegments segs + _ -> + genericSegments segs + +tagSegmentsFor :: Maybe ProjectType -> RawTagSegments -> TagSegments +tagSegmentsFor = + maybe tagSegmentsForFile tagSegmentsForProject + +renderSegment :: Segment -> Text +renderSegment = \case + Name -> "name" + Package -> "package" + Module -> "module" + +segmentExtract :: MenuItem Tag -> Segment -> Maybe Text +segmentExtract (view #meta -> Tag {segments = TagSegments {..}}) = \case + Name -> Just name + Package -> package + Module -> modulePath + +cycle :: Segment -> Segment +cycle = \case + Name -> Package + Package -> Module + Module -> Name + +data TagsMode = + TagsMode { + mode :: Filter, + segment :: Segment + } + deriving stock (Eq, Show, Ord, Generic) + +type TagsState = + Modal TagsMode Tag + +instance MenuMode Tag TagsMode where + type Filter TagsMode = + FilterMode Filter + + cycleFilter (TagsMode mode segment) = + TagsMode (cycleFilter mode) segment + + renderFilter (TagsMode mode _) = + renderFilter mode + + renderExtra (TagsMode _ segment) = + Just [exon|🔧 #{renderSegment segment}|] + + filterMode (TagsMode mode segment) = + FilterMode mode (flip segmentExtract segment) diff --git a/lib/Proteome/Tags/Stream.hs b/lib/Proteome/Tags/Stream.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Stream.hs @@ -0,0 +1,38 @@ +module Proteome.Tags.Stream where + +import qualified Data.ByteString as ByteString +import qualified Data.Text as Text +import Prelude hiding (tag) +import Ribosome (Rpc) +import Ribosome.Api (optionList) +import Ribosome.Menu (MenuItem) +import qualified Streamly.Internal.Data.Fold as Fold +import Streamly.Internal.FileSystem.File (toBytes) +import qualified Streamly.Prelude as Stream +import Streamly.Prelude (SerialT) + +import Proteome.Tags.Query (createTag) +import Proteome.Tags.State (RawTagSegments, Tag, TagSegments) + +parseTagLine :: + (RawTagSegments -> TagSegments) -> + Text -> + Maybe (MenuItem Tag) +parseTagLine mkSegments l = + case Text.split (== '\t') l of + [name, path, readMaybe . toString -> Just line] -> + createTag mkSegments name path line + _ -> + Nothing + +readLines :: Text -> SerialT IO Text +readLines path = + Stream.splitOnSuffix (== 10) (decodeUtf8 . ByteString.pack <$> Fold.toList) (toBytes (toString path)) + +readTags :: + (RawTagSegments -> TagSegments) -> + Member Rpc r => + Sem r (SerialT IO (MenuItem Tag)) +readTags mkSegments = do + files <- optionList "tags" + pure (Stream.mapMaybe (parseTagLine mkSegments) (Stream.concatMap readLines (Stream.fromList files))) diff --git a/lib/Proteome/Tags/Syntax.hs b/lib/Proteome/Tags/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Proteome/Tags/Syntax.hs @@ -0,0 +1,10 @@ +module Proteome.Tags.Syntax where + +import Exon (exon) +import Ribosome.Syntax (HiLink (HiLink), Syntax, build, link, match, prefix, (#>), (>-)) + +tagsSyntax :: Syntax +tagsSyntax = + (#links <>~ [HiLink "Module" "Type"]) $ build $ prefix "ProTags" $ + match "Line" "^.*$" #> match "Name" [exon|🟣 \S\+|] >- link "Directory" (match "Package" [exon|📦 \S\+|]) >- + link "Module" (match "Module" [exon|\S\+|]) diff --git a/lib/Proteome/Test/Config.hs b/lib/Proteome/Test/Config.hs deleted file mode 100644 --- a/lib/Proteome/Test/Config.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Proteome.Test.Config( - defaultTestConfigWith, - defaultTestConfig, -) where - -import Ribosome.Test.Embed (TestConfig, Vars) -import qualified Ribosome.Test.Embed as E (defaultTestConfig, defaultTestConfigWith) - -defaultTestConfigWith :: Vars -> TestConfig -defaultTestConfigWith = E.defaultTestConfigWith "proteome" - -defaultTestConfig :: TestConfig -defaultTestConfig = E.defaultTestConfig "proteome" diff --git a/lib/Proteome/Test/Functional.hs b/lib/Proteome/Test/Functional.hs deleted file mode 100644 --- a/lib/Proteome/Test/Functional.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Proteome.Test.Functional( - spec, - specWith, - fixture, - tempDir, - tempFile, -) where - -import Ribosome.Control.Ribo (Ribo) -import Ribosome.Test.Embed (Vars) -import Ribosome.Test.Functional (functionalSpec, fixture, tempDir, tempFile) -import Proteome.Test.Config (defaultTestConfig, defaultTestConfigWith) - -spec :: Ribo () () -> IO () -spec = functionalSpec defaultTestConfig - -specWith :: Ribo () () -> Vars -> IO () -specWith thunk vars = functionalSpec (defaultTestConfigWith vars) thunk diff --git a/lib/Proteome/Test/Unit.hs b/lib/Proteome/Test/Unit.hs deleted file mode 100644 --- a/lib/Proteome/Test/Unit.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Proteome.Test.Unit( - spec, - specWith, - specWithDef, -) where - -import Data.Default.Class (def) -import UnliftIO.STM (newTVarIO) -import Ribosome.Test.Embed (Vars) -import Ribosome.Test.Unit (unitSpec) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Env (Env) -import Proteome.Test.Config (defaultTestConfig, defaultTestConfigWith) - -spec :: Env -> Proteome () -> IO () -spec e s = do - t <- newTVarIO e - unitSpec defaultTestConfig t s - -specWith :: Env -> Proteome () -> Vars -> IO () -specWith e s vars = do - t <- newTVarIO e - unitSpec (defaultTestConfigWith vars) t s - -specWithDef :: Proteome () -> Vars -> IO () -specWithDef s v = do - specWith def s v diff --git a/proteome.cabal b/proteome.cabal --- a/proteome.cabal +++ b/proteome.cabal @@ -1,232 +1,278 @@ -cabal-version: 1.12 +cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack --- --- hash: b09159ae62bbe57e0dc799f83b55ab8e528c986bd083975cb5dc0e7df2423fbc name: proteome -version: 0.3.17.0 -synopsis: neovim project manager -description: Please see the README on GitHub at +version: 0.9.9.9 +synopsis: Neovim Project Manager +description: See https://hackage.haskell.org/package/proteome/docs/Proteome.html category: Neovim -homepage: https://github.com/tek/proteome-hs#readme -bug-reports: https://github.com/tek/proteome-hs/issues +homepage: https://github.com/tek/proteome#readme +bug-reports: https://github.com/tek/proteome/issues author: Torsten Schmits -maintainer: tek@tryp.io -copyright: 2018 Torsten Schmits -license: MIT +maintainer: hackage@tryp.io +copyright: 2022 Torsten Schmits +license: BSD-2-Clause-Patent license-file: LICENSE build-type: Simple -extra-source-files: - README.md source-repository head type: git - location: https://github.com/tek/proteome-hs + location: https://github.com/tek/proteome library exposed-modules: Proteome.Add + Proteome.Add.Syntax Proteome.BufEnter + Proteome.Buffers + Proteome.Buffers.Syntax Proteome.Config Proteome.Data.ActiveProject + Proteome.Data.AddError + Proteome.Data.AddItem Proteome.Data.AddOptions + Proteome.Data.CurrentTag Proteome.Data.Env + Proteome.Data.FilenameError + Proteome.Data.FileScanItem + Proteome.Data.FilesConfig + Proteome.Data.FilesError + Proteome.Data.FilesState + Proteome.Data.GrepError + Proteome.Data.GrepOutputLine + Proteome.Data.ListedBuffer + Proteome.Data.PersistBuffers Proteome.Data.Project + Proteome.Data.ProjectConfig + Proteome.Data.ProjectLang + Proteome.Data.ProjectMetadata + Proteome.Data.ProjectName + Proteome.Data.ProjectRoot Proteome.Data.ProjectSpec - Proteome.Data.Proteome + Proteome.Data.ProjectType + Proteome.Data.Replace + Proteome.Data.ReplaceError + Proteome.Data.ResolveError + Proteome.Data.TagsError + Proteome.Data.TagsParams Proteome.Diag - Proteome.Env + Proteome.Filename + Proteome.Files + Proteome.Files.Source + Proteome.Files.Syntax + Proteome.Grep + Proteome.Grep.Parse + Proteome.Grep.Process + Proteome.Grep.Replace + Proteome.Grep.Syntax Proteome.Init - Proteome.Log + Proteome.Menu + Proteome.Path Proteome.PersistBuffers Proteome.Plugin Proteome.Project Proteome.Project.Activate Proteome.Project.Resolve + Proteome.Quit Proteome.Save Proteome.Settings - Proteome.Tags - Proteome.Test.Config - Proteome.Test.Functional - Proteome.Test.Unit - other-modules: - Paths_proteome + Proteome.System.Path + Proteome.Tags.Cycle + Proteome.Tags.Gen + Proteome.Tags.Mappings + Proteome.Tags.Menu + Proteome.Tags.Nav + Proteome.Tags.Query + Proteome.Tags.State + Proteome.Tags.Stream + Proteome.Tags.Syntax hs-source-dirs: lib + default-extensions: + StandaloneKindSignatures + OverloadedLabels + ImpredicativeTypes + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DisambiguateRecordFields + DoAndIfThenElse + DuplicateRecordFields + EmptyCase + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedLabels + OverloadedLists + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + UndecidableInstances + UnicodeSyntax + ViewPatterns + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin build-depends: - MissingH - , aeson - , ansi-terminal - , base >=4.7 && <5 - , bytestring - , containers - , data-default-class - , deepseq - , directory - , either - , filepath - , hslogger + Glob + , attoparsec + , base >=4.12 && <5 + , chiasma + , chronos + , exon + , extra + , filepattern , lens - , messagepack - , mtl - , nvim-hs - , pretty-terminal + , lens-regex-pcre + , microlens + , nonempty-zipper + , parsers + , path + , path-io + , pcre-light + , polysemy + , polysemy-chronos + , polysemy-plugin + , polysemy-process + , prelate >=0.1 , prettyprinter - , process - , resourcet + , raw-strings-qq , ribosome - , safe - , split - , stm - , strings - , text - , time + , ribosome-host + , ribosome-menu + , stm-chans + , streamly >=0.8 + , streamly-process >=0.1 , transformers - , unliftio - , utf8-string + , typed-process + mixins: + base hiding (Prelude) + , prelate (Prelate as Prelude) + , prelate hiding (Prelate) default-language: Haskell2010 executable proteome main-is: Main.hs - other-modules: - Paths_proteome hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - MissingH - , aeson - , ansi-terminal - , base >=4.7 && <5 - , bytestring - , containers - , data-default-class - , deepseq - , directory - , either - , filepath - , hslogger - , lens - , messagepack - , mtl - , nvim-hs - , pretty-terminal - , prettyprinter - , process - , proteome - , resourcet - , ribosome - , safe - , split - , stm - , strings - , text - , time - , transformers - , unliftio - , utf8-string - default-language: Haskell2010 - -test-suite proteome-functional - type: exitcode-stdio-1.0 - main-is: SpecMain.hs - other-modules: - AddSpec - Config - ConfigSpec - InitSpec - Paths_proteome - hs-source-dirs: - test/f - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - HTF - , MissingH - , aeson - , ansi-terminal - , base >=4.7 && <5 - , bytestring - , containers - , data-default-class - , deepseq - , directory - , either - , filepath - , hslogger - , lens - , messagepack - , mtl - , nvim-hs - , pretty-terminal - , prettyprinter - , process - , proteome - , resourcet - , ribosome - , safe - , split - , stm - , strings - , text - , time - , transformers - , unliftio - , utf8-string - default-language: Haskell2010 - -test-suite proteome-unit - type: exitcode-stdio-1.0 - main-is: SpecMain.hs - other-modules: - AddSpec - Config - CycleSpec - DiagSpec - MultiTagsSpec - PersistLoadSpec - PersistStoreSpec - Project - ResolveSpec - ScratchSpec - TagsSpec - Paths_proteome - hs-source-dirs: - test/u - ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-extensions: + StandaloneKindSignatures + OverloadedLabels + ImpredicativeTypes + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DisambiguateRecordFields + DoAndIfThenElse + DuplicateRecordFields + EmptyCase + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedLabels + OverloadedLists + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + UndecidableInstances + UnicodeSyntax + ViewPatterns + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N build-depends: - HTF - , MissingH - , aeson - , ansi-terminal - , base >=4.7 && <5 - , bytestring - , containers - , data-default-class - , deepseq - , directory - , either - , filepath - , hslogger - , lens - , messagepack - , mtl - , nvim-hs - , pretty-terminal - , prettyprinter - , process + base >=4.12 && <5 + , polysemy + , polysemy-plugin + , prelate >=0.1 , proteome - , resourcet - , ribosome - , safe - , split - , stm - , strings - , text - , time - , transformers - , unliftio - , utf8-string + mixins: + base hiding (Prelude) + , prelate (Prelate as Prelude) + , prelate hiding (Prelate) default-language: Haskell2010 diff --git a/test/f/AddSpec.hs b/test/f/AddSpec.hs deleted file mode 100644 --- a/test/f/AddSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module AddSpec( - 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.Control.Ribo (Ribo) -import qualified Proteome.Settings as S (projectBaseDirs) -import Proteome.Test.Functional (specWith, fixture) -import Config (vars) - -addSpec :: Ribo env () -addSpec = do - 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_addFunction :: IO () -test_addFunction = - vars >>= specWith addSpec - -addCommandSpec :: Ribo env () -addCommandSpec = do - 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 = - vars >>= specWith addCommandSpec diff --git a/test/f/Config.hs b/test/f/Config.hs deleted file mode 100644 --- a/test/f/Config.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Config( - vars, -) where - -import Neovim (toObject) -import System.Directory (getCurrentDirectory) -import Ribosome.Test.Embed (Vars(..)) - -vars :: IO Vars -vars = do - base <- getCurrentDirectory - return $ Vars [ - ("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 deleted file mode 100644 --- a/test/f/ConfigSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module ConfigSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import Test.Framework -import Data.MessagePack (Object(ObjectInt)) -import Neovim (vim_call_function', vim_get_var') -import Ribosome.Control.Ribo (Ribo) -import Proteome.Test.Functional (specWith) -import Config (vars) - -configSpec :: Ribo env () -configSpec = do - _ <- vim_call_function' "ProReadConfig" [] - value <- vim_get_var' "flag" - liftIO $ assertEqual value (ObjectInt 13) - -test_config :: IO () -test_config = - vars >>= specWith configSpec diff --git a/test/f/InitSpec.hs b/test/f/InitSpec.hs deleted file mode 100644 --- a/test/f/InitSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module InitSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import Test.Framework -import Ribosome.Control.Ribo (Ribo) -import Ribosome.Config.Setting (setting) -import qualified Proteome.Settings as S -import Proteome.Data.Project (ProjectName(ProjectName), ProjectType(ProjectType)) -import Proteome.Test.Functional (specWith) -import Config (vars) - -initSpec :: Ribo env () -initSpec = do - tpe <- setting S.mainType - name <- setting S.mainName - liftIO $ assertEqual name (ProjectName "flagellum") - liftIO $ assertEqual tpe (ProjectType "haskell") - -test_init :: IO () -test_init = - vars >>= specWith initSpec diff --git a/test/f/SpecMain.hs b/test/f/SpecMain.hs deleted file mode 100644 --- a/test/f/SpecMain.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module Main where - -import {-@ HTF_TESTS @-} ConfigSpec -import {-@ HTF_TESTS @-} InitSpec -import {-@ HTF_TESTS @-} AddSpec -import Test.Framework -import Test.Framework.BlackBoxTest () - -main :: IO () -main = htfMain htf_importedTests diff --git a/test/u/AddSpec.hs b/test/u/AddSpec.hs deleted file mode 100644 --- a/test/u/AddSpec.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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.Control.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 ( - ProjectRoot(ProjectRoot), - ProjectMetadata(DirProject), - Project(Project), - ) -import qualified Proteome.Settings as S (projectBaseDirs) -import Proteome.Test.Unit (specWithDef) -import Config (vars) -import Project (flag, hask, fn, tp, l) - -addSpec :: Proteome () -addSpec = do - projectsDir <- fixture "projects" - updateSetting S.projectBaseDirs [projectsDir] - 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 - -test_add :: IO () -test_add = vars >>= specWithDef addSpec diff --git a/test/u/Config.hs b/test/u/Config.hs deleted file mode 100644 --- a/test/u/Config.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Config( - vars, -) where - -import Neovim (toObject) -import System.Directory (getCurrentDirectory) -import Ribosome.Test.Embed (Vars(..)) - -vars :: IO Vars -vars = do - base <- getCurrentDirectory - return $ Vars [ - ("proteome_project_base_dirs", toObject [base ++ "/test/u/fixtures/projects"]), - ("proteome_main_project_dir", toObject $ base ++ "/test/u/fixtures/projects/haskell/flagellum") - ] diff --git a/test/u/CycleSpec.hs b/test/u/CycleSpec.hs deleted file mode 100644 --- a/test/u/CycleSpec.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module CycleSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import Data.Default.Class (Default(def)) -import Data.Foldable (traverse_) -import System.FilePath (()) -import Neovim (Neovim) -import Test.Framework -import Ribosome.Api.Path (nvimCwd) -import Ribosome.Config.Setting (updateSetting) -import Ribosome.Test.Unit (fixture) -import Proteome.Add (proAdd) -import Proteome.Project.Activate (proNext, proPrev) -import Proteome.Data.AddOptions (AddOptions(AddOptions)) -import Proteome.Data.Proteome (Proteome) -import Proteome.Init (resolveAndInitMain) -import qualified Proteome.Settings as S (projectBaseDirs, mainProjectDir) -import Proteome.Test.Unit (specWithDef) -import Config (vars) -import Project (cn, fn, tp, hask, prot, cil, flag) - -assertProject :: FilePath -> String -> Neovim e () -assertProject projectsDir n = do - cwd <- nvimCwd - liftIO $ assertEqual (projectsDir hask n) cwd - -cycleSpec :: Proteome () -cycleSpec = do - projectsDir <- fixture "projects" - let assertDir = assertProject projectsDir - let mainDir = projectsDir hask prot - updateSetting S.projectBaseDirs [projectsDir] - updateSetting S.mainProjectDir mainDir - resolveAndInitMain - proAdd $ AddOptions fn tp False - proAdd $ AddOptions cn tp False - assertDir prot - let checkNext n = proNext def >> assertDir n - traverse_ checkNext [flag, cil, prot, flag] - proPrev def - assertDir prot - -test_cycle :: IO () -test_cycle = vars >>= specWithDef cycleSpec diff --git a/test/u/DiagSpec.hs b/test/u/DiagSpec.hs deleted file mode 100644 --- a/test/u/DiagSpec.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module DiagSpec( - htf_thisModulesTests -) where - -import Control.Lens (set) -import Control.Monad.IO.Class (liftIO) -import Data.Default.Class (Default(def)) -import Test.Framework -import Ribosome.Api.Buffer (currentBufferContent) -import qualified Ribosome.Control.Ribo as Ribo (modify) -import Proteome.Data.Env (_mainProject, _configLog) -import Proteome.Data.Project ( - Project (Project), - ProjectRoot(ProjectRoot), - ProjectMetadata (DirProject), - ) -import Proteome.Data.Proteome -import Proteome.Test.Unit (specWithDef) -import Proteome.Diag (proDiag) -import Config (vars) -import Project (fn, tp, ti, la, l, li, flag, idr, ag, hask) - -root :: String -root = "/projects/flagellum" - -main :: Project -main = Project (DirProject fn (ProjectRoot root) (Just tp)) [ti] (Just l) [la, li] - -confLog :: [FilePath] -confLog = ["/conf/project/haskell/flagellum.vim", "/conf/project_after/all.vim"] - -target :: [String] -target = [ - "Diagnostics", - "", - "Main project", - "", - "name: " ++ flag, - "root: " ++ root, - "type: " ++ hask, - "tags cmd: ctags -R --languages=agda,idris -f /projects/flagellum/.tags.tmp /projects/flagellum", - "types: " ++ idr, - "main language: " ++ hask, - "languages: " ++ ag ++ ", " ++ idr, - "", - "loaded config files:" - ] ++ confLog - -diagSpec :: Proteome () -diagSpec = do - Ribo.modify $ set _mainProject main - Ribo.modify $ set _configLog confLog - proDiag def - content <- currentBufferContent - liftIO $ assertEqual target content - -test_diag :: IO () -test_diag = - vars >>= specWithDef diagSpec diff --git a/test/u/MultiTagsSpec.hs b/test/u/MultiTagsSpec.hs deleted file mode 100644 --- a/test/u/MultiTagsSpec.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module MultiTagsSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import System.FilePath (()) -import System.Directory (doesFileExist) -import Test.Framework -import Neovim (fromObject', vim_get_current_buffer', buffer_get_option') -import Ribosome.Config.Setting (updateSetting) -import Ribosome.Test.Unit (tempDir) -import Proteome.Data.Proteome (Proteome) -import Proteome.Add (proAdd) -import Proteome.Data.AddOptions (AddOptions(AddOptions)) -import qualified Proteome.Settings as S (projectBaseDirs, tagsCommand, tagsArgs, tagsFork) -import Proteome.Tags (proTags) -import Proteome.Test.Unit (specWithDef) -import Proteome.BufEnter (bufEnter) -import Config (vars) -import Project (flag, cil, hask, cn, fn, tp, createTestProject) - -multiSpec :: Proteome () -multiSpec = do - projectsDir <- tempDir "multi/projects" - updateSetting S.projectBaseDirs [projectsDir] - createTestProject tp fn - createTestProject tp cn - updateSetting S.tagsCommand "touch" - updateSetting S.tagsArgs ".tags" - updateSetting S.tagsFork False - proAdd $ AddOptions fn tp False - proAdd $ AddOptions cn tp False - proTags - bufEnter - let ftags = projectsDir hask flag ".tags" - let ctags = projectsDir hask cil ".tags" - ftagsExists <- liftIO $ doesFileExist ftags - ctagsExists <- liftIO $ doesFileExist ctags - buf <- vim_get_current_buffer' - tags <- buffer_get_option' buf "tags" >>= fromObject' - liftIO $ assertEqual ftagsExists True - liftIO $ assertEqual ctagsExists True - liftIO $ assertEqual (ftags ++ "," ++ ctags) tags - -test_multi :: IO () -test_multi = vars >>= specWithDef multiSpec diff --git a/test/u/PersistLoadSpec.hs b/test/u/PersistLoadSpec.hs deleted file mode 100644 --- a/test/u/PersistLoadSpec.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module PersistLoadSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import Control.Lens (set) -import System.FilePath (()) -import Test.Framework -import Neovim (vim_get_buffers', vim_get_current_buffer', buffer_get_name') -import Ribosome.Config.Setting (updateSetting) -import Ribosome.Config.Settings (persistenceDir) -import qualified Ribosome.Control.Ribo as Ribo (modify) -import Ribosome.Test.Unit (fixture) -import Proteome.Data.Env (_mainProject) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project ( - ProjectName(..), - ProjectRoot(..), - ProjectType(..), - ProjectMetadata(DirProject), - _meta, - ) -import Proteome.PersistBuffers (loadBuffers) -import Proteome.Test.Unit (specWithDef) -import Config (vars) - -main :: ProjectMetadata -main = DirProject (ProjectName "flagellum") (ProjectRoot "") (Just (ProjectType "haskell")) - -loadBuffersSpec :: Proteome () -loadBuffersSpec = do - Ribo.modify $ set (_mainProject._meta) main - persistDir <- fixture "persist/load" - fixDir <- fixture "persist/store" - updateSetting persistenceDir persistDir - loadBuffers - buffers <- vim_get_buffers' - liftIO $ assertEqual 3 (length buffers) - active <- buffer_get_name' =<< vim_get_current_buffer' - liftIO $ assertEqual active (fixDir "file2") - -test_loadBuffers :: IO () -test_loadBuffers = - vars >>= specWithDef loadBuffersSpec diff --git a/test/u/PersistStoreSpec.hs b/test/u/PersistStoreSpec.hs deleted file mode 100644 --- a/test/u/PersistStoreSpec.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module PersistStoreSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import Control.Lens (set) -import Data.Aeson (decode) -import qualified Data.ByteString.Lazy as B (readFile) -import System.FilePath (()) -import Test.Framework -import Ribosome.Api.Buffer (edit) -import Ribosome.Config.Setting (updateSetting) -import Ribosome.Config.Settings (persistenceDir) -import qualified Ribosome.Control.Ribo as Ribo (modify) -import Ribosome.Test.Unit (fixture, tempDir) -import Proteome.Data.Env (_mainProject) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Project ( - ProjectName(..), - ProjectRoot(..), - ProjectType(..), - ProjectMetadata(DirProject), - _meta, - ) -import Proteome.PersistBuffers (storeBuffers, PersistBuffers(PersistBuffers)) -import Proteome.Test.Unit (specWithDef) -import Config (vars) - -main :: ProjectMetadata -main = DirProject (ProjectName "flagellum") (ProjectRoot "") (Just (ProjectType "haskell")) - -storeTarget :: FilePath -> FilePath -> FilePath -> PersistBuffers -storeTarget f1 f2 f3 = PersistBuffers (Just f2) [f1, f2, f3] - -storeBuffersSpec :: Proteome () -storeBuffersSpec = do - let nonexistentFile = "nonexistent" - base <- fixture "persist/store" - let file1 = base "file1" - let file2 = base "file2" - let file3 = base "file3" - edit file1 - edit file2 - edit file3 - edit $ base nonexistentFile - edit file2 - persistDir <- tempDir "persist/store" - Ribo.modify $ set (_mainProject._meta) main - updateSetting persistenceDir persistDir - storeBuffers - let bufferFile = persistDir "proteome/haskell/flagellum/buffers.json" - json <- liftIO $ B.readFile bufferFile - pb <- case decode json of - Just a -> return a - _ -> fail "invalid json" - liftIO $ assertEqual pb (storeTarget file1 file2 file3) - -test_storeBuffers :: IO () -test_storeBuffers = - vars >>= specWithDef storeBuffersSpec diff --git a/test/u/Project.hs b/test/u/Project.hs deleted file mode 100644 --- a/test/u/Project.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Project( - flag, - hask, - cn, - tp, - l, - fn, - cil, - createTestProject, - prot, - idr, - ag, - ti, - ta, - li, - la, -) where - -import Control.Monad.IO.Class (liftIO) -import System.FilePath (()) -import System.Directory (createDirectoryIfMissing) -import Ribosome.Config.Setting (setting) -import Ribosome.Control.Ribo (Ribo) -import qualified Proteome.Settings as S (projectBaseDirs) -import Proteome.Data.Project ( - ProjectName(ProjectName), - ProjectType(ProjectType), - ProjectLang(ProjectLang), - ) - -flag :: String -flag = "flagellum" - -hask :: String -hask = "haskell" - -idr :: String -idr = "idris" - -ag :: String -ag = "agda" - -cil :: String -cil = "cilia" - -prot :: String -prot = "proteome" - -fn :: ProjectName -fn = ProjectName flag - -cn :: ProjectName -cn = ProjectName cil - -tp :: ProjectType -tp = ProjectType hask - -ti :: ProjectType -ti = ProjectType idr - -ta :: ProjectType -ta = ProjectType ag - -l :: ProjectLang -l = ProjectLang hask - -li :: ProjectLang -li = ProjectLang idr - -la :: ProjectLang -la = ProjectLang ag - -createTestProject :: ProjectType -> ProjectName -> Ribo e () -createTestProject (ProjectType tpe) (ProjectName name) = do - bases <- setting S.projectBaseDirs - liftIO $ createDirectoryIfMissing True (head bases tpe name) diff --git a/test/u/ResolveSpec.hs b/test/u/ResolveSpec.hs deleted file mode 100644 --- a/test/u/ResolveSpec.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module ResolveSpec( - htf_thisModulesTests -) where - -import Data.Map.Strict (Map) -import qualified Data.Map as Map (fromList) -import Data.Default.Class (Default(def)) -import Test.Framework -import Ribosome.File (canonicalPaths) -import Proteome.Config (ProjectConfig(ProjectConfig)) -import Proteome.Data.Project ( - Project(Project), - ProjectRoot(ProjectRoot), - ProjectType(ProjectType), - ProjectName(ProjectName), - ProjectLang(ProjectLang), - ProjectMetadata(DirProject), - ) -import Proteome.Project.Resolve (resolveProject) - -paths :: [FilePath] -paths = [ - "~/../test/dir", - "~" - ] - -test_canonicalPaths :: IO () -test_canonicalPaths = do - canon <- canonicalPaths paths - assertNotEqual canon paths - -root :: ProjectRoot -root = ProjectRoot "/projects/haskell/flagellum" - -name :: ProjectName -name = ProjectName "flagellum" - -tpe :: ProjectType -tpe = ProjectType "haskell" - -tpe1 :: ProjectType -tpe1 = ProjectType "idris" - -tpe2 :: ProjectType -tpe2 = ProjectType "agda" - -lang :: ProjectLang -lang = ProjectLang "haskell" - -lang1 :: ProjectLang -lang1 = ProjectLang "idris" - -lang2 :: ProjectLang -lang2 = ProjectLang "agda" - -typeMap :: Map ProjectType [ProjectType] -typeMap = Map.fromList [(tpe, [tpe1, tpe2])] - -config :: ProjectConfig -config = ProjectConfig def typeMap (Map.fromList [(tpe, lang)]) (Map.fromList [(lang, [lang1, lang2])]) - -targetProject :: Project -targetProject = Project (DirProject name root (Just tpe)) [tpe1, tpe2] (Just lang) [lang1, lang2] - -test_typeMap :: IO () -test_typeMap = do - project <- resolveProject ["/projects"] [] config (Just root) name (Just tpe) - assertEqual targetProject project diff --git a/test/u/ScratchSpec.hs b/test/u/ScratchSpec.hs deleted file mode 100644 --- a/test/u/ScratchSpec.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module ScratchSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import Test.Framework -import Ribosome.Api.Buffer (currentBufferContent) -import Ribosome.Data.ScratchOptions (ScratchOptions(ScratchOptions)) -import Ribosome.Scratch (showInScratch) -import Proteome.Data.Proteome (Proteome) -import Proteome.Test.Unit (specWithDef) -import Config (vars) - -target :: [String] -target = ["line 1", "line 2"] - -scratchSpec :: Proteome () -scratchSpec = do - _ <- showInScratch target (ScratchOptions False True (Just 0) False "buffi") - content <- currentBufferContent - liftIO $ assertEqual target content - -test_scratch :: IO () -test_scratch = - vars >>= specWithDef scratchSpec diff --git a/test/u/SpecMain.hs b/test/u/SpecMain.hs deleted file mode 100644 --- a/test/u/SpecMain.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module Main where - -import {-@ HTF_TESTS @-} TagsSpec -import {-@ HTF_TESTS @-} ResolveSpec -import {-@ HTF_TESTS @-} PersistLoadSpec -import {-@ HTF_TESTS @-} PersistStoreSpec -import {-@ HTF_TESTS @-} AddSpec -import {-@ HTF_TESTS @-} MultiTagsSpec -import {-@ HTF_TESTS @-} CycleSpec -import {-@ HTF_TESTS @-} ScratchSpec -import {-@ HTF_TESTS @-} DiagSpec -import Test.Framework -import Test.Framework.BlackBoxTest () - -main :: IO () -main = htfMain htf_importedTests diff --git a/test/u/TagsSpec.hs b/test/u/TagsSpec.hs deleted file mode 100644 --- a/test/u/TagsSpec.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module TagsSpec( - htf_thisModulesTests -) where - -import Control.Monad.IO.Class (liftIO) -import Control.Lens (set) -import System.FilePath (()) -import System.Directory (doesFileExist) -import Test.Framework -import Ribosome.Config.Setting (updateSetting) -import qualified Ribosome.Control.Ribo as Ribo (modify) -import Ribosome.Test.Unit (tempDir) -import Proteome.Data.Proteome (Proteome) -import Proteome.Data.Env (_mainProject) -import Proteome.Data.Project ( - ProjectName(..), - ProjectRoot(..), - ProjectType(..), - ProjectLang(..), - ProjectMetadata(DirProject), - _meta, - _lang, - ) -import qualified Proteome.Settings as S (tagsCommand, tagsArgs, tagsFork) -import Proteome.Tags (proTags) -import Proteome.Test.Unit (specWithDef) -import Config (vars) - -main :: FilePath -> ProjectMetadata -main root = DirProject (ProjectName "flagellum") (ProjectRoot root) (Just (ProjectType "haskell")) - -tagsSpec :: Proteome () -tagsSpec = do - root <- tempDir "projects/haskell/flagellum" - Ribo.modify $ set (_mainProject._meta) (main root) - Ribo.modify $ set (_mainProject._lang) (Just (ProjectLang "idris")) - updateSetting S.tagsCommand "touch" - updateSetting S.tagsArgs "tags-{langsComma}" - updateSetting S.tagsFork False - proTags - let tagsFile = root "tags-idris" - exists <- liftIO $ doesFileExist tagsFile - liftIO $ assertBool exists - -test_tags :: IO () -test_tags = vars >>= specWithDef tagsSpec