From 6ca0662862dffcc67ff4016aaa04cf314d81608e Mon Sep 17 00:00:00 2001 From: defanor Date: Sat, 16 Dec 2017 06:11:12 +0300 Subject: Generate usage strings for help messages --- Coalpit.hs | 145 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- Example.hs | 21 +++++++++ README.md | 40 ++++++++++++++++- 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) +``` -- cgit v1.2.3