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

@@ -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

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

package.yaml

@@ -47,6 +47,7 @@ library:
   - sqlite-simple
   exposed-modules:
   - CAStore.Command
+  - CAStore.Command.Autocomplete
   - CAStore.Command.Type
   - CAStore.Config
   - CAStore.Config.CLI

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 <TAB> 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 []

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)
+parseCommand ("file":"add":xs) =
-  = pure $ FileAdd xs
+  pure $ FileAdd xs
-parseCommand ("file":"remove":xs)
+parseCommand ("file":"remove":xs) =
-  = pure $ FileRemove $ StoreId <$> xs
+  pure $ FileRemove $ StoreId <$> xs
-parseCommand ("file":"verify":xs)
+parseCommand ("file":"verify":xs) =
-  = pure $ FileVerify $ StoreId <$> xs
+  pure $ FileVerify $ StoreId <$> xs
-parseCommand ("tag":"add":x:xs)
+parseCommand ("tag":"add":x:xs) =
-  = pure $ TagAdd (StoreId x) (Tag <$> xs)
+  pure $ TagAdd (StoreId x) (Tag <$> xs)
-parseCommand ("tag":"remove":x:xs)
+parseCommand ("tag":"remove":x:xs) =
-  = pure $ TagRemove (StoreId x) (Tag <$> xs)
+  pure $ TagRemove (StoreId x) (Tag <$> xs)
-parseCommand ("tag":"show":x:[])
+parseCommand ("tag":"show":x:[]) =
-  = pure $ TagShow (StoreId x)
+  pure $ TagShow (StoreId x)
-parseCommand ("tag":"super":"add":x:xs)
+parseCommand ("tag":"super":"add":x:xs) =
-  = pure $ TagSuperAdd (Tag x) (Tag <$> xs)
+  pure $ TagSuperAdd (Tag x) (Tag <$> xs)
-parseCommand ("tag":"sub":"add":x:xs)
+parseCommand ("tag":"super":"remove":x:xs) =
-  = pure $ TagSubAdd (Tag x) (Tag <$> xs)
+  pure $ TagSuperRemove (Tag x) (Tag <$> xs)
-parseCommand ("tag":"super":"remove":x:xs)
+parseCommand ("tag":"super":"show":x:[]) =
-  = pure $ TagSuperRemove (Tag x) (Tag <$> xs)
+  pure $ TagSuperShow (Tag x)
-parseCommand ("tag":"sub":"remove":x:xs)
+parseCommand ("tag":"sub":"add":x:xs) =
-  = pure $ TagSubRemove (Tag x) (Tag <$> xs)
+  pure $ TagSubAdd (Tag x) (Tag <$> xs)
-parseCommand ("tag":"super":"show":x:[])
+parseCommand ("tag":"sub":"remove":x:xs) =
-  = pure $ TagSuperShow $ Tag x
+  pure $ TagSubRemove (Tag x) (Tag <$> xs)
-parseCommand ("tag":"sub":"show":x:[])
+parseCommand ("tag":"sub":"show":x:[]) =
-  = pure $ TagSubShow $ Tag x
+  pure $ TagSubShow (Tag x)
-parseCommand xs = Left $ ErrInvalidCommand xs
+parseCommand xs =
+  Left $ ErrInvalidCommand xs

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"
   }

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
   }

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.

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 qualified CAStore.Config as C
-import CAStore.Config (Config(..))
 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)
+getArguments :: Program [String]
-getCommand = Program $ asks mCommand
+getArguments = Program $ asks arguments
+
+getAutocomplete :: Program Bool
+getAutocomplete = Program $ asks autocomplete