summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Coalpit.hs114
-rw-r--r--Example.hs4
-rw-r--r--README.md15
-rw-r--r--test/Test.hs22
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