diff --git a/Application/CLI.hs b/Application/CLI.hs new file mode 100644 --- /dev/null +++ b/Application/CLI.hs @@ -0,0 +1,116 @@ +-- | +-- Module : Application.CLI +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +module Application.CLI + ( -- * Default Main + defaultMain + + -- * CLI + , CLI(..) + , OptHelp(..) + -- ** Default CLIs + , Usage + , printUsage + + , Help(..) + , printHelp + + -- * Commands + , CLIContext + , getHeader + , getDefault + , initialize + , with + ) where + +import Application.CLI.Class +import Application.CLI.Types +import System.Environment +import System.Exit + +-- | Default usage Command Interface +data Usage = Usage +instance CLI Usage where + name _ = "" + desc _ = "" + options _ = [] + action _ ctx opts = do + progName <- getProgName + usage (printUsage " " progName ctx) opts + +usage :: String + -> [String] + -> IO () +usage list msgs = do + mapM_ (\str -> putStrLn str) msgs + putStrLn list + exitFailure + +data Help = Help +instance CLI Help where + name _ = "help" + desc _ = "show help message" + options _ = [] + action _ ctx _ = do + progName <- getProgName + putStrLn $ printHelp " " progName ctx + +------------------------------------------------------------------------------- +-- Commands -- +------------------------------------------------------------------------------- + +-- | Add a new Command into a collection of commands +with :: CLI cli + => cli -- ^ A new Command Interface + -> CLIContext -- ^ The original Collection of commands + -> CLIContext +with c l = insertCommand (cliToCommand c) l + +-- | Initialize a collection of commands +initialize :: CLI cliDefault + => Maybe cliDefault -- ^ The command to execute if no option is given + -> String -- ^ CLI Description + -> CLIContext +initialize defaultCli description = + case defaultCli of + Nothing -> cmdMap + Just cmd -> insertDefault (cliToCommand cmd) cmdMap + where + cmdMap :: CLIContext + cmdMap = createContext (cliToCommand Usage) description + +------------------------------------------------------------------------------- +-- Default Main -- +------------------------------------------------------------------------------- + +defaultMain :: CLIContext -- ^ A collection of commands + -> IO () +defaultMain cmdMap = do + args <- getArgs + case args of + [] -> tryDefault + (x:xs) -> tryCommand x xs + where + raiseHelper :: String + -> IO () + raiseHelper what = + cmdAction (getHelper cmdMap) cmdMap [what] + tryDefault :: IO () + tryDefault = do + progName <- getProgName + case getDefault cmdMap of + Nothing -> raiseHelper $ progName ++ " does not provide default command" + Just cmd -> cmdAction cmd cmdMap [] + tryCommand :: String + -> [String] + -> IO () + tryCommand cmdstr opts = + case lookupCommand cmdstr cmdMap of + Nothing -> raiseHelper $ cmdstr ++ ": command does not exist" + Just cmd -> cmdAction cmd cmdMap opts diff --git a/Application/CLI/Class.hs b/Application/CLI/Class.hs new file mode 100644 --- /dev/null +++ b/Application/CLI/Class.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Application.CLI.Class +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +module Application.CLI.Class + ( CLI (..) + , cliToCommand + ) where + +import Application.CLI.Types + +class CLI cli where + name :: cli + -> String + desc :: cli + -> String + options :: cli + -> [OptHelp] + action :: cli + -> CLIContext + -> [String] + -> IO () + +cliToCommand :: CLI cli + => cli + -> Command +cliToCommand cli = + Command + { cmdName = name cli + , cmdDesc = desc cli + , cmdOptions = options cli + , cmdAction = action cli + } diff --git a/Application/CLI/Types.hs b/Application/CLI/Types.hs new file mode 100644 --- /dev/null +++ b/Application/CLI/Types.hs @@ -0,0 +1,181 @@ +-- | +-- Module : Application.CLI.Types +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +module Application.CLI.Types + ( -- * Types + CLIContext + , Command(..) + , OptHelp(..) + + -- * Commands + -- ** Getter/Setter + , createContext + , getHeader + , getHelper + , insertDefault + , getDefault + , insertCommand + -- ** Lookup + , lookupCommand + + -- * pretty printer + , printUsage + , printHelp + , printOptHelp + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M + +------------------------------------------------------------------------------- +-- Commands -- +------------------------------------------------------------------------------- + +data CLIContext = CLIContext + { getCommands :: Map String Command + , getDefault :: Maybe Command + , getHeader :: String + , getHelper :: Command + } deriving (Show, Eq) + +-- | Create a CLIContext +createContext :: Command -- ^ the helper command + -> String -- ^ a description about the program + -> CLIContext +createContext helper header = + CLIContext + { getCommands = M.empty + , getDefault = Nothing + , getHelper = helper + , getHeader = header + } + +insertCommand :: Command -> CLIContext -> CLIContext +insertCommand cmd cmdMap = cmdMap { getCommands = M.insert (cmdName cmd) cmd (getCommands cmdMap) } + +insertDefault :: Command -> CLIContext -> CLIContext +insertDefault cmd cmdMap = + insertCommand cmd $cmdMap { getDefault = Just cmd } + +lookupCommand :: String -> CLIContext -> Maybe Command +lookupCommand k cmdMap = M.lookup k (getCommands cmdMap) + +------------------------------------------------------------------------------- +-- Command -- +------------------------------------------------------------------------------- + +data Command = + Command + { cmdName :: String + , cmdDesc :: String + , cmdOptions :: [OptHelp] + , cmdAction :: CLIContext -> [String] -> IO () + } + +instance Eq Command where + (==) a b = eqname && eqdesc && eqopts + where + eqname = cmdName a == cmdName b + eqdesc = cmdDesc a == cmdDesc b + eqopts = cmdOptions a == cmdOptions b + +instance Show Command where + show c = + "Command { " ++ "name: " ++ (cmdName c) ++ ", " + ++ "desc: " ++ (cmdDesc c) ++ ", " + ++ "opts: " ++ (show $ cmdOptions c) ++ " }" + +printCommandHelp :: String -- ^ indentation + -> Command + -> String +printCommandHelp prefix cmd = + prefix ++ cmdName cmd ++ ": " ++ cmdDesc cmd ++ "\n" + ++ (foldr (\c acc -> "\n" ++ prefix ++ prefix ++ (printOptHelp c) ++ acc) "" (cmdOptions cmd)) + +------------------------------------------------------------------------------- +-- Option helps -- +------------------------------------------------------------------------------- + +data OptHelp = OptHelp + { optSymbols :: [String] + , optArgument :: Maybe String + , optDescription :: String + } deriving (Eq, Show) + +printOptHelp :: OptHelp -> String +printOptHelp opthelp = + (printSymbols $ optSymbols opthelp) + ++ (printArgument $ optArgument opthelp) + ++ (optDescription opthelp) + where + printSymbols :: [String] -> String + printSymbols [] = "" + printSymbols [x] = x ++ " " + printSymbols (x:xs) = x ++ printSymbols xs + + printArgument :: Maybe String -> String + printArgument Nothing = "" + printArgument (Just a) = "<" ++ a ++ ">" + +------------------------------------------------------------------------------- +-- Pretty printers -- +------------------------------------------------------------------------------- + +printHelp :: String -- ^ indentation + -> String -- ^ program name + -> CLIContext -- ^ command list + -> String +printHelp prefix name cmdMap = + (defaultUsage prefix name $ getDefault cmdMap) + ++ "\n" + ++ (listCommands prefix cmdMap) + +listCommands :: String + -> CLIContext + -> String +listCommands prefix cmdMap = + "Available commands:\n" + ++ (foldr (\c acc -> "\n" ++ (printCommandHelp listPrefix c) ++ acc) "" (M.elems $ getCommands cmdMap)) + where + listPrefix :: String + listPrefix = prefix + +-- | Pretty printer: list the available commands +printUsage :: String -- ^ indentation + -> String -- ^ program name + -> CLIContext -- ^ the command to print + -> String +printUsage prefix name cmdMap = + (defaultUsage prefix name $ getDefault cmdMap) + ++ "\n" + ++ (listDescriptions prefix cmdMap) + +defaultUsage :: String -- ^ prefix + -> String -- ^ program name + -> Maybe Command + -> String +defaultUsage _ _ Nothing = "" +defaultUsage prefix name (Just cmd) = + prefix ++ "Usage: " ++ name ++ " [" ++ (cmdName cmd) ++ "]\n" + +listDescriptions :: String -- ^ prefix + -> CLIContext + -> String +listDescriptions prefix cmdMap = + "Available commands:\n" + ++ (foldr (\c acc -> "\n" ++ (commandDescription listPrefix c) ++ acc) "" (M.elems $ getCommands cmdMap)) + where + listPrefix :: String + listPrefix = prefix + +commandDescription :: String + -> Command + -> String +commandDescription prefix cmd = + prefix ++ cmdName cmd ++ ": " ++ cmdDesc cmd ++ "\n" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014 Nicolas DI PRIMA + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# CLI + +[![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) +[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) + +Documentation: [cli on hackage](http://hackage.haskell.org/package/cli) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cli.cabal b/cli.cabal new file mode 100644 --- /dev/null +++ b/cli.cabal @@ -0,0 +1,40 @@ +Name: cli +Version: 0.0.1 +Synopsis: Simple Command Line Interface Library +Description: + This package provides a simple Command Line Library +License: BSD3 +License-file: LICENSE +Copyright: Nicolas DI PRIMA +Author: Nicolas DI PRIMA +Maintainer: Nicolas DI PRIMA +Category: Application +Stability: experimental +Build-Type: Simple +Homepage: https://github.com/NicolasDP/hs-cli +Cabal-Version: >=1.10 +extra-source-files: README.md + +Library + Exposed-modules: Application.CLI + Other-modules: Application.CLI.Types + , Application.CLI.Class + Build-depends: base >= 4 && < 5 + , containers + ghc-options: -Wall -fwarn-tabs + Default-Language: Haskell2010 + +source-repository head + type: git + location: https://github.com/NicolasDP/hs-cli + +Flag executable + +Executable Example + Main-Is: Main.hs + hs-source-dirs: example + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + Default-Language: Haskell2010 + if flag(executable) + Build-depends: base >= 4 && < 5 + , cli diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Main +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +module Main + ( main + ) where + +import Application.CLI + +main :: IO () +main = + defaultMain + $ with Help + $ initialize (Nothing :: Maybe Help) "Example of use of CLI Library"