From 2581f4b9a61d8ca4c782269886c30b3cc433d85d Mon Sep 17 00:00:00 2001 From: defanor Date: Sun, 24 Dec 2017 07:12:59 +0300 Subject: Introduce 'Usage' structure. Produce it with 'argHelper' first, then translate into a string -- so that it can be reused for other kinds of output, such as roff and texinfo. --- Coalpit.hs | 2 +- Coalpit/Core.hs | 154 ++++++++++++++++++++++++++++++------------------------ examples/Basic.hs | 4 +- examples/Pipes.hs | 3 +- 4 files changed, 91 insertions(+), 72 deletions(-) diff --git a/Coalpit.hs b/Coalpit.hs index 78be85e..cd6e69b 100644 --- a/Coalpit.hs +++ b/Coalpit.hs @@ -29,7 +29,7 @@ main = do case 'fromArgs' 'defOpt' args of Left err -> do putStrLn err - putStrLn $ "Usage: " ++ 'usage' 'defOpt' (Proxy :: Proxy Foo) + putStrLn $ "Usage: " ++ 'usageString' 'defOpt' (Proxy :: Proxy Foo) Right x -> do print (x :: Foo) print $ 'toArgs' 'defOpt' x diff --git a/Coalpit/Core.hs b/Coalpit/Core.hs index ac2b03c..0e10757 100644 --- a/Coalpit/Core.hs +++ b/Coalpit/Core.hs @@ -17,9 +17,11 @@ and 'Options' are defined here. {-# LANGUAGE ScopedTypeVariables #-} module Coalpit.Core ( Coalpit(..) - -- * Utility functions , fromArgs + -- * Usage + , Usage(..) , usage + , usageString -- * Options , Options(..) , defOpt @@ -48,6 +50,15 @@ import Network.URI (URI, parseURIReference, uriToString) import Coalpit.Parsing +data Usage = UConstructor String + | URecursive String + | USelector String Usage + | UOptional Usage + | USum Usage Usage + | UProduct Usage Usage + | UUnit + | UType String + -- | Printing and parsing options. data Options = Options { fieldSeparator :: Char -- ^ DSV field separator ('showDSV', @@ -85,10 +96,31 @@ fromArgs opt args = case parse (argParser opt) "arguments" (map CLArg args) of Left err -> Left $ parseErrorPretty err Right x -> Right x --- | Composes a usage string. -usage :: Coalpit a => Options -> Proxy a -> String +-- | Composes 'Usage' description. +usage :: Coalpit a => Options -> Proxy a -> Usage usage opt = argHelper opt [] +-- | Composes a usage string. +usageString :: Coalpit a => Options -> Proxy a -> String +usageString opt = usageToString . usage opt + +-- | Translates 'Usage' into a string, used by 'usageString'. +usageToString :: Usage -> String +usageToString (UConstructor c) = c +usageToString (URecursive c) = c ++ "..." +usageToString (USelector s u) = s ++ " " ++ usageToString u +usageToString (UOptional u) = "[" ++ usageToString u ++ "]" +usageToString (USum ul ur) = concat [ "(" + , usageToString ul + , " | " + , usageToString ur + , ")"] +usageToString (UProduct u1 UUnit) = usageToString u1 +usageToString (UProduct u1 u2) = usageToString u1 ++ " " ++ usageToString u2 +usageToString UUnit = "" +usageToString (UType t) = t + + -- | Coalpit class: parsing, printing, usage strings. class Coalpit a where argParser :: Options -> Parser a @@ -99,22 +131,22 @@ class Coalpit a where default toArgs :: (Generic a, GCoalpit (Rep a)) => Options -> a -> [String] toArgs opt a = gToArgs opt (from a) - argHelper :: Options -> [String] -> Proxy a -> String + argHelper :: Options -> [String] -> Proxy a -> Usage default argHelper :: (GCoalpit (Rep a)) - => Options -> [String] -> Proxy a -> String + => Options -> [String] -> Proxy a -> Usage argHelper opt path Proxy = gArgHelper opt path (Proxy :: Proxy (Rep a p)) class GCoalpit a where gArgParser :: Options -> Parser (a p) gToArgs :: Options -> a p -> [String] - gArgHelper :: Options -> [String] -> Proxy (a p) -> String + gArgHelper :: Options -> [String] -> Proxy (a p) -> Usage -- Units instance GCoalpit U1 where gArgParser _ = pure U1 gToArgs _ U1 = [] - gArgHelper _ _ (Proxy :: Proxy (U1 f)) = "" + gArgHelper _ _ (Proxy :: Proxy (U1 f)) = UUnit -- Products @@ -122,9 +154,8 @@ instance (GCoalpit a, GCoalpit b) => GCoalpit (a :*: b) where gArgParser opt = (:*:) <$> gArgParser opt <*> gArgParser opt gToArgs opt (x :*: y) = gToArgs opt x ++ gToArgs opt y gArgHelper opt path (Proxy :: Proxy ((a :*: b) p)) = - concat [ gArgHelper opt path (Proxy :: Proxy (a p)) - , " " - , gArgHelper opt path (Proxy :: Proxy (b p))] + UProduct (gArgHelper opt path (Proxy :: Proxy (a p))) + (gArgHelper opt path (Proxy :: Proxy (b p))) -- Sums @@ -136,13 +167,13 @@ handleRecCon :: GCoalpit a -> Options -> [String] -> Proxy (a p) - -> String -handleRecCon nameA opt path (Proxy :: Proxy (a p)) = conNameMod opt nameA - ++ if nameA `elem` path - then "..." - else case gArgHelper opt (nameA : path) (Proxy :: Proxy (a p)) of - "" -> "" - s -> ' ' : s + -> Usage +handleRecCon nameA opt path (Proxy :: Proxy (a p)) = + let n = conNameMod opt nameA + in if nameA `elem` path + then URecursive n + else UProduct (UConstructor n) + (gArgHelper opt (nameA : path) (Proxy :: Proxy (a p))) instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) => GCoalpit ((b :+: c) :+: C1 conA a) where @@ -155,11 +186,8 @@ instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) => gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x gArgHelper opt path (Proxy :: Proxy (((b :+: c) :+: C1 conA a) p)) = let nameA = conName (undefined :: C1 conA f p) - in concat [ "(" - , gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)) - , " | " - , handleRecCon nameA opt path (Proxy :: Proxy (a p)) - , ")"] + in USum (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p))) + (handleRecCon nameA opt path (Proxy :: Proxy (a p))) instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) => GCoalpit (C1 conA a :+: (b :+: c)) where @@ -172,11 +200,8 @@ instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) => gToArgs opt (R1 x) = gToArgs opt x gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: (b :+: c)) p)) = let nameA = conName (undefined :: C1 conA a p) - in concat [ "(" - , handleRecCon nameA opt path (Proxy :: Proxy (a p)) - , " | " - , gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)) - , ")"] + in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p))) + (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p))) instance (Constructor conA, Constructor conB, GCoalpit a, GCoalpit b) => GCoalpit (C1 conA a :+: C1 conB b) where @@ -193,11 +218,8 @@ instance (Constructor conA, Constructor conB, GCoalpit a, GCoalpit b) => gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: C1 conB b) p)) = let nameA = conName (undefined :: C1 conA a p) nameB = conName (undefined :: C1 conB b p) - in concat [ "(" - , handleRecCon nameA opt path (Proxy :: Proxy (a p)) - , " | " - , handleRecCon nameB opt path (Proxy :: Proxy (b p)) - , ")"] + in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p))) + (handleRecCon nameB opt path (Proxy :: Proxy (b p))) -- Record Selectors @@ -217,14 +239,13 @@ printS1 opt sel@(M1 x) = case (selName sel, alwaysUseSelName opt) of (name, True) -> selNameMod opt name : gToArgs opt x helpS1 :: (GCoalpit a) - => String -> Options -> [String] -> Proxy (S1 selA a p) -> String + => String -> Options -> [String] -> Proxy (S1 selA a p) -> Usage helpS1 nameA opt path (Proxy :: Proxy (S1 selA a p)) = case (nameA, alwaysUseSelName opt) of ("", _) -> gArgHelper opt path (Proxy :: Proxy (a p)) (_, False) -> gArgHelper opt path (Proxy :: Proxy (a p)) - (_, True) -> concat [ selNameMod opt nameA - , " " - , gArgHelper opt path (Proxy :: Proxy (a p))] + (_, True) -> USelector (selNameMod opt nameA) + (gArgHelper opt path (Proxy :: Proxy (a p))) instance (GCoalpit a, Selector selA) => GCoalpit (S1 selA a) where gArgParser = parseS1 (selName (undefined :: S1 selA a p)) @@ -253,11 +274,8 @@ instance {-#OVERLAPPING#-} let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p) in case (omitNamedOptions opt, null nameA) of (True, True) -> gArgHelper opt path (Proxy :: Proxy (Rec0 (Maybe a) p)) - (True, False) -> concat [ "[" - , selNameMod opt nameA - , " " - , gArgHelper opt path (Proxy :: Proxy (Rec0 a p)) - , "]"] + (True, False) -> UOptional $ USelector (selNameMod opt nameA) + (gArgHelper opt path (Proxy :: Proxy (Rec0 a p))) _ -> helpS1 nameA opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p)) @@ -289,82 +307,82 @@ instance (Coalpit a) => GCoalpit (K1 i a) where instance Coalpit Int where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "INT" + argHelper _ _ _ = UType "INT" instance Coalpit Integer where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "INTEGER" + argHelper _ _ _ = UType "INTEGER" instance Coalpit Word8 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "WORD8" + argHelper _ _ _ = UType "WORD8" instance Coalpit Word16 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "WORD16" + argHelper _ _ _ = UType "WORD16" instance Coalpit Word32 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "WORD32" + argHelper _ _ _ = UType "WORD32" instance Coalpit Word64 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "WORD64" + argHelper _ _ _ = UType "WORD64" instance Coalpit Int8 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "INT8" + argHelper _ _ _ = UType "INT8" instance Coalpit Int16 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "INT16" + argHelper _ _ _ = UType "INT16" instance Coalpit Int32 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "INT32" + argHelper _ _ _ = UType "INT32" instance Coalpit Int64 where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "INT64" + argHelper _ _ _ = UType "INT64" instance Coalpit Natural where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "NATURAL" + argHelper _ _ _ = UType "NATURAL" instance Coalpit Rational where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "RATIONAL" + argHelper _ _ _ = UType "RATIONAL" instance Coalpit Double where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "DOUBLE" + argHelper _ _ _ = UType "DOUBLE" instance Coalpit Float where argParser _ = readArg toArgs _ i = [show i] - argHelper _ _ _ = "FLOAT" + argHelper _ _ _ = UType "FLOAT" instance Coalpit Char where argParser _ = readArg toArgs _ c = [show c] - argHelper _ _ _ = "CHAR" + argHelper _ _ _ = UType "CHAR" instance {-#OVERLAPPING#-} Coalpit String where argParser _ = token (Right . unArg) Nothing toArgs _ i = [i] - argHelper _ _ _ = "STRING" + argHelper _ _ _ = UType "STRING" instance Coalpit Scientific where argParser _ = try $ do @@ -374,7 +392,7 @@ instance Coalpit Scientific where _ -> fail $ "Failed to read a scientific number: " ++ x toArgs opt n = [formatScientific (scientificFormat opt) (scientificDecimals opt) n] - argHelper _ _ _ = "SCIENTIFIC" + argHelper _ _ _ = UType "SCIENTIFIC" instance Coalpit Version where argParser _ = try $ do @@ -383,7 +401,7 @@ instance Coalpit Version where (v, ""):_ -> pure v _ -> fail $ "Failed to read a version: " ++ x toArgs _ v = [showVersion v] - argHelper _ _ _ = "VERSION" + argHelper _ _ _ = UType "VERSION" -- | An URI reference (absolute or relative). instance Coalpit URI where @@ -391,44 +409,44 @@ instance Coalpit URI where x <- token (Right . unArg) Nothing maybe (fail $ "Failed to parse URI: " ++ x) pure (parseURIReference x) toArgs opt u = [uriToString (uriUserInfo opt) u ""] - argHelper _ _ _ = "URI" + argHelper _ _ _ = UType "URI" -- | Uses 'dateTimeFormat'. instance Coalpit UTCTime where argParser opt = pTime (timeLocale opt) (dateTimeFormat opt) toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t] - argHelper _ _ _ = "UTC_TIME" + argHelper _ _ _ = UType "UTC_TIME" -- | Uses 'dateTimeFormat'. instance Coalpit ZonedTime where argParser opt = pTime (timeLocale opt) (dateTimeFormat opt) toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t] - argHelper _ _ _ = "ZONED_TIME" + argHelper _ _ _ = UType "ZONED_TIME" -- | Uses 'dateTimeFormat'. instance Coalpit LocalTime where argParser opt = pTime (timeLocale opt) (dateTimeFormat opt) toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t] - argHelper _ _ _ = "LOCAL_TIME" + argHelper _ _ _ = UType "LOCAL_TIME" -- | Uses 'dateTimeFormat'. instance Coalpit UniversalTime where argParser opt = pTime (timeLocale opt) (dateTimeFormat opt) toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t] - argHelper _ _ _ = "UNIVERSAL_TIME" + argHelper _ _ _ = UType "UNIVERSAL_TIME" -- | Uses 'timeFormat'. instance Coalpit TimeOfDay where argParser opt = pTime (timeLocale opt) (timeFormat opt) toArgs opt t = [formatTime (timeLocale opt) (timeFormat opt) t] - argHelper _ _ _ = "TIME_OF_DAY" + argHelper _ _ _ = UType "TIME_OF_DAY" -- | Uses 'dateFormat'. instance Coalpit Day where argParser opt = pTime (timeLocale opt) (dateFormat opt) toArgs opt t = [formatTime (timeLocale opt) (dateFormat opt) t] - argHelper _ _ _ = "DAY" + argHelper _ _ _ = UType "DAY" -- | Converts to/from 'Scientific'. instance Coalpit NominalDiffTime where @@ -436,7 +454,7 @@ instance Coalpit NominalDiffTime where <$> (argParser opt :: Parser Scientific) toArgs opt = toArgs opt . (fromRational . toRational :: NominalDiffTime -> Scientific) - argHelper _ _ _ = "NOMINAL_DIFF_TIME" + argHelper _ _ _ = UType "NOMINAL_DIFF_TIME" -- | Converts to/from 'Scientific'. instance Coalpit DiffTime where @@ -444,7 +462,7 @@ instance Coalpit DiffTime where <$> (argParser opt :: Parser Scientific) toArgs opt = toArgs opt . (fromRational . toRational :: DiffTime -> Scientific) - argHelper _ _ _ = "DIFF_TIME" + argHelper _ _ _ = UType "DIFF_TIME" instance Coalpit () diff --git a/examples/Basic.hs b/examples/Basic.hs index a08730d..13ee95d 100644 --- a/examples/Basic.hs +++ b/examples/Basic.hs @@ -38,8 +38,8 @@ help = do [ let opts = defOpt { alwaysUseSelName = ausn , omitNamedOptions = ono } in ( (ausn, ono) - , showDSV opts [Test [1,2,3] vals] - , argHelper opts [] (Proxy :: Proxy Test)) + , showDSV opts (Test [1,2,3] vals) + , usageString opts (Proxy :: Proxy Test)) | ausn <- [True, False] , ono <- [True, False] , vals <- [Just "a string", Nothing]] diff --git a/examples/Pipes.hs b/examples/Pipes.hs index 7b50f93..b1096e3 100644 --- a/examples/Pipes.hs +++ b/examples/Pipes.hs @@ -37,7 +37,8 @@ runMain :: forall m a i o. (MonadIO m, Coalpit a, Coalpit i, Coalpit o) -> m () runMain e f = do pn <- liftIO getProgName - let u = Prelude.concat ["Usage: ", pn, " ", usage defOpt (Proxy :: Proxy a)] + let u = Prelude.concat [ "Usage: ", pn, " " + , usageString defOpt (Proxy :: Proxy a)] args <- liftIO getArgs a <- either (liftIO . die . (++ u)) pure $ fromArgs defOpt args runEffect $ -- cgit v1.2.3