commander-cli 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+343/−37 lines, 5 filesdep +directorydep +processdep ~basedep ~commander-clidep ~mtlnew-component:exe:task-manager
Dependencies added: directory, process
Dependency ranges changed: base, commander-cli, mtl, text, unordered-containers
Files
- README.md +1/−1
- Test.hs +45/−0
- app/Main.hs +138/−8
- commander-cli.cabal +53/−10
- src/Options/Commander.hs +106/−18
README.md view
@@ -5,7 +5,7 @@ like this: ```haskell-type File = "writer" & Arg "file" FilePath & Arg "contents" FilePath Raw+type File = "writer" & Arg "file" FilePath & Arg "contents" FilePath & Raw + "reader" & Arg "file" FilePath & Raw ```
+ Test.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+module Main where++import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HashMap+import Data.Text+import Control.Concurrent+import Options.Commander+import Control.Monad+import System.Exit++main :: IO ()+main = rawTest >> argTest >> optTest >> flagTest++rawProg :: ProgramT Raw IO Bool+rawProg = raw (pure True)++rawTest :: IO ()+rawTest = maybe exitFailure (cond exitSuccess 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))++cond :: x -> x -> Bool -> x+cond x y True = x+cond x y False = y++argTest :: IO ()+argTest = maybe exitFailure (cond exitSuccess 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)++flagProg :: ProgramT (Flag "flag" & Raw) IO Bool+flagProg = flag (raw . pure)++flagTest :: IO ()+flagTest = maybe exitFailure (cond exitSuccess exitFailure) =<< runCommanderT (run flagProg) (State mempty mempty (HashSet.fromList ["flag"]))
app/Main.hs view
@@ -1,19 +1,149 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BlockArguments #-} module Main where +import Control.Monad import Options.Commander import Prelude+import System.Directory+import System.Process+import Data.List+import Text.Read+import System.Exit+import Data.Either -type File = Named "file"- & Arg "filename" FilePath - & ("write" & Arg "contents" String & Raw- + "read" & Raw) +type TaskManager+ = Named "task-manager" & ( + "help" & Usage (Named "task-manager" & TaskManagerBasic)+ + TaskManagerBasic) -file :: ProgramT File IO ()-file = named $ arg \a -> (sub $ arg (raw . writeFile a)) :+: (sub . raw $ readFile a >>= putStrLn)+type TaskManagerBasic+ = "edit" & TaskProgram+ + "open" & TaskProgram+ + "close" & TaskProgram+ + "tasks" & Raw+ + "priorities" & Raw -main :: IO ()-main = command_ (file :+: usage @File)+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++editTask = arg @"task-name" \taskName -> raw + $ withTask taskName \Context{home} task -> callProcess "vim" [home ++ "/tasks/" ++ taskName ++ ".task"]++newTask = arg @"task-name" \taskName -> raw do+ Context{home, tasks} <- initializeOrFetch+ if not (taskName `elem` tasks)+ then do+ let path = home ++ "/tasks/" ++ 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 ->+ case mtask of+ Just Task{priorities} ->+ if priorities == [] + then removeFile (home ++ "/tasks/" ++ taskName ++ ".task")+ else putStrLn $ "task " ++ taskName ++ " has remaining priorities."+ Nothing -> putStrLn "task is corrupted"++listTasks = raw do+ Context{tasks} <- initializeOrFetch+ mapM_ putStrLn tasks++listPriorities = raw do+ Context{tasks} <- initializeOrFetch+ forM_ tasks $ \taskName -> withTask taskName \_ mtask -> + case mtask of+ Just Task{name, priorities} -> do+ putStrLn $ name ++ ": "+ putStrLn $ renderPriorities priorities+ Nothing -> putStrLn $ "Corruption! Task " ++ taskName ++ " is the culprint"++data Context = Context+ { home :: FilePath+ , tasks :: [String] }+ deriving Show++data Task = Task+ { name :: String+ , priorities :: [(String, String)]+ } deriving (Show, Read)++readTask :: String -> IO (Maybe Task)+readTask taskName = do+ Context{home, tasks} <- initializeOrFetch+ if taskName `elem` tasks+ then do+ let path = home ++ "/tasks/" ++ 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"+ writeFile path $ renderPriorities priorities++renderPriorities :: [(String, String)] -> String+renderPriorities = concat . map (\(x, y) -> ("#" ++ x ++ "\n" ++ unlines (map (" " ++) $ lines y)))++trimWhitespace :: String -> String+trimWhitespace = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ')++parseTask :: String -> String -> Maybe Task+parseTask taskName+ = sectionByPriority+ . dropWhile isRight+ . map (\case+ ('#': (trimWhitespace -> xs)) -> Left xs+ xs -> Right xs)+ . lines+ where+ sectionByPriority :: [Either String String] -> Maybe Task+ sectionByPriority = \case+ Left priority : xs -> do+ let (concat . map (fromRight undefined) -> description, xs') = span isRight xs+ Task{priorities} <- sectionByPriority xs'+ Just $ Task taskName ((priority, description) : priorities)+ Right _ : xs -> Nothing+ [] -> Just $ Task taskName []++withTask :: String -> (Context -> Maybe Task -> IO ()) -> IO ()+withTask taskName action = do+ c@Context{tasks, home} <- initializeOrFetch+ if taskName `elem` tasks + then do+ readTask taskName >>= \case+ Just task -> action c (Just task)+ Nothing -> action c Nothing+ else putStrLn $ "task " ++ taskName ++ " does not exist."++initializeOrFetch = 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"+ +main = command_ taskManager
commander-cli.cabal view
@@ -1,14 +1,11 @@ cabal-version: 2.4--- Initial package description 'commander-cli.cabal' generated by 'cabal--- init'. For further documentation, see--- http://haskell.org/cabal/users-guide/ name: commander-cli-version: 0.1.0.0+version: 0.2.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--- bug-reports:+bug-reports: https://github.com/SamuelSchlesinger/commander-cli/issues license: MIT license-file: LICENSE author: Samuel Schlesinger@@ -19,14 +16,60 @@ library exposed-modules: Options.Commander- other-extensions: DeriveFunctor, AllowAmbiguousTypes, PolyKinds, GADTs, TypeOperators, DataKinds- build-depends: base ^>=4.13.0.0, mtl ^>=2.2.2, text ^>=1.2.4.0, unordered-containers ^>=0.2.10.0+ other-extensions: ViewPatterns,+ DerivingVia,+ StandaloneDeriving,+ GeneralizedNewtypeDeriving,+ DerivingStrategies,+ OverloadedStrings,+ FlexibleInstances,+ TypeFamilies,+ TypeSynonymInstances,+ ScopedTypeVariables,+ RecordWildCards,+ TypeApplications,+ RankNTypes,+ BlockArguments,+ DeriveFunctor,+ AllowAmbiguousTypes,+ PolyKinds,+ GADTs,+ TypeOperators,+ DataKinds+ build-depends: base >=4.13 && < 5,+ mtl >=2.2 && <2.3,+ text >=1.2 && < 1.3,+ unordered-containers >=0.2 && < 0.3 hs-source-dirs: src default-language: Haskell2010 -executable commander-cli+executable task-manager main-is: Main.hs- other-extensions: DeriveFunctor, AllowAmbiguousTypes, PolyKinds, GADTs, TypeOperators, DataKinds- build-depends: base ^>=4.13.0.0, mtl ^>=2.2.2, text ^>=1.2.4.0, commander-cli ^>=0.1+ other-extensions: TypeFamilies,+ ViewPatterns,+ ScopedTypeVariables,+ NamedFieldPuns,+ RecordWildCards,+ LambdaCase,+ DataKinds,+ TypeApplications,+ TypeOperators,+ BlockArguments+ build-depends:+ base >=4.13 && < 5,+ mtl >=2.2,+ text >=1.2.4 && < 1.3,+ directory >= 1.3 && < 1.4,+ process >= 1.6 && < 1.7,+ commander-cli hs-source-dirs: app+ default-language: Haskell2010++test-suite test-commander+ type: exitcode-stdio-1.0+ main-is: Test.hs+ build-depends: base >= 4.13 && < 5,+ text >=1.2.4 && < 1.3,+ unordered-containers >= 0.2 && < 0.3,+ commander-cli default-language: Haskell2010
src/Options/Commander.hs view
@@ -18,8 +18,63 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}-module Options.Commander where+{- |+Module: Options.Commander+Description: A set of combinators for constructing and executing command line programs+Copyright: (c) Samuel Schlesinger 2020+License: MIT+Maintainer: sgschlesinger@gmail.com+Stability: experimental+Portability: POSIX, Windows +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:++@+main :: IO ()+main = command_ . toplevel @"file" $+ (sub @"maybe-read" $+ arg @"filename" \filename ->+ flag @"read" \b -> raw $+ if b+ then putStrLn =<< readFile filename+ else pure ())+ \<+\>+ (sub @"maybe-write" $+ opt @"file" @"file-to-write" \mfilename -> raw $+ case mfilename of+ Just filename -> putStrLn =<< readFile filename+ Nothing -> pure ())+@++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.+-}+module Options.Commander (+ -- ** Run CLI Programs+ command, command_,+ -- ** CLI Combinators+ arg, opt, raw, sub, named, flag, toplevel, usage, (<+>),+ -- ** Type Level CLI Description+ type (&), type (+), Arg, Opt, Named, Usage, Raw, Flag,+ -- **+ HasProgram(run, hoist, invocations),+ ProgramT(ArgProgramT, unArgProgramT,+ OptProgramT, unOptProgramT,+ RawProgramT, unRawProgramT,+ SubProgramT, unSubProgramT,+ NamedProgramT, unNamedProgramT,+ FlagProgramT, unFlagProgramT,+ UsageProgramT,+ (:+:)+ ),+ -- ** The CommanderT Monad+ CommanderT(Action, Defeat, Victory), runCommanderT, initialState, State(State, arguments, options, flags),+ -- ** Parsing Arguments and Options+ Unrender(unrender),+) where+ import Control.Applicative (Alternative(..)) import Control.Monad ((<=<)) import Control.Monad (ap, void)@@ -54,10 +109,10 @@ instance Unrender a => Unrender (Maybe a) where unrender x = justCase x <|> nothingCase x where- justCase x = do- x' <- stripPrefix "Just " x- return (unrender x')- nothingCase x = if x == "Nothing" then return Nothing else Nothing+ justCase x' = do+ x'' <- stripPrefix "Just " x'+ return (unrender x'')+ nothingCase x' = if x' == "Nothing" then return Nothing else Nothing instance (Unrender a, Unrender b) => Unrender (Either a b) where unrender x = leftCase x <|> rightCase x where@@ -67,7 +122,7 @@ instance Unrender Bool where unrender = unrenderSmall -newtype WrappedIntegral i = WrappedIntegral { unwrapIntegral :: i }+newtype WrappedIntegral i = WrappedIntegral i deriving newtype (Num, Real, Ord, Eq, Enum, Integral) instance Integral i => Unrender (WrappedIntegral i) where@@ -82,7 +137,7 @@ deriving via WrappedIntegral Int32 instance Unrender Int32 deriving via WrappedIntegral Int64 instance Unrender Int64 -newtype WrappedNatural i = WrappedNatural { unwrapNatural :: i }+newtype WrappedNatural i = WrappedNatural i deriving newtype (Num, Real, Ord, Eq, Enum, Integral) instance Integral i => Unrender (WrappedNatural i) where@@ -100,21 +155,41 @@ instance Unrender Char where unrender = find (const True) +-- | The type level argument combinator, with a 'Symbol' designating the+-- name of that argument. data Arg :: Symbol -> * -> * +-- | The type level option combinator, with a 'Symbol' designating the+-- option's name and another representing the metavariables name for+-- documentation purposes. data Opt :: Symbol -> Symbol -> * -> * +-- | The type level naming combinator, giving your program a name for the+-- sake of documentation. data Named :: Symbol -> * +-- | The type level usage combinator, taking a program type as an argument+-- and being interpreted as a program which prints out all of the+-- invocations of that particular program. data Usage :: * -> * +-- | The type level program sequencing combinator, taking two program types+-- and sequencing them one after another. data (&) :: k -> * -> * infixr 4 & +-- | The type level raw monadic program combinator, allowing a command line+-- program to just do some computation. data Raw :: * +-- | The type level flag combinator, taking a name as input, allowing your+-- program to take flags with the syntax @~flag@. data Flag :: Symbol -> * +-- | The type level combining combinator, taking two program types as+-- input, and being interpreted as a program which attempts to run the+-- first command line program and, if parsing its flags, subprograms,+-- options or arguments fails, runs the second, otherwise failing. data a + b infixr 2 + @@ -237,20 +312,26 @@ (action', state') <- action state return (action' <|> p, state') +-- | This is the 'State' that the 'CommanderT' library uses for its role in+-- this library. It is not inlined, because that does nothing but obfuscate+-- the 'CommanderT' monad. It consists of 'arguments', 'options', and+-- 'flags'. data State = State { arguments :: [Text] , options :: HashMap Text Text , flags :: HashSet Text } --- | This is the workhorse of the library and is inspired by the servant--- HTTP library. Basically, it allows you to 'run' your 'ProgramT'+-- | This is the workhorse of the library. Basically, it allows you to +-- 'run' your 'ProgramT' -- representation of your program as a 'CommanderT' and pump the 'State' -- through it until you've processed all of the arguments, options, and -- flags that you have specified must be used in your 'ProgramT'. You can -- think of 'ProgramT' as a useful syntax for command line programs, but -- 'CommanderT' as the semantics of that program. We also give the ability -- to 'hoist' 'ProgramT' actions between monads if you can uniformly turn--- computations in one into another.+-- computations in one into another. All of the different 'invocations'+-- are also stored to give a primitive form of automatically generated+-- documentation. class HasProgram p where data ProgramT p (m :: * -> *) a run :: ProgramT p IO a -> CommanderT State IO a@@ -319,21 +400,21 @@ hoist n = NamedProgramT . hoist n . unNamedProgramT invocations = [((pack (symbolVal (Proxy @name)) <> " ") <>)] <*> invocations @p -instance (KnownSymbol seg, HasProgram p) => HasProgram (seg & p) where- newtype ProgramT (seg & p) m a = SegProgramT { unSegProgramT :: ProgramT p m a }+instance (KnownSymbol sub, HasProgram p) => HasProgram (sub & p) where+ newtype ProgramT (sub & p) m a = SubProgramT { unSubProgramT :: ProgramT p m a } run s = Action $ \State{..} -> do case arguments of (x : xs) -> - if x == pack (symbolVal $ Proxy @seg) - then return (run $ unSegProgramT s, State{arguments = xs, ..})+ if x == pack (symbolVal $ Proxy @sub) + then return (run $ unSubProgramT s, State{arguments = xs, ..}) else return (Defeat, State{..}) [] -> return (Defeat, State{..})- hoist n = SegProgramT . hoist n . unSegProgramT- invocations = [((pack $ symbolVal (Proxy @seg) <> " ") <> )] + hoist n = SubProgramT . hoist n . unSubProgramT+ invocations = [((pack $ symbolVal (Proxy @sub) <> " ") <> )] <*> invocations @p -- | A simple default for getting out the arguments, options, and flags--- using 'System.Environment'. We use the syntax ~flag for flags and ~opt+-- using 'getArgs'. We use the syntax ~flag for flags and ~opt -- for options, with arguments using the typical ordered representation. initialState :: IO State initialState = do@@ -386,7 +467,7 @@ sub :: KnownSymbol s => ProgramT p m a -> ProgramT (s & p) m a-sub = SegProgramT+sub = SubProgramT -- | Named command combinator, should only really be used at the top level. named :: KnownSymbol s @@ -406,6 +487,13 @@ => ProgramT p m a -> ProgramT (Named s & ("help" & Usage (Named s & p) + p)) m a toplevel p = named (sub usage :+: p) where++-- | The command line program which consists of trying to enter one and+-- then trying the other.+(<+>) :: forall x y m a. ProgramT x m a -> ProgramT y m a -> ProgramT (x + y) m a+(<+>) = (:+:)++infixr 2 <+> -- | A meta-combinator that takes a type-level description of a command -- line program and produces a simple usage program.