From 88d9c4a76e27ddee2170bb21e90e0f0fcf77b44c Mon Sep 17 00:00:00 2001 From: defanor Date: Mon, 4 Dec 2017 19:14:06 +0300 Subject: Introduce the omitNamedOptions option It is nice to omit them, but may lead to ambiguity -- so better to provide a safer option. --- Coalpit.hs | 114 ++++++++++++++++++++++++++++++++--------------------------- Example.hs | 4 +-- README.md | 15 ++++---- test/Test.hs | 22 ++++++------ 4 files changed, 85 insertions(+), 70 deletions(-) diff --git a/Coalpit.hs b/Coalpit.hs index 7b9fd39..ce06417 100644 --- a/Coalpit.hs +++ b/Coalpit.hs @@ -27,11 +27,11 @@ instance 'ToArgs' Foo main :: IO () main = do args <- getArgs - case 'fromArgs' 'defMod' args of + case 'fromArgs' 'defOpt' args of Left err -> putStrLn err Right x -> do print (x :: Foo) - print $ 'toArgs' 'defMod' x + print $ 'toArgs' 'defOpt' x @ Then, in a shell: @@ -58,9 +58,9 @@ module Coalpit ( , ToArgs(..) -- * Utility functions , fromArgs - -- * Modifiers - , Modifiers(..) - , defMod + -- * Options + , Options(..) + , defOpt -- * Parsing helpers , Parser , CLArg(..) @@ -99,13 +99,13 @@ instance Stream [CLArg] where chunkEmpty Proxy = null advance1 Proxy = advance advanceN Proxy w = foldl' (advance w) - take1_ ([]) = Nothing - take1_ ((t:ts)) = Just (t, ts) + take1_ [] = Nothing + take1_ (t:ts) = Just (t, ts) takeN_ n s | n <= 0 = Just ([], s) | null s = Nothing - | otherwise = Just (take n s, (drop n s)) - takeWhile_ f s = (takeWhile f s, (dropWhile f s)) + | otherwise = Just (splitAt n s) + takeWhile_ = span instance ShowToken CLArg where showTokens xs = concat $ NE.map unArg xs @@ -122,46 +122,49 @@ pS p = try $ do Right x' -> pure x' --- | Name modifiers. -data Modifiers = Modifiers { conNameMod :: String -> String - -- ^ Constructor name modifier. - , selNameMod :: String -> String - -- ^ Record selector name modifier. - , alwaysUseSelName :: Bool - -- ^ Add record selector name always, not - -- just for optional arguments. - } +-- | Printing and parsing options. +data Options = Options { conNameMod :: String -> String + -- ^ Constructor name modifier. + , selNameMod :: String -> String + -- ^ Record selector name modifier. + , alwaysUseSelName :: Bool + -- ^ Add record selector name always, not just + -- for optional arguments. + , omitNamedOptions :: Bool + -- ^ Omit named Maybe values to indicate + -- 'Nothing'. + } --- | Default modifiers. -defMod :: Modifiers -defMod = Modifiers (map toLower) (("--" ++) . map toLower) False +-- | Default options. +defOpt :: Options +defOpt = Options (map toLower) (("--" ++) . map toLower) False True -- Core classes -- | Arguments parser class. class ArgParser a where - argParser :: Modifiers -> Parser a - default argParser :: (Generic a, GArgParser (Rep a)) => Modifiers -> Parser a - argParser m = to <$> gArgParser m + argParser :: Options -> Parser a + default argParser :: (Generic a, GArgParser (Rep a)) => Options -> Parser a + argParser o = to <$> gArgParser o class GArgParser f where - gArgParser :: Modifiers -> Parser (f a) + gArgParser :: Options -> Parser (f a) -- | Parses arguments. -fromArgs :: ArgParser a => Modifiers -> [String] -> Either String a -fromArgs m args = case parse (argParser m) "arguments" (map CLArg args) of +fromArgs :: ArgParser a => Options -> [String] -> Either String a +fromArgs o args = case parse (argParser o) "arguments" (map CLArg args) of Left err -> Left $ parseErrorPretty err Right x -> Right x -- | Arguments serializer class. class ToArgs a where - toArgs :: Modifiers -> a -> [String] - default toArgs :: (Generic a, GToArgs (Rep a)) => Modifiers -> a -> [String] - toArgs m a = gToArgs m (from a) + toArgs :: Options -> a -> [String] + default toArgs :: (Generic a, GToArgs (Rep a)) => Options -> a -> [String] + toArgs o a = gToArgs o (from a) class GToArgs f where - gToArgs :: Modifiers -> f a -> [String] + gToArgs :: Options -> f a -> [String] -- Units @@ -227,39 +230,46 @@ instance (Constructor c1, Constructor c2, GToArgs f1, GToArgs f2) => -- Record Selectors +parseS1 :: (GArgParser a) => String -> Options -> Parser (S1 c a f) +parseS1 n o = + let sname = case (n, alwaysUseSelName o) of + ("", _) -> pure () + (_, False) -> pure () + (name, True) -> pS (string (selNameMod o name)) >> pure () + in M1 <$> (sname *> gArgParser o) + +printS1 :: (GToArgs f, Selector c) => Options -> S1 c f a -> [String] +printS1 o s@(M1 x) = case (selName s, alwaysUseSelName o) of + ("", _) -> gToArgs o x + (_, False) -> gToArgs o x + (name, True) -> selNameMod o name : gToArgs o x + instance (GArgParser a, Selector c) => GArgParser (S1 c a) where - gArgParser m = M1 <$> do - let sname = case (selName (undefined :: S1 c a f), alwaysUseSelName m) of - ("", _) -> pure () - (_, False) -> pure () - (name, True) -> pS (string (selNameMod m name)) >> pure () - sname *> gArgParser m + gArgParser = parseS1 (selName (undefined :: S1 c a f)) instance (GToArgs a, Selector c) => GToArgs (S1 c a) where - gToArgs m s@(M1 x) = case (selName s, alwaysUseSelName m) of - ("", _) -> gToArgs m x - (_, False) -> gToArgs m x - (name, True) -> selNameMod m name : gToArgs m x - + gToArgs = printS1 -- Optional arguments instance {-#OVERLAPPING#-} (ArgParser a, Selector c) => GArgParser (S1 c (Rec0 (Maybe a))) where gArgParser m = - case selName (undefined :: S1 c (Rec0 (Maybe a)) f) of - "" -> M1 <$> gArgParser m - name -> do - x <- optional $ pS (string (selNameMod m name)) *> argParser m - pure $ M1 $ K1 x + let n = selName (undefined :: S1 c (Rec0 (Maybe a)) f) + in case (omitNamedOptions m, null n) of + (True, True) -> M1 <$> gArgParser m + (True, False) -> + M1 . K1 <$> optional (pS (string (selNameMod m n)) *> argParser m) + _ -> parseS1 n m instance {-#OVERLAPPING#-} (ToArgs a, Selector c) => GToArgs (S1 c (Rec0 (Maybe a))) where - gToArgs m s@(M1 (K1 x)) = case (selName s, x) of - ("", _) -> toArgs m x - (_, Nothing) -> [] - (name, Just x') -> selNameMod m name : toArgs m x' - + gToArgs m s@(M1 (K1 x)) + | omitNamedOptions m = case (selName s, x) of + ("", _) -> toArgs m x + (_, Nothing) -> [] + (name, Just x') -> selNameMod m name : toArgs m x' + | otherwise = printS1 m s -- Constructors diff --git a/Example.hs b/Example.hs index 4784aa2..a5dcb35 100644 --- a/Example.hs +++ b/Example.hs @@ -29,7 +29,7 @@ main = do , fooBar = Just (Foo FooArgs { arg1 = 1 , arg2 = "a string"}) , fooBar2 = Bar} - args = toArgs defMod val + args = toArgs defOpt val print val print args - print (fromArgs defMod args :: Either String Input) + print (fromArgs defOpt args :: Either String Input) diff --git a/README.md b/README.md index 898bb9e..bcefff4 100644 --- a/README.md +++ b/README.md @@ -14,9 +14,10 @@ e.g. [optparse-generic](https://hackage.haskell.org/package/optparse-generic), but the aim here is to handle more or less arbitrary types. -Warning: it is currently possible to run into ambiguity by defining a -recursive structure with optional named elements. Unit type can be -used to avoid that, see the `RecursiveRecordMaybe` test. +Warning: it is possible to run into ambiguity by defining a recursive +structure with optional named elements while using default options. +Unit type can be used to avoid that, or `omitNamedOptions` can be +disabled. Not production-ready yet, merely a prototype. @@ -32,7 +33,7 @@ Input { something = Nothing , fooBar2 = Bar} ``` -With the default modifiers, its serialized version should look like +With the default options, its serialized version should look like this: ```haskell @@ -45,9 +46,11 @@ What would look like this in a shell: --foobar foo 1 'a string' bar ``` -A more verbose version can be produced and parsed with -`alwaysUseSelName = True`: +More verbose versions can be produced and parsed with +`alwaysUseSelName = True` and/or `omitNamedOptions = False`: ```sh --foobar foo --arg1 1 --arg2 'a string' --foobar2 bar +nothing just foo 1 'a string' bar +--something nothing --foobar just foo --arg1 1 --arg2 'a string' --foobar2 bar ``` diff --git a/test/Test.hs b/test/Test.hs index d5860d4..ffcae8e 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -106,14 +106,14 @@ instance ToArgs RecordStrings instance Arbitrary RecordStrings where arbitrary = genericArbitraryU printAndParse :: (ArgParser a, ToArgs a, Eq a) - => Modifiers -> Proxy a -> a -> Bool + => Options -> Proxy a -> a -> Bool printAndParse m _ r = Right r == fromArgs m (toArgs m r) mkTest :: (ArgParser a, ToArgs a, Eq a, Show a, Arbitrary a) - => Modifiers -> Proxy a -> String -> TestTree + => Options -> Proxy a -> String -> TestTree mkTest m p n = QC.testProperty n (printAndParse m p) -idEqToAndFrom :: Modifiers -> TestTree +idEqToAndFrom :: Options -> TestTree idEqToAndFrom m = testGroup "id == parse . print" [ mkTest m (Proxy :: Proxy Basic) "Basic" , mkTest m (Proxy :: Proxy WithLists) "WithLists" @@ -134,17 +134,19 @@ idEqToAndFrom m = testGroup "id == parse . print" , mkTest m (Proxy :: Proxy RecordStrings) "RecordStrings" ] -variousModifiers :: (Modifiers -> TestTree) -> TestTree -variousModifiers tt = testGroup "Various modifiers" - [ testGroup "alwaysUseSelName = True" - [tt defMod { alwaysUseSelName = True }] - , testGroup "alwaysUseSelName = False" - [tt defMod { alwaysUseSelName = False }] +variousOptions :: (Options -> TestTree) -> TestTree +variousOptions tt = testGroup "Various modifiers" + [ testGroup (concat [ "alwaysUseSelName = ", show ausn + , ", omitNamedOptions = ", show ono]) + [tt defOpt { alwaysUseSelName = ausn + , omitNamedOptions = ono }] + | ausn <- [True, False] + , ono <- [True, False] ] qcProps :: TestTree qcProps = testGroup "Quickcheck properties" - [ variousModifiers idEqToAndFrom ] + [ variousOptions idEqToAndFrom ] main :: IO () main = travisTestReporter defaultConfig [] qcProps -- cgit v1.2.3