Generate usage strings for help messages

1 files changed, 144 insertions, 1 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)