diff options
author | defanor <defanor@uberspace.net> | 2017-12-03 08:12:35 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2017-12-03 08:12:35 +0300 |
commit | c9b0d21826c1479ae3c977713b21ccd704b2b95a (patch) | |
tree | d57924c62675d313ad20c8286fda382051df79d7 /Coalpit.hs | |
parent | ecc1d48c01ef5633d6229dc9009a899141b2eec7 (diff) |
Omit constructor names, unless those are in sums
Diffstat (limited to 'Coalpit.hs')
-rw-r--r-- | Coalpit.hs | 47 |
1 files changed, 38 insertions, 9 deletions
@@ -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 |