commander-cli 0.4.1.2 → 0.5.0.0
raw patch · 5 files changed
+88/−53 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Options.Commander: optDef :: (KnownSymbol option, KnownSymbol name) => x -> (x -> ProgramT p m a) -> ProgramT (Opt option name x & p) m a
Files
- README.md +16/−2
- Test.hs +8/−0
- app/Main.hs +46/−44
- commander-cli.cabal +1/−1
- src/Options/Commander.hs +17/−6
README.md view
@@ -5,8 +5,22 @@ This library is meant to allow Haskell programs to quickly and easily construct command line interfaces which are easy to use, especially as a Haskell user. To-begin, I suggest viewing the task-manager application which comes with this-repository. The library is based around the following classes:+begin, I suggest viewing/playing with the task-manager application which+comes with this repository. Its usage info is generated as:++```bash+usage:+task-manager help +task-manager -d <task-directory :: [Char]> edit <task-name :: [Char]> +task-manager -d <task-directory :: [Char]> open <task-name :: [Char]> +task-manager -d <task-directory :: [Char]> close <task-name :: [Char]> +task-manager -d <task-directory :: [Char]> tasks +task-manager -d <task-directory :: [Char]> priorities +task-manager -d <task-directory :: [Char]> +```+++The library is based around the following classes: ```haskell class Unrender r where
Test.hs view
@@ -69,3 +69,11 @@ testBool =<< isNothing <$> test bigProg (State ["argument"] (HashMap.fromList [("opt", "option")]) (HashSet.singleton "flag")) testBool =<< (== Just False) <$> test bigProg (State ["option"] (HashMap.fromList [("opt'", "option")]) mempty) testBool =<< (== Just False) <$> test bigProg (State ["option"] (HashMap.fromList [("opt", "1")]) (HashSet.singleton "flag"))++optDefProg :: (String -> Bool) -> ProgramT (Opt "o" "opt" String & Raw) IO Bool+optDefProg prop = optDef "Default" \o -> raw (pure (prop o))++optDefTest :: IO ()+optDefTest = parlay (== "Default") (State mempty mempty mempty)+ >> parlay (== "hello") (State mempty (HashMap.fromList [("o", "hello")]) mempty) where+ parlay prop state = maybe exitFailure (cond (pure ()) exitFailure) =<< runCommanderT (run (optDefProg prop)) state
app/Main.hs view
@@ -20,25 +20,27 @@ import Data.Either type TaskManager- = Named "task-manager" &- ( "help" & Raw- + "edit" & TaskProgram- + "open" & TaskProgram- + "close" & TaskProgram- + "tasks" & Raw- + "priorities" & Raw- + Raw+ = Named "task-manager"+ & ("help" & Raw+ + Opt "d" "task-directory" FilePath+ & ("edit" & TaskProgram+ + "open" & TaskProgram+ + "close" & TaskProgram+ + "tasks" & Raw+ + "priorities" & Raw+ + Raw+ ) ) type TaskProgram = Arg "task-name" String & Raw taskManager :: ProgramT TaskManager IO ()-taskManager = toplevel @"task-manager" - $ sub @"edit" editTask- <+> sub @"open" newTask- <+> sub @"close" closeTask- <+> sub @"tasks" listTasks- <+> sub @"priorities" listPriorities+taskManager = toplevel @"task-manager" . optDef @"d" @"task-directory" "tasks" $ \tasksFilePath -> + sub @"edit" (editTask tasksFilePath) + <+> sub @"open" (newTask tasksFilePath)+ <+> sub @"close" (closeTask tasksFilePath)+ <+> sub @"tasks" (listTasks tasksFilePath)+ <+> sub @"priorities" (listPriorities tasksFilePath) <+> hoist describeTaskManager (usage @TaskManager) where describeTaskManager :: IO a -> IO a@@ -46,35 +48,35 @@ putStrLn "Welcome to the Task Manager! This is a tool to help you manage tasks, each with priorities." io -editTask = arg @"task-name" $ \taskName -> raw - $ withTask taskName $ \Context{home} task -> callProcess "vim" [home ++ "/tasks/" ++ taskName ++ ".task"]+editTask tasksFilePath = arg @"task-name" $ \taskName -> raw + $ withTask tasksFilePath taskName $ \Context{home} task -> callProcess "vim" [home ++ "/" <> tasksFilePath <> "/" ++ taskName ++ ".task"] -newTask = arg @"task-name" $ \taskName -> raw $ do- Context{home, tasks} <- initializeOrFetch+newTask tasksFilePath = arg @"task-name" $ \taskName -> raw $ do+ Context{home, tasks} <- initializeOrFetch tasksFilePath if not (taskName `elem` tasks) then do- let path = home ++ "/tasks/" ++ taskName ++ ".task"+ let path = home ++ "/" <> tasksFilePath <> "/" ++ taskName ++ ".task" callProcess "touch" [path] appendFile path (renderPriorities $ []) callProcess "vim" [path] else putStrLn $ "task " ++ taskName ++ " already exists." -closeTask = arg @"task-name" $ \taskName -> raw - $ withTask taskName $ \Context{home, tasks} mtask ->+closeTask tasksFilePath = arg @"task-name" $ \taskName -> raw + $ withTask tasksFilePath taskName $ \Context{home, tasks} mtask -> case mtask of Just Task{priorities} -> if priorities == [] - then removeFile (home ++ "/tasks/" ++ taskName ++ ".task")+ then removeFile (home ++ "/" <> tasksFilePath <> "/" ++ taskName ++ ".task") else putStrLn $ "task " ++ taskName ++ " has remaining priorities." Nothing -> putStrLn "task is corrupted" -listTasks = raw $ do- Context{tasks} <- initializeOrFetch+listTasks tasksFilePath = raw $ do+ Context{tasks} <- initializeOrFetch tasksFilePath mapM_ putStrLn tasks -listPriorities = raw $ do- Context{tasks} <- initializeOrFetch- forM_ tasks $ \taskName -> withTask taskName $ \_ mtask -> +listPriorities tasksFilePath = raw $ do+ Context{tasks} <- initializeOrFetch tasksFilePath+ forM_ tasks $ \taskName -> withTask tasksFilePath taskName $ \_ mtask -> case mtask of Just Task{name, priorities} -> do putStrLn $ name ++ ": "@@ -91,22 +93,22 @@ , priorities :: [(String, String)] } deriving (Show, Read) -readTask :: String -> IO (Maybe Task)-readTask taskName = do- Context{home, tasks} <- initializeOrFetch+readTask :: FilePath -> String -> IO (Maybe Task)+readTask tasksFilePath taskName = do+ Context{home, tasks} <- initializeOrFetch tasksFilePath if taskName `elem` tasks then do- let path = home ++ "/tasks/" ++ taskName ++ ".task"+ let path = home ++ "/" <> tasksFilePath <> "/" ++ taskName ++ ".task" stringTask <- readFile path return $ parseTask taskName stringTask else do putStrLn $ "task " ++ taskName ++ " does not exist." exitSuccess -writeTask :: Task -> IO ()-writeTask Task{name, priorities} = do- Context{home, tasks} <- initializeOrFetch- let path = home ++ "/tasks/" ++ name ++ ".task"+writeTask :: FilePath -> Task -> IO ()+writeTask tasksFilePath Task{name, priorities} = do+ Context{home, tasks} <- initializeOrFetch tasksFilePath+ let path = home ++ "/" <> tasksFilePath <> "/" ++ name ++ ".task" writeFile path $ renderPriorities priorities renderPriorities :: [(String, String)] -> String@@ -133,23 +135,23 @@ Right _ : xs -> Nothing [] -> Just $ Task taskName [] -withTask :: String -> (Context -> Maybe Task -> IO ()) -> IO ()-withTask taskName action = do- c@Context{tasks, home} <- initializeOrFetch+withTask :: FilePath -> String -> (Context -> Maybe Task -> IO ()) -> IO ()+withTask tasksFilePath taskName action = do+ c@Context{tasks, home} <- initializeOrFetch tasksFilePath if taskName `elem` tasks then do- readTask taskName >>= \case+ readTask tasksFilePath taskName >>= \case Just task -> action c (Just task) Nothing -> action c Nothing else putStrLn $ "task " ++ taskName ++ " does not exist." -initializeOrFetch :: IO Context-initializeOrFetch = do+initializeOrFetch :: FilePath -> IO Context+initializeOrFetch tasksFilePath = do home <- getHomeDirectory >>= makeAbsolute withCurrentDirectory home $ do- doesDirectoryExist "tasks" >>= \case- True -> Context home . map (takeWhile (/= '.')) . filter (".task" `isSuffixOf`) <$> listDirectory "tasks"- False -> Context home [] <$ createDirectory "tasks"+ doesDirectoryExist tasksFilePath >>= \case+ True -> Context home . map (takeWhile (/= '.')) . filter (".task" `isSuffixOf`) <$> listDirectory tasksFilePath+ False -> Context home [] <$ createDirectory tasksFilePath main :: IO () main = command_ taskManager
commander-cli.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: commander-cli-version: 0.4.1.2+version: 0.5.0.0 synopsis: A command line argument/option parser library built around a monadic metaphor description: A command line argument/option parser library built around a monadic metaphor. homepage: https://github.com/SamuelSchlesinger/commander-cli
src/Options/Commander.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingVia #-}@@ -77,7 +79,7 @@ We also have a convenience combinator, 'toplevel', which lets you add a name and a help command to your program using the 'usage' combinator. -}- arg, opt, raw, sub, named, flag, toplevel, (<+>), usage,+ arg, opt, optDef, raw, sub, named, flag, toplevel, (<+>), usage, -- ** Describing CLI Programs -- ** Run CLI Programs {- |@@ -98,7 +100,7 @@ -} HasProgram(run, hoist, invocations), ProgramT(ArgProgramT, unArgProgramT,- OptProgramT, unOptProgramT,+ OptProgramT, unOptProgramT, unOptDefault, RawProgramT, unRawProgramT, SubProgramT, unSubProgramT, NamedProgramT, unNamedProgramT,@@ -423,15 +425,17 @@ instance (KnownSymbol name, KnownSymbol option, HasProgram p, Unrender t) => HasProgram (Opt option name t & p) where- newtype ProgramT (Opt option name t & p) m a = OptProgramT { unOptProgramT :: Maybe t -> ProgramT p m a }+ data ProgramT (Opt option name t & p) m a = OptProgramT+ { unOptProgramT :: Maybe t -> ProgramT p m a+ , unOptDefault :: Maybe t } run f = Action $ \State{..} -> do case HashMap.lookup (pack $ symbolVal (Proxy @option)) options of Just opt' -> case unrender opt' of Just t -> return (run (unOptProgramT f (Just t)), State{..}) Nothing -> return (Defeat, State{..})- Nothing -> return (run (unOptProgramT f Nothing), State{..})- hoist n (OptProgramT f) = OptProgramT (hoist n . f)+ Nothing -> return (run (unOptProgramT f (unOptDefault f)), State{..})+ hoist n (OptProgramT f d) = OptProgramT (hoist n . f) d invocations = [(("-" <> (pack $ symbolVal (Proxy @option)) <> " <" <> (pack $ symbolVal (Proxy @name)) @@ -508,7 +512,14 @@ opt :: (KnownSymbol option, KnownSymbol name) => (Maybe x -> ProgramT p m a) -> ProgramT (Opt option name x & p) m a-opt = OptProgramT+opt = flip OptProgramT Nothing++-- | Option combinator with default+optDef :: (KnownSymbol option, KnownSymbol name)+ => x+ -> (x -> ProgramT p m a)+ -> ProgramT (Opt option name x & p) m a+optDef x f = OptProgramT { unOptDefault = Just x, unOptProgramT = \case { Just x -> f x; Nothing -> error "Violated invariant of optDef" } } -- | Raw monadic combinator raw :: m a