diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ``` diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -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"])) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/commander-cli.cabal b/commander-cli.cabal --- a/commander-cli.cabal +++ b/commander-cli.cabal @@ -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 diff --git a/src/Options/Commander.hs b/src/Options/Commander.hs --- a/src/Options/Commander.hs +++ b/src/Options/Commander.hs @@ -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.