diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 edit +task-manager -d open +task-manager -d close +task-manager -d tasks +task-manager -d priorities +task-manager -d +``` + + +The library is based around the following classes: ```haskell class Unrender r where diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/commander-cli.cabal b/commander-cli.cabal --- a/commander-cli.cabal +++ b/commander-cli.cabal @@ -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 diff --git a/src/Options/Commander.hs b/src/Options/Commander.hs --- a/src/Options/Commander.hs +++ b/src/Options/Commander.hs @@ -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