commander-cli 0.3.0.0 → 0.4.0.0

raw patch · 4 files changed

+137/−24 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Test.hs +32/−6
• app/Main.hs +10/−3
• commander-cli.cabal +3/−2
• src/Options/Commander.hs +92/−13

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}@@ -7,20 +8,29 @@  import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap+import Data.Word (Word64) import Data.Text import Control.Concurrent import Options.Commander import Control.Monad import System.Exit+import Control.Exception+import Data.Maybe  main :: IO ()-main = rawTest >> argTest >> optTest >> flagTest+main = rawTest >> argTest >> optTest >> flagTest >> bigProgTests  rawProg :: ProgramT Raw IO Bool rawProg = raw (pure True) +testMaybeBool :: Maybe Bool -> IO ()+testMaybeBool = maybe exitFailure (cond (pure ()) exitFailure)++testBool :: Bool -> IO ()+testBool = cond (pure ()) exitFailure+ rawTest :: IO ()-rawTest = maybe exitFailure (cond exitSuccess exitFailure) =<< runCommanderT (run rawProg) (State mempty mempty mempty)+rawTest = maybe exitFailure (cond (pure ()) exitFailure) =<< runCommanderT (run rawProg) (State mempty mempty mempty)  argProg :: (String -> Bool) -> ProgramT (Arg "arg" String & Raw) IO Bool argProg prop = arg \a -> raw (pure (prop a))@@ -30,16 +40,32 @@ cond x y False = y  argTest :: IO ()-argTest = maybe exitFailure (cond exitSuccess exitFailure) =<< runCommanderT (run (argProg (== "hello"))) (State ["hello"] mempty mempty)+argTest = maybe exitFailure (cond (pure ()) exitFailure) =<< runCommanderT (run (argProg (== "hello"))) (State ["hello"] mempty mempty)  optProg :: (Maybe String -> Bool) -> ProgramT (Opt "opt" "opt" String & Raw) IO Bool optProg prop = opt \o -> raw (pure (prop o))  optTest :: IO ()-optTest = maybe exitFailure (cond exitSuccess exitFailure) =<< runCommanderT (run (optProg (== Just "hello"))) (State mempty (HashMap.fromList [("opt", "hello")]) mempty)+optTest = maybe exitFailure (cond (pure ()) exitFailure) =<< runCommanderT (run (optProg (== Just "hello"))) (State mempty (HashMap.fromList [("opt", "hello")]) mempty) -flagProg :: ProgramT (Flag "flag" & Raw) IO Bool+flagProg :: Monad m => ProgramT (Flag "flag" & Raw) m Bool flagProg = flag (raw . pure)  flagTest :: IO ()-flagTest = maybe exitFailure (cond exitSuccess exitFailure) =<< runCommanderT (run flagProg) (State mempty mempty (HashSet.fromList ["flag"]))+flagTest = maybe exitFailure (cond (pure ()) exitFailure) =<< runCommanderT (run flagProg) (State mempty mempty (HashSet.fromList ["flag"]))++test :: HasProgram p => ProgramT p IO Bool -> State -> IO (Maybe Bool)+test prog state = runCommanderT (logState $ run prog) state++bigProg :: Monad m => ProgramT ("argument" & Arg "arg" String & Flag "flag" & Raw + Opt "opt" "option-test" Word64 & "option" & Raw) m Bool+bigProg = (sub @"argument" $ arg $ \a -> flag $ \f -> raw $ pure $ f && a == "arg") <+> (opt \o -> sub @"option" $ raw $ pure (o == Just 0))++bigProgTests :: IO ()+bigProgTests = do+  testMaybeBool =<< test bigProg (State ["argument", "arg"] mempty (HashSet.singleton "flag"))+  testMaybeBool =<< test bigProg (State ["option"] (HashMap.fromList [("opt", "0")]) mempty)+  testBool =<< isNothing <$> test bigProg (State ["argument"] mempty mempty)+  testBool =<< isNothing <$> test bigProg (State ["argument"] (HashMap.fromList [("opt", "option")]) mempty)+  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"))

@@ -27,17 +27,24 @@   + "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 @"edit" editTask+  <+> sub @"open" newTask+  <+> sub @"close" closeTask   <+> sub @"tasks" listTasks   <+> sub @"priorities" listPriorities+  <+> hoist describeTaskManager (usage @TaskManager)+  where+    describeTaskManager :: IO a -> IO a+    describeTaskManager io = do+      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"]

@@ -1,7 +1,7 @@ cabal-version:       2.4  name:                commander-cli-version:             0.3.0.0+version:             0.4.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@@ -34,7 +34,8 @@                        PolyKinds,                        GADTs,                        TypeOperators,-                       DataKinds+                       DataKinds,+                       DeriveGeneric   build-depends:       base >=4.12 && < 5,                        mtl >=2.2 && <2.3,                        text >=1.2 && < 1.3,

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE StandaloneDeriving #-}@@ -28,7 +29,7 @@  Commander is an embedded domain specific language describing a command line interface, along with ways to run those as real programs. An complete example-of such a command line interface can be found as:+of such a command line interface is:  @ main :: IO ()@@ -47,10 +48,21 @@       Nothing -> pure ()) @ +If I run this program with the argument help, it will output:++@+usage:+file maybe-read \<filename :: String\> ~read+file maybe-write -file \<file-to-write :: String\>+@+ The point of this library is mainly so that you can write command line-interfaces quickly and easily, and not have to write any boilerplate.+interfaces quickly and easily, with somewhat useful help messages, and +not have to write any boilerplate. -} module Options.Commander (+  -- ** Parsing Arguments and Options+  Unrender(unrender),   -- ** Run CLI Programs   command, command_,   -- ** CLI Combinators@@ -69,11 +81,12 @@            ),   -- ** The CommanderT Monad   CommanderT(Action, Defeat, Victory), runCommanderT, initialState, State(State, arguments, options, flags),-  -- ** Parsing Arguments and Options-  Unrender(unrender),+  -- ** Middleware for CommanderT+  Middleware, logState, transform, withActionEffects, withDefeatEffects, withVictoryEffects ) where  import Control.Applicative (Alternative(..))+import Control.Arrow (first) import Control.Monad ((<=<)) import Control.Monad (ap, void) import Control.Monad.Trans (MonadIO(..), MonadTrans(..))@@ -85,11 +98,13 @@ import Data.Text.Read (decimal, signed) import Data.Word import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import GHC.Generics (Generic) import Numeric.Natural import System.Environment (getArgs)+import Data.Typeable (Typeable, typeRep)  -- | A class for interpreting command line arguments into Haskell types.-class Unrender t where+class Typeable t => Unrender t where   unrender :: Text -> Maybe t  instance Unrender String where@@ -123,7 +138,7 @@ newtype WrappedIntegral i = WrappedIntegral i   deriving newtype (Num, Real, Ord, Eq, Enum, Integral) -instance Integral i => Unrender (WrappedIntegral i) where+instance (Typeable i, Integral i) => Unrender (WrappedIntegral i) where   unrender = either (const Nothing) h . signed decimal where     h (n, "") = Just (fromInteger n)     h _ = Nothing@@ -138,7 +153,7 @@ newtype WrappedNatural i = WrappedNatural i   deriving newtype (Num, Real, Ord, Eq, Enum, Integral) -instance Integral i => Unrender (WrappedNatural i) where+instance (Typeable i, Integral i) => Unrender (WrappedNatural i) where   unrender = either (const Nothing) h . decimal where     h (n, "") = if n >= 0 then Just (fromInteger n) else Nothing     h _ = Nothing @@ -312,7 +327,8 @@ data State = State    { arguments :: [Text]   , options :: HashMap Text Text-  , flags :: HashSet Text }+  , flags :: HashSet Text+  } deriving (Generic, Show, Eq, Ord)  -- | This is the workhorse of the library. Basically, it allows you to  -- 'run' your 'ProgramT'@@ -341,7 +357,10 @@           Nothing -> return (Defeat, State{..})       [] -> return (Defeat, State{..})   hoist n (ArgProgramT f) = ArgProgramT (hoist n . f)-  invocations = [(("<" <> pack (symbolVal (Proxy @name)) <> "> ") <>)] <*> invocations @p+  invocations =+    [(("<" <> pack (symbolVal (Proxy @name))+    <> " :: " <> pack (show (typeRep (Proxy @t)))+    <> "> ") <>)] <*> invocations @p  instance (HasProgram x, HasProgram y) => HasProgram (x + y) where   data ProgramT (x + y) m a = ProgramT x m a :+: ProgramT y m a@@ -368,7 +387,11 @@           Nothing -> return (Defeat, State{..})       Nothing  -> return (run (unOptProgramT f Nothing), State{..})   hoist n (OptProgramT f) = OptProgramT (hoist n . f)-  invocations = [(("-" <> (pack $ symbolVal (Proxy @option)) <> " <" <> (pack $ symbolVal (Proxy @name)) <> "> ") <>)  ] <*> invocations @p+  invocations =+    [(("-" <> (pack $ symbolVal (Proxy @option)) +    <> " <" <> (pack $ symbolVal (Proxy @name)) +    <> " :: " <> (pack $ show (typeRep (Proxy @t)))+    <> "> ") <>)  ] <*> invocations @p  instance (KnownSymbol flag, HasProgram p) => HasProgram (Flag flag & p) where   newtype ProgramT (Flag flag & p) m a = FlagProgramT { unFlagProgramT :: Bool -> ProgramT p m a }@@ -467,10 +490,10 @@  -- | A convenience combinator that constructs the program I often want -- to run out of a program I want to write.-toplevel :: forall s p m a. (HasProgram p, KnownSymbol s, MonadIO m) +toplevel :: forall s p m. (HasProgram p, KnownSymbol s, MonadIO m)           => ProgramT p m ()           -> ProgramT (Named s & ("help" & Raw + p)) m ()-toplevel p = named (sub (usage @(Named s & (p + "help" & Raw))) <+> p)+toplevel p = named (sub (usage @(Named s & ("help" & Raw + p))) <+> p)  -- | The command line program which consists of trying to enter one and -- then trying the other.@@ -481,7 +504,63 @@  -- | A meta-combinator that takes a type-level description of a command  -- line program and produces a simple usage program.-usage :: forall p m a. (MonadIO m, HasProgram p) => ProgramT Raw m ()+usage :: forall p m. (MonadIO m, HasProgram p) => ProgramT Raw m () usage = raw $ do   liftIO $ putStrLn "usage:"   void . traverse (liftIO . putStrLn . unpack) $ invocations @p++-- | The type of middleware, which can transform interpreted command line programs+-- by meddling with arguments, options, or flags, or by adding effects for+-- every step. You can also change the underlying monad.+type Middleware m n = forall a. CommanderT State m a -> CommanderT State n a++-- | Middleware to transform the base monad with a natural transformation.+transform :: (Monad m, Monad n) => (forall a. m a -> n a) -> Middleware m n+transform f commander = case commander of+  Action a -> Action $ \state -> do+    (commander', state') <- f (a state)+    pure (transform f commander', state')+  Defeat -> Defeat+  Victory a -> Victory a ++-- | Middleware to add monadic effects for every 'Action'. Useful for+-- debugging complex command line programs.+withActionEffects :: Monad m => m a -> Middleware m m+withActionEffects ma = transform (ma *>)++-- | Middleware to have effects whenever the program might backtrack.+withDefeatEffects :: Monad m => m a -> Middleware m m+withDefeatEffects ma commander = case commander of+  Action a -> Action $ \state -> do+    (commander', state') <- a state+    pure (withDefeatEffects ma commander', state')+  Defeat -> Action $ \state -> ma *> pure (Defeat, state)+  Victory a -> Victory a++-- | Middleware to have effects whenever the program successfully computes+-- a result.+withVictoryEffects :: Monad m => m a -> Middleware m m+withVictoryEffects ma commander = case commander of+  Action a -> Action $ \state -> do+    (commander', state') <- a state+    pure (withVictoryEffects ma commander', state')+  Defeat -> Defeat+  Victory a -> Action $ \state -> ma *> pure (Victory a, state)++-- | Middleware to log the state to standard out for every step of the+-- 'CommanderT' computation.+logState :: MonadIO m => Middleware m m+logState commander+  = case commander of+      Action a -> do+        Action $ \state -> do+          liftIO $ print state+          fmap (first logState) (a state)+      Defeat ->+        Action $ \state -> do+          liftIO $ print state+          pure (Defeat, state)+      Victory a ->+        Action $ \state -> do+          liftIO $ print state+          pure (Victory a, state)