summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-04 07:28:42 +0300
committerdefanor <defanor@uberspace.net>2017-12-04 07:28:42 +0300
commit967ae182b0a6852cc37e77cb88ee53a53526f027 (patch)
tree730395d2dbd046311300af3ac3b654ed0e18f3db
parent95c890dbcd07b7355399e122191a362714cd52b9 (diff)
Be more strict on record selector name parsing
Ambiguity is possible if the parser accepts those optionally, so it should accept them depending on the provided options.
-rw-r--r--Coalpit.hs12
-rw-r--r--README.md4
-rw-r--r--test/Test.hs17
3 files changed, 21 insertions, 12 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index 99eb1f9..246f036 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -87,7 +87,7 @@ data Modifiers = Modifiers { conNameMod :: String -> String
-- ^ Constructor name modifier.
, selNameMod :: String -> String
-- ^ Record selector name modifier.
- , alwaysAddSelName :: Bool
+ , alwaysUseSelName :: Bool
-- ^ Add record selector name always, not
-- just for optional arguments.
}
@@ -189,14 +189,14 @@ instance (Constructor c1, Constructor c2, GToArgs f1, GToArgs f2) =>
instance (GArgParser a, Selector c) => GArgParser (S1 c a) where
gArgParser m = M1 <$> do
- let sname = case selName (undefined :: S1 c a f) of
- "" -> pure ()
- name -> optional (pS (string (selNameMod m name)))
- >> pure ()
+ 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
instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
- gToArgs m s@(M1 x) = case (selName s, alwaysAddSelName m) of
+ 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
diff --git a/README.md b/README.md
index 27c0bd1..898bb9e 100644
--- a/README.md
+++ b/README.md
@@ -45,8 +45,8 @@ What would look like this in a shell:
--foobar foo 1 'a string' bar
```
-A more verbose version can be produced with `alwaysAddSelName = True`,
-while parsing would accept either version:
+A more verbose version can be produced and parsed with
+`alwaysUseSelName = True`:
```sh
--foobar foo --arg1 1 --arg2 'a string' --foobar2 bar
diff --git a/test/Test.hs b/test/Test.hs
index a467ceb..d5860d4 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -96,6 +96,14 @@ instance ArgParser RecursiveRecordMaybe2
instance ToArgs RecursiveRecordMaybe2
instance Arbitrary RecursiveRecordMaybe2 where arbitrary = genericArbitraryU
+data RecordStrings = RecordStrings
+ { s1 :: String
+ , s2 :: String
+ , s3 :: String
+ } deriving (Generic, Eq, Show)
+instance ArgParser RecordStrings
+instance ToArgs RecordStrings
+instance Arbitrary RecordStrings where arbitrary = genericArbitraryU
printAndParse :: (ArgParser a, ToArgs a, Eq a)
=> Modifiers -> Proxy a -> a -> Bool
@@ -123,14 +131,15 @@ idEqToAndFrom m = testGroup "id == parse . print"
, mkTest m (Proxy :: Proxy NestedSum) "NestedSum"
, mkTest m (Proxy :: Proxy RecursiveRecordMaybe) "RecursiveRecordMaybe"
, mkTest m (Proxy :: Proxy RecursiveRecordMaybe2) "RecursiveRecordMaybe2"
+ , mkTest m (Proxy :: Proxy RecordStrings) "RecordStrings"
]
variousModifiers :: (Modifiers -> TestTree) -> TestTree
variousModifiers tt = testGroup "Various modifiers"
- [ testGroup "alwaysAddSelName = True"
- [tt defMod { alwaysAddSelName = True }]
- , testGroup "alwaysAddSelName = False"
- [tt defMod { alwaysAddSelName = False }]
+ [ testGroup "alwaysUseSelName = True"
+ [tt defMod { alwaysUseSelName = True }]
+ , testGroup "alwaysUseSelName = False"
+ [tt defMod { alwaysUseSelName = False }]
]
qcProps :: TestTree