optparse-declarative (empty) → 0.1.0
raw patch · 8 files changed
+544/−0 lines, 8 filesdep +basesetup-changed
Dependencies added: base
Files
- ChangeLog.md +3/−0
- LICENSE +20/−0
- README.md +128/−0
- Setup.hs +2/−0
- example/simple.hs +12/−0
- example/subcmd.hs +35/−0
- optparse-declarative.cabal +30/−0
- src/Options/Declarative.hs +314/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# 0.1.0 + +- First release
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Hideyuki Tanaka + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,128 @@+# optparse-declarative++`optparse-declarative` is a declarative and easy to use command-line option parser.++# Install++```bash+$ cabal install optparse-declarative+```++# Usage++## Writing a simple command++First, you need to enable `DataKinds` extension and import `Options.Declarative` module.++```hs+{-# LANGUAGE DataKinds #-}+import Options.Declarative+```++Then, define the command line option as a **type of the function**.+For example, this is a simple greeting program:++```hs+greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String)+ -> Arg "NAME" String+ -> Cmd "greet"+greet msg name = Cmd $ do+ putStrLn $ get msg ++ ", " ++ get name ++ "!"+```++There are two type of options, `Flag` and `Arg`.+`Flag` is named argument and `Arg` is unnamed argument.+Last argument of both options is value type.+If you need to specify default value, use the modifiers such as `Def`.++In above, variable `msg` has a very complex type (`Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String)`).+In order to get the value of usual type (in this case, that is `String`),+you can use `get` function.++The whole type of command is `Cmd`.+`Cmd <description>` is basically newtype of `IO ()`,+except this contains extra information.++When you define the command, there remains only invoking the command.++```hs+main :: IO ()+main = run_ greet+```++You can execute this program like this:++```bash+$ ghc simple.hs++$ ./simple+simple: not enough arguments+Try 'simple --help' for more information.++$ ./simple --help+Usage: simple [OPTION...] NAME+Options:+ -g STRING --greet=STRING greeting message+ -? --help display this help and exit++$ ./simple World+Hello, World!++$ ./simple --greet=Goodbye World+Goodbye, World!+```++## Writing multiple sum-commands++You can write (nested) sub-commands.++Just groupe subcommands by `Group`, you got sub-command parser.++This is the example:++```hs+{-# LANGUAGE DataKinds #-}++import Options.Declarative++main :: IO ()+main = run_ $+ Group "Test program for library"+ [ subCmd "greet" greet+ , subCmd "connect" connect+ ]++greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String)+ -> Flag "" '["decolate"] "" "decolate message" Bool+ -> Arg "NAME" String+ -> Cmd "Greeting command"+greet msg deco name = Cmd $ do+ let f x | get deco = "*** " ++ x ++ " ***"+ | otherwise = x+ putStrLn $ f $ get msg ++ ", " ++ get name ++ "!"++connect :: Flag "h" '["host"] "HOST" "host name" (Def "localhost" String)+ -> Flag "p" '["port"] "PORT" "port number" (Def "8080" Int )+ -> Cmd "Connect command"+connect host port = Cmd $ do+ let addr = get host ++ ":" ++ show (get port)+ putStrLn $ "connect to " ++ addr+```++And this is the output:++```bash+$ ./subcmd --help+Usage: subcmd [OPTION...] <COMMAND> [ARGS...]+Options:+ -? --help display this help and exit++Commands:+ greet Greeting command+ port Server command++$ ./subcmd connect --port=1234+connect to localhost:1234+```++For more examples, please see `example` directory.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ example/simple.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DataKinds #-}++import Options.Declarative++greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String)+ -> Arg "NAME" String+ -> Cmd "greet"+greet msg name = Cmd $ do+ putStrLn $ get msg ++ ", " ++ get name ++ "!"++main :: IO ()+main = run_ greet
+ example/subcmd.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}++import Options.Declarative++greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String)+ -> Flag "" '["decolate"] "" "decolate message" Bool+ -> Arg "NAME" String+ -> Cmd "Greeting command"+greet msg deco name = Cmd $ do+ let f x | get deco = "*** " ++ x ++ " ***"+ | otherwise = x+ putStrLn $ f $ get msg ++ ", " ++ get name ++ "!"++connect :: Flag "h" '["host"] "HOST" "host name" (Def "localhost" String)+ -> Flag "p" '["port"] "PORT" "port number" (Def "8080" Int )+ -> Cmd "Connect command"+connect host port = Cmd $ do+ let addr = get host ++ ":" ++ show (get port)+ putStrLn $ "connect to " ++ addr++getOptExample+ :: Flag "o" '["output"] "FILE" "output FILE" (Def "stdout" String)+ -> Flag "c" '[] "FILE" "input FILE" (Def "stdin" String)+ -> Flag "L" '["libdir"] "DIR" "library directory" String+ -> Cmd "GetOpt example"+getOptExample output input libdir = Cmd $+ print (get output, get input, get libdir)++main :: IO ()+main = run_ $+ Group "Test program for library"+ [ subCmd "greet" greet+ , subCmd "connect" connect+ , subCmd "getopt" getOptExample+ ]
+ optparse-declarative.cabal view
@@ -0,0 +1,30 @@+name: optparse-declarative +version: 0.1.0 +synopsis: Declarative command line option parser +description: Declarative and easy to use command line option parser +homepage: https://github.com/tanakh/optparse-declarative +license: MIT +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: tanaka.hideyuki@gmail.com +copyright: (c) Hideyuki Tanaka 2015 +category: System +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: README.md + ChangeLog.md + example/simple.hs + example/subcmd.hs + +source-repository head + type: git + location: https://github.com/tanakh/optparse-declarative.git + +library + exposed-modules: Options.Declarative + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <5 + hs-source-dirs: src + default-language: Haskell2010
+ src/Options/Declarative.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Declarative options parser + +module Options.Declarative ( + -- * Command type + Cmd(..), + IsCmd, + + -- * Argument definition tools + Option(..), + Flag, + Arg, + + -- * Defining argment types + ArgRead(..), + Def, + + -- * Subcommands support + Group(..), + SubCmd, subCmd, + + -- * Run a command + run, run_, + ) where + +import Control.Applicative +import Control.Monad +import Data.List +import Data.Maybe +import Data.Proxy +import GHC.TypeLits +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Text.Read + +-- argument types + +class Option a where + type Value a :: * + get :: a -> Value a + +newtype Flag (shortNames :: Symbol ) + (longNames :: [Symbol]) + (placeholder :: Symbol ) + (help :: Symbol ) + a + = Flag { getFlag :: a } + +newtype Arg (placeholder :: Symbol) a = Arg { getArg :: a } + +instance ArgRead a => Option (Flag _a _b _c _d a) where + type Value (Flag _a _b _c _d a) = Unwrap a + get = unwrap . getFlag + +instance Option (Arg _a a) where + type Value (Arg _a a) = a + get = getArg + +class ArgRead a where + type Unwrap a :: * + type Unwrap a = a + + unwrap :: a -> Unwrap a + default unwrap :: a ~ Unwrap a => a -> Unwrap a + unwrap = id + + argRead :: Maybe String -> Maybe a + default argRead :: Read a => Maybe String -> Maybe a + argRead s = readMaybe =<< s + + needArg :: Proxy a -> Bool + needArg _ = True + +instance ArgRead Int + +instance ArgRead Integer + +instance ArgRead Double + +instance ArgRead String where + argRead = id + +instance ArgRead Bool where + argRead Nothing = Just False + argRead (Just "t") = Just True + argRead _ = Nothing + + needArg _ = False + +instance ArgRead a => ArgRead (Maybe a) where + argRead Nothing = Just Nothing + argRead (Just a) = Just <$> argRead (Just a) + +newtype Def (defaultValue :: Symbol) a = + Def { getDef :: a } + +instance (KnownSymbol defaultValue, ArgRead a) => ArgRead (Def defaultValue a) where + type Unwrap (Def defaultValue a) = Unwrap a + unwrap = unwrap . getDef + + argRead s = + let s' = fromMaybe (symbolVal (Proxy :: Proxy defaultValue)) s + in Def <$> argRead (Just s') + +-- command types + +newtype Cmd (help :: Symbol) = Cmd (IO ()) + +data Group + = Group + { groupHelp :: String + , groupCmds :: [SubCmd] + } + +data SubCmd = forall c. IsCmd c => SubCmd String c + +class IsCmd c where + getCmdHelp :: c -> String + default getCmdHelp :: (c ~ (a -> b), IsCmd b) => c -> String + getCmdHelp f = getCmdHelp $ f undefined + + getOptDescr :: c -> [OptDescr (String, String)] + default getOptDescr :: (c ~ (a -> b), IsCmd b) => c -> [OptDescr (String, String)] + getOptDescr f = getOptDescr $ f undefined + + getUsageHeader :: c -> String -> String + default getUsageHeader :: (c ~ (a -> b), IsCmd b) => c -> String -> String + getUsageHeader f = getUsageHeader $ f undefined + + getUsageFooter :: c -> String -> String + default getUsageFooter :: (c ~ (a -> b), IsCmd b) => c -> String -> String + getUsageFooter f = getUsageFooter $ f undefined + + runCmd :: c + -> [String] -- ^ Command name + -> Maybe String -- ^ Version + -> [(String, String)] -- ^ Options + -> [String] -- ^ Non options + -> [String] -- ^ Unrecognized options + -> IO () + +class KnownSymbols (s :: [Symbol]) where + symbolVals :: Proxy s -> [String] + +instance KnownSymbols '[] where + symbolVals _ = [] + +instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where + symbolVals _ = symbolVal (Proxy :: Proxy s) : symbolVals (Proxy :: Proxy ss) + +instance ( KnownSymbol shortNames + , KnownSymbols longNames + , KnownSymbol placeholder + , KnownSymbol help + , ArgRead a + , IsCmd c ) + => IsCmd (Flag shortNames longNames placeholder help a -> c) where + getOptDescr f = + let flagname = head $ + symbolVals (Proxy :: Proxy longNames) ++ + [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] + in Option + (symbolVal (Proxy :: Proxy shortNames)) + (symbolVals (Proxy :: Proxy longNames)) + (if needArg (Proxy :: Proxy a) + then ReqArg + (flagname, ) + (symbolVal (Proxy :: Proxy placeholder)) + else NoArg + (flagname, "t")) + (symbolVal (Proxy :: Proxy help)) + : getOptDescr (f undefined) + + runCmd f name mbver options nonOptions unrecognized = + let flagname = head $ + symbolVals (Proxy :: Proxy longNames) ++ + [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] + mbs = lookup flagname options + in case (argRead mbs, mbs) of + (Nothing, Nothing) -> + errorExit name $ "flag must be specified: --" ++ flagname + (Nothing, Just s) -> + errorExit name $ "bad argument: --" ++ flagname ++ "=" ++ s + (Just arg, _) -> + runCmd (f $ Flag arg) name mbver options nonOptions unrecognized + +instance ( KnownSymbol placeholder, IsCmd c ) + => IsCmd (Arg placeholder String -> c) where + getUsageHeader f prog = + " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog + + runCmd f name mbver options nonOptions unrecognized = + case nonOptions of + [] -> errorExit name "not enough arguments" + (opt: rest) -> + case argRead (Just opt) of + Nothing -> + errorExit name $ "bad argument: " ++ opt + Just arg -> + runCmd (f $ Arg arg) name mbver options rest unrecognized + +instance ( KnownSymbol placeholder, IsCmd c ) + => IsCmd (Arg placeholder [String] -> c) where + getUsageHeader f prog = + " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog + + runCmd f name mbver options nonOptions unrecognized = + runCmd (f $ Arg nonOptions) name mbver options [] unrecognized + +instance KnownSymbol help => IsCmd (Cmd help) where + getCmdHelp _ = symbolVal (Proxy :: Proxy help) + getOptDescr _ = [] + + getUsageHeader _ _ = "" + getUsageFooter _ _ = "" + + runCmd (Cmd m) name _ options nonOptions unrecognized = + case (options, nonOptions, unrecognized) of + (_, [], []) -> m + _ -> do + forM_ nonOptions $ \o -> + errorExit name $ "unrecognized argument '" ++ o ++ "'" + forM_ unrecognized $ \o -> + errorExit name $ "unrecognized option '" ++ o ++ "'" + exitFailure + +instance IsCmd Group where + getCmdHelp = groupHelp + getOptDescr _ = [] + + getUsageHeader _ _ = " <COMMAND> [ARGS...]" + getUsageFooter g _ = unlines $ + [ "" + , "Commands: " + ] ++ + [ " " ++ name ++ replicate (12 - length name) ' ' ++ getCmdHelp c + | SubCmd name c <- groupCmds g + ] + + runCmd g name mbver _options (cmd: nonOptions) unrecognized = + case [ SubCmd subname c | SubCmd subname c <- groupCmds g, subname == cmd ] of + [SubCmd subname c] -> + run' c (name ++ [subname]) mbver (nonOptions ++ unrecognized) + _ -> + errorExit name $ "unrecognized command: " ++ cmd + runCmd _ name _ _ _ _ = + errorExit name "no command given" + +subCmd :: IsCmd c => String -> c -> SubCmd +subCmd = SubCmd + +-- runner + +run' :: IsCmd c => c -> [String] -> Maybe String -> [String] -> IO () +run' cmd name mbver args = do + let optDescr = + getOptDescr cmd + ++ [ Option "?" ["help"] (NoArg ("help", "t")) "display this help and exit" ] + ++ [ Option "V" ["version"] (NoArg ("version", "t")) "output version information and exit" + | isJust mbver ] + + prog = unwords name + vermsg = prog ++ maybe "" (" version " ++) mbver + usage = + -- prog ++ ": " ++ getCmdHelp cmd ++ "\n\n" ++ + usageInfo ("Usage: " ++ prog ++ " [OPTION...]" ++ getUsageHeader cmd prog ++ "\nOptions:") optDescr ++ + getUsageFooter cmd prog + + case getOpt' RequireOrder optDescr args of + (options, nonOptions, unrecognized, errors) + | not $ null errors -> + errorExit name $ intercalate ", " errors + | isJust (lookup "help" options) -> do + putStr usage + exitSuccess + | isJust (lookup "version" options) -> do + putStrLn vermsg + exitSuccess + | otherwise -> + runCmd cmd name mbver options nonOptions unrecognized + +-- | Run a command with specifying program name and version +run :: IsCmd c => String -> Maybe String -> c -> IO () +run progName progVer cmd = + run' cmd [progName] progVer =<< getArgs + +-- | Run a command +run_ :: IsCmd c => c -> IO () +run_ cmd = do + progName <- getProgName + run progName Nothing cmd + +errorExit :: [String] -> String -> IO () +errorExit name msg = do + let prog = unwords name + hPutStrLn stderr $ prog ++ ": " ++ msg + hPutStrLn stderr $ "Try '" ++ prog ++ " --help' for more information." + exitFailure