From 1849baa588cf23b8b12d676a5165fb74090cf390 Mon Sep 17 00:00:00 2001 From: hylodon Date: Mon, 22 Sep 2025 13:43:57 +0100 Subject: [PATCH] Add basic autocomplete support ca-store now takes a --completion argument to output completions to standard output. These are to be used for completion scripts, in future commits. Before the 1.0.0 release we need to either: 1) Work out how to get bash et al to accept these completions without mangling them 2) Get optparse-applicative to handle the command parsing entirely and forgo the Moore machine approach --- .gitignore | 1 + app/Main.hs | 7 +- package.yaml | 1 + src/CAStore/Command/Autocomplete.hs | 116 ++++++++++++++++++++++++++++ src/CAStore/Command/Type.hs | 59 ++++++++------ src/CAStore/Config/CLI.hs | 1 + src/CAStore/Config/Type.hs | 2 + src/CAStore/Program.hs | 6 ++ src/CAStore/Program/Internal.hs | 25 +++--- 9 files changed, 181 insertions(+), 37 deletions(-) create mode 100644 src/CAStore/Command/Autocomplete.hs diff --git a/.gitignore b/.gitignore index 4ea955f..31f7a94 100644 --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,7 @@ !package.yaml !app/Main.hs !src/CAStore/Command.hs +!src/CAStore/Command/Autocomplete.hs !src/CAStore/Command/Type.hs !src/CAStore/Config.hs !src/CAStore/Config/Type.hs diff --git a/app/Main.hs b/app/Main.hs index 7082dad..ae83e0e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,9 @@ module Main(main) where import CAStore.Command (runCommand) +import CAStore.Command.Autocomplete (generateAutocompletions) import CAStore.Config (finalConfig) -import CAStore.Program (Program, runProgram, getCommand) +import CAStore.Program (Program, runProgram, getCommand, getAutocomplete) import CAStore.Program.IO.Text (err) import CAStore.Program.Storage (initialise) @@ -12,4 +13,6 @@ main = finalConfig >>= flip runProgram defaultProgram defaultProgram :: Program () defaultProgram = do initialise - getCommand >>= either err runCommand + getAutocomplete >>= \case + True -> generateAutocompletions + False -> getCommand >>= either err runCommand diff --git a/package.yaml b/package.yaml index d730e30..4a266ad 100644 --- a/package.yaml +++ b/package.yaml @@ -47,6 +47,7 @@ library: - sqlite-simple exposed-modules: - CAStore.Command + - CAStore.Command.Autocomplete - CAStore.Command.Type - CAStore.Config - CAStore.Config.CLI diff --git a/src/CAStore/Command/Autocomplete.hs b/src/CAStore/Command/Autocomplete.hs new file mode 100644 index 0000000..a3d190b --- /dev/null +++ b/src/CAStore/Command/Autocomplete.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CAStore.Command.Autocomplete + ( generateAutocompletions + ) +where + +import CAStore.Program.Internal (Program(..), getArguments, getConnectionHandle) +import CAStore.Program.IO.Text (msg) +import CAStore.Type.Text (Message(MsgArb)) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (for_) +import Database.SQLite.Simple (Query, query_, fromOnly) + +generateAutocompletions :: Program () +generateAutocompletions = + getArguments >>= (outputAutocomplete . autocompleteM) + +{-| + 'Autocomplete' represents the results of an autocompletion, usually + accessed by pressing in a shell such as bash, zsh, etc... +-} +data Autocomplete + -- | A pure list of expected options + = ACList [String] + -- | A file path + | ACFile + -- | A store ID found in the store + | ACStoreId + -- | A tag found in the store + | ACTag + +{-| + Output the results, one per line, to standard output. The completion + script reads these and generates completions for the user. + + ## TODO ## + Some shells (e.g. bash) will not use the output directly and will + mangle the results. Will have to find a way to escape out output to + avoid this +-} +outputAutocomplete :: Autocomplete -> Program () +outputAutocomplete (ACList xs) + = for_ xs $ msg . MsgArb +outputAutocomplete ACFile + = pure () -- TODO: Stub +outputAutocomplete ACStoreId + = runACSql "SELECT hash FROM file" +outputAutocomplete ACTag + = runACSql "SELECT name FROM tag" + +runACSql :: Query -> Program () +runACSql q = do + h <- getConnectionHandle + res <- Program $ liftIO $ fmap fromOnly <$> query_ h q + for_ res $ msg . MsgArb + +{-| + 'autocompleteM' is a Moore machine with input 'String' and + output 'Autocomplete'. +-} +autocompleteM :: [String] -> Autocomplete +autocompleteM [] = + ACList [ "file", "tag" ] +autocompleteM ("file":[]) = + ACList [ "add", "remove", "verify" ] +autocompleteM ("file":"add":_) = + ACFile +autocompleteM ("file":"remove":_) = + ACStoreId +autocompleteM ("file":"verify":_) = + ACStoreId +autocompleteM ("tag":[]) = + ACList [ "add", "remove", "show", "super", "sub" ] +autocompleteM ("tag":"add":[]) = + ACStoreId +autocompleteM ("tag":"add":_:_) = + ACTag +autocompleteM ("tag":"remove":[]) = + ACStoreId +autocompleteM ("tag":"remove":_:_) = + ACTag +autocompleteM ("tag":"show":[]) = + ACStoreId +autocompleteM ("tag":"show":_:[]) = + ACList [] +autocompleteM ("tag":"super":[]) = + ACList [ "add", "remove", "show" ] +autocompleteM ("tag":"super":"add":[]) = + ACTag +autocompleteM ("tag":"super":"add":_:_) = + ACTag +autocompleteM ("tag":"super":"remove":[]) = + ACTag +autocompleteM ("tag":"super":"remove":_:_) = + ACTag +autocompleteM ("tag":"super":"show":[]) = + ACTag +autocompleteM ("tag":"super":"show":_:[]) = + ACTag +autocompleteM ("tag":"sub":[]) = + ACList [ "add", "remove", "show" ] +autocompleteM ("tag":"sub":"add":[]) = + ACTag +autocompleteM ("tag":"sub":"add":_:_) = + ACTag +autocompleteM ("tag":"sub":"remove":[]) = + ACTag +autocompleteM ("tag":"sub":"remove":_:_) = + ACTag +autocompleteM ("tag":"sub":"show":[]) = + ACTag +autocompleteM ("tag":"sub":"show":_:[]) = + ACTag +autocompleteM _ = + ACList [] diff --git a/src/CAStore/Command/Type.hs b/src/CAStore/Command/Type.hs index 42f9409..98ac4d9 100644 --- a/src/CAStore/Command/Type.hs +++ b/src/CAStore/Command/Type.hs @@ -21,29 +21,38 @@ data Command | TagSubShow Tag deriving (Show) +{-| + 'parseCommand' is effectively a Moore machine on 'String'. We can + represent a Moore machine as a pure function from [String]. + + Every command line may have a valid command. For now there is only one error + and so I could simplify this type to 'Maybe Command'. However I do intend for + better error messages later. +-} parseCommand :: [String] -> Either Error Command -parseCommand ("file":"add":xs) - = pure $ FileAdd xs -parseCommand ("file":"remove":xs) - = pure $ FileRemove $ StoreId <$> xs -parseCommand ("file":"verify":xs) - = pure $ FileVerify $ StoreId <$> xs -parseCommand ("tag":"add":x:xs) - = pure $ TagAdd (StoreId x) (Tag <$> xs) -parseCommand ("tag":"remove":x:xs) - = pure $ TagRemove (StoreId x) (Tag <$> xs) -parseCommand ("tag":"show":x:[]) - = pure $ TagShow (StoreId x) -parseCommand ("tag":"super":"add":x:xs) - = pure $ TagSuperAdd (Tag x) (Tag <$> xs) -parseCommand ("tag":"sub":"add":x:xs) - = pure $ TagSubAdd (Tag x) (Tag <$> xs) -parseCommand ("tag":"super":"remove":x:xs) - = pure $ TagSuperRemove (Tag x) (Tag <$> xs) -parseCommand ("tag":"sub":"remove":x:xs) - = pure $ TagSubRemove (Tag x) (Tag <$> xs) -parseCommand ("tag":"super":"show":x:[]) - = pure $ TagSuperShow $ Tag x -parseCommand ("tag":"sub":"show":x:[]) - = pure $ TagSubShow $ Tag x -parseCommand xs = Left $ ErrInvalidCommand xs +parseCommand ("file":"add":xs) = + pure $ FileAdd xs +parseCommand ("file":"remove":xs) = + pure $ FileRemove $ StoreId <$> xs +parseCommand ("file":"verify":xs) = + pure $ FileVerify $ StoreId <$> xs +parseCommand ("tag":"add":x:xs) = + pure $ TagAdd (StoreId x) (Tag <$> xs) +parseCommand ("tag":"remove":x:xs) = + pure $ TagRemove (StoreId x) (Tag <$> xs) +parseCommand ("tag":"show":x:[]) = + pure $ TagShow (StoreId x) +parseCommand ("tag":"super":"add":x:xs) = + pure $ TagSuperAdd (Tag x) (Tag <$> xs) +parseCommand ("tag":"super":"remove":x:xs) = + pure $ TagSuperRemove (Tag x) (Tag <$> xs) +parseCommand ("tag":"super":"show":x:[]) = + pure $ TagSuperShow (Tag x) +parseCommand ("tag":"sub":"add":x:xs) = + pure $ TagSubAdd (Tag x) (Tag <$> xs) +parseCommand ("tag":"sub":"remove":x:xs) = + pure $ TagSubRemove (Tag x) (Tag <$> xs) +parseCommand ("tag":"sub":"show":x:[]) = + pure $ TagSubShow (Tag x) +parseCommand xs = + Left $ ErrInvalidCommand xs diff --git a/src/CAStore/Config/CLI.hs b/src/CAStore/Config/CLI.hs index dd712ea..732e53c 100644 --- a/src/CAStore/Config/CLI.hs +++ b/src/CAStore/Config/CLI.hs @@ -21,4 +21,5 @@ parser :: Config Parser parser = Config { storeLocation = argument (maybeReader (either (const Nothing) Just . parseStoreLocation)) (metavar "STORE") , arguments = some (strArgument (metavar "COMMAND")) + , autocomplete = switch $ long "completion" } diff --git a/src/CAStore/Config/Type.hs b/src/CAStore/Config/Type.hs index a03d9cb..7d87a02 100644 --- a/src/CAStore/Config/Type.hs +++ b/src/CAStore/Config/Type.hs @@ -23,6 +23,7 @@ import GHC.Generics (Generic) data Config f = Config { storeLocation :: f StoreLocation , arguments :: f [String] + , autocomplete :: f Bool } deriving stock (Generic) deriving anyclass (FunctorB, TraversableB, ApplicativeB, ConstraintsB) @@ -35,4 +36,5 @@ defaultConfig :: Config Maybe defaultConfig = Config { storeLocation = Nothing , arguments = Just [] + , autocomplete = pure False } diff --git a/src/CAStore/Program.hs b/src/CAStore/Program.hs index 5ac137a..fb7bfca 100644 --- a/src/CAStore/Program.hs +++ b/src/CAStore/Program.hs @@ -5,6 +5,7 @@ module CAStore.Program , getStoreRoot , getCommand , getFileLocation + , getAutocomplete -- * File Operations , storeFile @@ -12,12 +13,17 @@ module CAStore.Program ) where +import CAStore.Command.Type (Command, parseCommand) import CAStore.Program.Internal import CAStore.Type import Control.Monad.IO.Class (liftIO) import qualified System.Directory as D import System.FilePath (takeDirectory) +-- | Parse the command line arguments and (hopefully) get the command. +getCommand :: Program (Either Error Command) +getCommand = parseCommand <$> getArguments + -- | Add a file to the store -- You must already have a 'StoreId' to use this function. You get one by -- adding the file to the database. diff --git a/src/CAStore/Program/Internal.hs b/src/CAStore/Program/Internal.hs index 7d6c11d..9153959 100644 --- a/src/CAStore/Program/Internal.hs +++ b/src/CAStore/Program/Internal.hs @@ -5,12 +5,12 @@ module CAStore.Program.Internal , getConnectionHandle , getStoreRoot , getFileLocation - , getCommand + , getArguments + , getAutocomplete ) where -import CAStore.Command.Type (Command(..), parseCommand) -import CAStore.Config (Config(..)) +import qualified CAStore.Config as C import CAStore.Type import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (ReaderT(..), asks) @@ -23,9 +23,9 @@ newtype Program a = Program (ReaderT Env IO a) deriving (Functor, Applicative, Monad, MonadIO) via (ReaderT Env IO) -runProgram :: Config Identity -> Program a -> IO a +runProgram :: C.Config Identity -> Program a -> IO a runProgram cfg (Program x) = do - root <- defineStoreRoot $ runIdentity $ storeLocation cfg + root <- defineStoreRoot $ runIdentity $ C.storeLocation cfg D.createDirectoryIfMissing True root let db = root "db.db" withConnection db (runReaderT x . makeEnv cfg root) @@ -39,14 +39,16 @@ defineStoreRoot (StoreShort p) = do data Env = Env { handle :: Connection , storeRoot :: FilePath - , mCommand :: Either Error Command + , arguments :: [String] + , autocomplete :: Bool } -makeEnv :: Config Identity -> FilePath -> Connection -> Env +makeEnv :: C.Config Identity -> FilePath -> Connection -> Env makeEnv cfg root conn = Env { handle = conn , storeRoot = root - , mCommand = parseCommand $ runIdentity $ arguments cfg + , arguments = runIdentity $ C.arguments cfg + , autocomplete = runIdentity $ C.autocomplete cfg } getConnectionHandle :: Program Connection @@ -61,5 +63,8 @@ getFileLocation (StoreId x) = (\root -> root "files" (take 2 x) x) <$> getStoreRoot -getCommand :: Program (Either Error Command) -getCommand = Program $ asks mCommand +getArguments :: Program [String] +getArguments = Program $ asks arguments + +getAutocomplete :: Program Bool +getAutocomplete = Program $ asks autocomplete