summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-03 08:12:35 +0300
committerdefanor <defanor@uberspace.net>2017-12-03 08:12:35 +0300
commitc9b0d21826c1479ae3c977713b21ccd704b2b95a (patch)
treed57924c62675d313ad20c8286fda382051df79d7
parentecc1d48c01ef5633d6229dc9009a899141b2eec7 (diff)
downloadcoalpit-c9b0d21826c1479ae3c977713b21ccd704b2b95a.zip
coalpit-c9b0d21826c1479ae3c977713b21ccd704b2b95a.tar.gz
coalpit-c9b0d21826c1479ae3c977713b21ccd704b2b95a.tar.bz2
Omit constructor names, unless those are in sums
-rw-r--r--Coalpit.hs47
-rw-r--r--Example.hs12
2 files changed, 47 insertions, 12 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index ab7edff..4d3bdd0 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -47,12 +47,41 @@ instance (GArgParser a, GArgParser b) => GArgParser (a :*: b) where
instance (GToArgs a, GToArgs b) => GToArgs (a :*: b) where
gToArgs (a :*: b) = gToArgs a ++ gToArgs b
-instance (GArgParser a, GArgParser b) => GArgParser (a :+: b) where
- gArgParser = L1 <$> gArgParser <|> R1 <$> gArgParser
-
-instance (GToArgs a, GToArgs b) => GToArgs (a :+: b) where
- gToArgs c@(L1 x) = gToArgs x
- gToArgs c@(R1 x) = gToArgs x
+instance (Constructor c1, GArgParser f1, GArgParser (f :+: g)) =>
+ GArgParser ((f :+: g) :+: C1 c1 f1) where
+ gArgParser =
+ L1 <$> gArgParser
+ <|>
+ R1 <$> (string (conName (undefined :: C1 c1 f a)) *> space *> gArgParser)
+
+instance (Constructor c1, GArgParser f1, GArgParser (f :+: g)) =>
+ GArgParser (C1 c1 f1 :+: (f :+: g)) where
+ gArgParser =
+ L1 <$> (string (conName (undefined :: C1 c1 f a)) *> space *> gArgParser)
+ <|>
+ R1 <$> gArgParser
+
+instance (Constructor c1, Constructor c2, GArgParser f1, GArgParser f2) =>
+ GArgParser (C1 c1 f1 :+: C1 c2 f2) where
+ gArgParser =
+ L1 <$> (string (conName (undefined :: C1 c1 f a)) *> space *> gArgParser)
+ <|>
+ R1 <$> (string (conName (undefined :: C1 c2 f a)) *> space *> gArgParser)
+
+instance (Constructor c1, GToArgs f1, GToArgs (f :+: g)) =>
+ GToArgs ((f :+: g) :+: C1 c1 f1) where
+ gToArgs (L1 x) = gToArgs x
+ gToArgs (R1 x) = conName x : gToArgs x
+
+instance (Constructor c1, GToArgs f1, GToArgs (f :+: g)) =>
+ GToArgs (C1 c1 f1 :+: (f :+: g)) where
+ gToArgs (L1 x) = conName x : gToArgs x
+ gToArgs (R1 x) = gToArgs x
+
+instance (Constructor c1, Constructor c2, GToArgs f1, GToArgs f2) =>
+ GToArgs (C1 c1 f1 :+: C1 c2 f2) where
+ gToArgs (L1 x) = conName x : gToArgs x
+ gToArgs (R1 x) = conName x : gToArgs x
instance {-#OVERLAPPING#-}
(ArgParser a, Selector c) => GArgParser (S1 c (Rec0 (Maybe a))) where
@@ -81,13 +110,13 @@ instance {-#OVERLAPPING#-}
instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
gToArgs s@(M1 x) = case selName s of
"" -> gToArgs x
- name -> ("--" ++ selName s) : gToArgs x
+ name -> ("--" ++ name) : gToArgs x
instance (GArgParser a, Constructor c) => GArgParser (C1 c a) where
- gArgParser = string (conName (undefined :: C1 c a f)) *> space *> (M1 <$> gArgParser)
+ gArgParser = M1 <$> gArgParser
instance (GToArgs a, Constructor c) => GToArgs (C1 c a) where
- gToArgs c@(M1 x) = conName c : gToArgs x
+ gToArgs c@(M1 x) = gToArgs x
instance (GArgParser a, Datatype c) => GArgParser (D1 c a) where
diff --git a/Example.hs b/Example.hs
index a9f50aa..0319bcd 100644
--- a/Example.hs
+++ b/Example.hs
@@ -17,13 +17,19 @@ data Foo = Bar Int
| Qux (Maybe Int) (Maybe Int) RecTest (Maybe Double)
deriving (Generic, Show)
-instance ToArgs Foo
instance ArgParser Foo
+instance ToArgs Foo
+
+data Wrap = Wrap { foo :: Maybe Foo, num :: Maybe Int }
+ deriving (Generic, Show)
+
+instance ArgParser Wrap
+instance ToArgs Wrap
main :: IO ()
main = do
- let val = Qux Nothing (Just 1) (RecTest Nothing (Just 2.3) Nothing) Nothing
+ let val = Wrap (Just $ Qux Nothing (Just 1) (RecTest Nothing (Just 2.3) Nothing) Nothing) (Just 1)
a = args val
print val
putStrLn a
- print $ parse (argParser :: Parser Foo) "test" a
+ print $ parse (argParser :: Parser Wrap) "test" a