summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-16 06:11:12 +0300
committerdefanor <defanor@uberspace.net>2017-12-16 06:11:12 +0300
commit6ca0662862dffcc67ff4016aaa04cf314d81608e (patch)
tree3d0a7183984571b0623c15b9ab1fb52c00d1ff4c
parent88d9c4a76e27ddee2170bb21e90e0f0fcf77b44c (diff)
downloadcoalpit-6ca0662862dffcc67ff4016aaa04cf314d81608e.zip
coalpit-6ca0662862dffcc67ff4016aaa04cf314d81608e.tar.gz
coalpit-6ca0662862dffcc67ff4016aaa04cf314d81608e.tar.bz2
Generate usage strings for help messages
-rw-r--r--Coalpit.hs145
-rw-r--r--Example.hs21
-rw-r--r--README.md40
3 files changed, 203 insertions, 3 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index ce06417..114181a 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -15,6 +15,7 @@ scripting-friendly than JSON and similar formats.
@
\{\-\# LANGUAGE DeriveGeneric \#\-\}
import GHC.Generics
+import Data.Proxy
import System.Environment
import Coalpit
@@ -23,12 +24,15 @@ data Foo = Foo { bar :: Maybe Int
} deriving (Generic, Show)
instance 'ArgParser' Foo
instance 'ToArgs' Foo
+instance 'ArgHelper' Foo
main :: IO ()
main = do
args <- getArgs
case 'fromArgs' 'defOpt' args of
- Left err -> putStrLn err
+ Left err -> do
+ putStrLn err
+ putStrLn $ "Usage: " ++ 'usage' 'defOpt' (Proxy :: Proxy Foo)
Right x -> do
print (x :: Foo)
print $ 'toArgs' 'defOpt' x
@@ -42,6 +46,11 @@ Then, in a shell:
> $ ./Example --bar 42 'a string'
> Foo {bar = Just 42, baz = "a string"}
> ["--bar","42","a string"]
+> $ ./Example --bar foo
+> arguments:1:3:
+> Failed to read: foo
+>
+> Usage: [--bar INT] STRING
-}
@@ -56,8 +65,10 @@ module Coalpit (
-- * Core classes
ArgParser(..)
, ToArgs(..)
+ , ArgHelper(..)
-- * Utility functions
, fromArgs
+ , usage
-- * Options
, Options(..)
, defOpt
@@ -166,6 +177,19 @@ class ToArgs a where
class GToArgs f where
gToArgs :: Options -> f a -> [String]
+-- | Helper class.
+class ArgHelper a where
+ argHelper :: Options -> [String] -> Proxy a -> String
+ default argHelper :: (GArgHelper (Rep a))
+ => Options -> [String] -> Proxy a -> String
+ argHelper o path Proxy = gArgHelper o path (Proxy :: Proxy (Rep a f))
+
+class GArgHelper f where
+ gArgHelper :: Options -> [String] -> Proxy (f a) -> String
+
+-- | Composes a usage string.
+usage :: ArgHelper a => Options -> Proxy a -> String
+usage o = argHelper o []
-- Units
@@ -175,6 +199,8 @@ instance GArgParser U1 where
instance GToArgs U1 where
gToArgs _ U1 = []
+instance GArgHelper U1 where
+ gArgHelper _ _ (Proxy :: Proxy (U1 f)) = ""
-- Products
@@ -184,6 +210,12 @@ instance (GArgParser a, GArgParser b) => GArgParser (a :*: b) where
instance (GToArgs a, GToArgs b) => GToArgs (a :*: b) where
gToArgs m (a :*: b) = gToArgs m a ++ gToArgs m b
+instance (GArgHelper a, GArgHelper b) => GArgHelper (a :*: b) where
+ gArgHelper m path (Proxy :: Proxy ((a :*: b) f)) =
+ concat [ gArgHelper m path (Proxy :: Proxy (a f))
+ , " "
+ , gArgHelper m path (Proxy :: Proxy (b f))]
+
-- Sums
@@ -227,6 +259,57 @@ instance (Constructor c1, Constructor c2, GToArgs f1, GToArgs f2) =>
gToArgs m (L1 x) = conNameMod m (conName x) : gToArgs m x
gToArgs m (R1 x) = conNameMod m (conName x) : gToArgs m x
+spaceNonEmpty :: String -> String
+spaceNonEmpty "" = ""
+spaceNonEmpty s = ' ' : s
+
+instance (Constructor c1, GArgHelper f1, GArgHelper (f :+: g)) =>
+ GArgHelper ((f :+: g) :+: C1 c1 f1) where
+ gArgHelper m path (Proxy :: Proxy (((f :+: g) :+: C1 c1 f1) p)) =
+ let cName1 = conName (undefined :: C1 c1 f a)
+ in concat [ "("
+ , gArgHelper m path (Proxy :: Proxy ((f :+: g) p))
+ , " | "
+ , conNameMod m cName1
+ , if cName1 `elem` path
+ then "..."
+ else spaceNonEmpty $
+ gArgHelper m (cName1 : path) (Proxy :: Proxy (f1 p))
+ , ")"]
+
+instance (Constructor c1, GArgHelper f1, GArgHelper (f :+: g)) =>
+ GArgHelper (C1 c1 f1 :+: (f :+: g)) where
+ gArgHelper m path (Proxy :: Proxy ((C1 c1 f1 :+: (f :+: g)) p)) =
+ let cName1 = conName (undefined :: C1 c1 f a)
+ in concat [ "("
+ , conNameMod m cName1
+ , if cName1 `elem` path
+ then "..."
+ else spaceNonEmpty $
+ gArgHelper m (cName1 : path) (Proxy :: Proxy (f1 p))
+ , " | "
+ , gArgHelper m path (Proxy :: Proxy ((f :+: g) p))
+ , ")"]
+
+instance (Constructor c1, Constructor c2, GArgHelper f1, GArgHelper f2) =>
+ GArgHelper (C1 c1 f1 :+: C1 c2 f2) where
+ gArgHelper m path (Proxy :: Proxy ((C1 c1 f1 :+: C1 c2 f2) p)) =
+ let cName1 = conName (undefined :: C1 c1 f a)
+ cName2 = conName (undefined :: C1 c2 f a)
+ in concat [ "("
+ , conNameMod m cName1
+ , if cName1 `elem` path
+ then "..."
+ else spaceNonEmpty $
+ gArgHelper m (cName1 : path) (Proxy :: Proxy (f1 p))
+ , " | "
+ , conNameMod m cName2
+ , if cName2 `elem` path
+ then "..."
+ else spaceNonEmpty $
+ gArgHelper m (cName2 : path) (Proxy :: Proxy (f2 p))
+ , ")"]
+
-- Record Selectors
@@ -244,12 +327,26 @@ printS1 o s@(M1 x) = case (selName s, alwaysUseSelName o) of
(_, False) -> gToArgs o x
(name, True) -> selNameMod o name : gToArgs o x
+helpS1 :: (GArgHelper a)
+ => String -> Options -> [String] -> Proxy (S1 c a f) -> String
+helpS1 n o path (Proxy :: Proxy ((S1 c a) f)) =
+ case (n, alwaysUseSelName o) of
+ ("", _) -> gArgHelper o path (Proxy :: Proxy (a f))
+ (_, False) -> gArgHelper o path (Proxy :: Proxy (a f))
+ (name, True) -> concat [ selNameMod o name
+ , " "
+ , gArgHelper o path (Proxy :: Proxy (a f))]
+
instance (GArgParser a, Selector c) => GArgParser (S1 c a) where
gArgParser = parseS1 (selName (undefined :: S1 c a f))
instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
gToArgs = printS1
+instance (GArgHelper a, Selector c) => GArgHelper (S1 c a) where
+ gArgHelper = helpS1 (selName (undefined :: S1 c a f))
+
+
-- Optional arguments
instance {-#OVERLAPPING#-}
@@ -271,6 +368,20 @@ instance {-#OVERLAPPING#-}
(name, Just x') -> selNameMod m name : toArgs m x'
| otherwise = printS1 m s
+instance {-#OVERLAPPING#-}
+ (ArgHelper a, Selector c) => GArgHelper (S1 c (Rec0 (Maybe a))) where
+ gArgHelper m path (Proxy :: Proxy (S1 c (Rec0 (Maybe a)) f)) =
+ let n = selName (undefined :: S1 c (Rec0 (Maybe a)) f)
+ in case (omitNamedOptions m, null n) of
+ (True, True) -> gArgHelper m path (Proxy :: Proxy (Rec0 (Maybe a) f))
+ (True, False) -> concat [ "["
+ , selNameMod m n
+ , " "
+ , gArgHelper m path (Proxy :: Proxy (Rec0 a f))
+ , "]"]
+ _ -> helpS1 n m path (Proxy :: Proxy (S1 c (Rec0 (Maybe a)) f))
+
+
-- Constructors
instance (GArgParser a) => GArgParser (C1 c a) where
@@ -279,6 +390,9 @@ instance (GArgParser a) => GArgParser (C1 c a) where
instance (GToArgs a) => GToArgs (C1 c a) where
gToArgs m (M1 x) = gToArgs m x
+instance (GArgHelper a) => GArgHelper (C1 c a) where
+ gArgHelper m path (Proxy :: Proxy (C1 c a f)) =
+ gArgHelper m path (Proxy :: Proxy (a f))
-- Data types
@@ -288,6 +402,9 @@ instance (GArgParser a) => GArgParser (D1 c a) where
instance (GToArgs a) => GToArgs (D1 c a) where
gToArgs m (M1 x) = gToArgs m x
+instance (GArgHelper a) => GArgHelper (D1 c a) where
+ gArgHelper m path (Proxy :: Proxy (D1 c a f)) =
+ gArgHelper m path (Proxy :: Proxy (a f))
-- Constraints and such
@@ -297,6 +414,10 @@ instance (ArgParser a) => GArgParser (K1 i a) where
instance (ToArgs a) => GToArgs (K1 i a) where
gToArgs m (K1 x) = toArgs m x
+instance (ArgHelper a) => GArgHelper (K1 i a) where
+ gArgHelper m path (Proxy :: Proxy (K1 x a f)) =
+ argHelper m path (Proxy :: Proxy a)
+
-- Common types
@@ -312,38 +433,52 @@ instance ArgParser Int where
argParser _ = readArg
instance ToArgs Int where
toArgs _ i = [show i]
+instance ArgHelper Int where
+ argHelper _ _ _ = "INT"
instance ArgParser Integer where
argParser _ = readArg
instance ToArgs Integer where
toArgs _ i = [show i]
+instance ArgHelper Integer where
+ argHelper _ _ _ = "INTEGER"
instance ArgParser Rational where
argParser _ = readArg
instance ToArgs Rational where
toArgs _ i = [show i]
+instance ArgHelper Rational where
+ argHelper _ _ _ = "RATIONAL"
instance ArgParser Double where
argParser _ = readArg
instance ToArgs Double where
toArgs _ i = [show i]
+instance ArgHelper Double where
+ argHelper _ _ _ = "DOUBLE"
instance {-#OVERLAPPING#-} ArgParser String where
argParser _ = token (Right . unArg) Nothing
instance {-#OVERLAPPING#-} ToArgs String where
toArgs _ i = [i]
+instance {-#OVERLAPPING#-} ArgHelper String where
+ argHelper _ _ _ = "STRING"
instance ArgParser Bool
instance ToArgs Bool
+instance ArgHelper Bool
instance ArgParser a => ArgParser (Maybe a)
instance ToArgs a => ToArgs (Maybe a)
+instance ArgHelper a => ArgHelper (Maybe a)
instance ArgParser a => ArgParser [a]
instance ToArgs a => ToArgs [a]
+instance ArgHelper a => ArgHelper [a]
instance (ArgParser a, ArgParser b) => ArgParser (Either a b)
instance (ToArgs a, ToArgs b) => ToArgs (Either a b)
+instance (ArgHelper a, ArgHelper b) => ArgHelper (Either a b)
-- | Expects a dot.
instance ArgParser () where
@@ -351,18 +486,26 @@ instance ArgParser () where
-- | Shows a dot.
instance ToArgs () where
toArgs _ () = ["."]
+instance ArgHelper () where
+ argHelper _ _ _ = "."
instance (ArgParser a, ArgParser b) => ArgParser (a, b)
instance (ToArgs a, ToArgs b) => ToArgs (a, b)
+instance (ArgHelper a, ArgHelper b) => ArgHelper (a, b)
instance (ArgParser a, ArgParser b, ArgParser c) => ArgParser (a, b, c)
instance (ToArgs a, ToArgs b, ToArgs c) => ToArgs (a, b, c)
+instance (ArgHelper a, ArgHelper b, ArgHelper c) => ArgHelper (a, b, c)
instance (ArgParser a, ArgParser b, ArgParser c, ArgParser d) =>
ArgParser (a, b, c, d)
instance (ToArgs a, ToArgs b, ToArgs c, ToArgs d) => ToArgs (a, b, c, d)
+instance (ArgHelper a, ArgHelper b, ArgHelper c, ArgHelper d) =>
+ ArgHelper (a, b, c, d)
instance (ArgParser a, ArgParser b, ArgParser c, ArgParser d, ArgParser e) =>
ArgParser (a, b, c, d, e)
instance (ToArgs a, ToArgs b, ToArgs c, ToArgs d, ToArgs e) =>
ToArgs (a, b, c, d, e)
+instance (ArgHelper a, ArgHelper b, ArgHelper c, ArgHelper d, ArgHelper e) =>
+ ArgHelper (a, b, c, d, e)
diff --git a/Example.hs b/Example.hs
index a5dcb35..a1af925 100644
--- a/Example.hs
+++ b/Example.hs
@@ -3,18 +3,21 @@ module Main where
import GHC.Generics
import Coalpit
+import Data.Proxy
data FooArgs = FooArgs { arg1 :: Int
, arg2 :: String
} deriving (Generic, Show)
instance ArgParser FooArgs
instance ToArgs FooArgs
+instance ArgHelper FooArgs
data FooBar = Foo FooArgs
| Bar
deriving (Generic, Show)
instance ArgParser FooBar
instance ToArgs FooBar
+instance ArgHelper FooBar
data Input = Input { something :: Maybe String
, fooBar :: Maybe FooBar
@@ -22,6 +25,7 @@ data Input = Input { something :: Maybe String
} deriving (Generic, Show)
instance ArgParser Input
instance ToArgs Input
+instance ArgHelper Input
main :: IO ()
main = do
@@ -33,3 +37,20 @@ main = do
print val
print args
print (fromArgs defOpt args :: Either String Input)
+
+data Test = Test { foo :: [Int], bar :: Maybe String }
+ deriving (Generic, Show)
+
+instance ArgParser Test
+instance ToArgs Test
+instance ArgHelper Test
+
+help :: IO ()
+help = do
+ mapM_ (\(o, x, y) -> print o >> print x >> putStrLn y) $
+ [ let opts = defOpt { alwaysUseSelName = ausn
+ , omitNamedOptions = ono }
+ in ((ausn, ono), toArgs opts (Test [] vals), argHelper opts [] (Proxy :: Proxy Test))
+ | ausn <- [True, False]
+ , ono <- [True, False]
+ , vals <- [Just "a string", Nothing]]
diff --git a/README.md b/README.md
index bcefff4..cb38e87 100644
--- a/README.md
+++ b/README.md
@@ -8,8 +8,8 @@ while keeping them language-agnostic and more user- and shell
scripting-friendly than JSON and similar formats.
Given a type, it derives instances to print and parse it as
-command-line arguments. The resulting deserialization wouldn't be as
-nice as that of
+command-line arguments, as well as to compose usage instructions. The
+resulting deserialization wouldn't be as nice as that of
e.g.
[optparse-generic](https://hackage.haskell.org/package/optparse-generic),
but the aim here is to handle more or less arbitrary types.
@@ -46,6 +46,12 @@ What would look like this in a shell:
--foobar foo 1 'a string' bar
```
+And its usage string -- like this:
+
+```
+[--something STRING] [--foobar (foo INT STRING | bar)] (foo INT STRING | bar)
+```
+
More verbose versions can be produced and parsed with
`alwaysUseSelName = True` and/or `omitNamedOptions = False`:
@@ -54,3 +60,33 @@ More verbose versions can be produced and parsed with
nothing just foo 1 'a string' bar
--something nothing --foobar just foo --arg1 1 --arg2 'a string' --foobar2 bar
```
+
+And here is output of the `help` function from the same file, with all
+the (alwaysUseSelName, omitNamedOptions) combinations:
+
+```
+(True,True)
+["--foo","[]","--bar","a string"]
+--foo ([] | : INT ([] | :...)) [--bar STRING]
+(True,True)
+["--foo","[]"]
+--foo ([] | : INT ([] | :...)) [--bar STRING]
+(True,False)
+["--foo","[]","--bar","just","a string"]
+--foo ([] | : INT ([] | :...)) --bar (nothing | just STRING)
+(True,False)
+["--foo","[]","--bar","nothing"]
+--foo ([] | : INT ([] | :...)) --bar (nothing | just STRING)
+(False,True)
+["[]","--bar","a string"]
+([] | : INT ([] | :...)) [--bar STRING]
+(False,True)
+["[]"]
+([] | : INT ([] | :...)) [--bar STRING]
+(False,False)
+["[]","just","a string"]
+([] | : INT ([] | :...)) (nothing | just STRING)
+(False,False)
+["[]","nothing"]
+([] | : INT ([] | :...)) (nothing | just STRING)
+```