summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-02 16:55:09 +0300
committerdefanor <defanor@uberspace.net>2017-12-02 16:55:09 +0300
commitecc1d48c01ef5633d6229dc9009a899141b2eec7 (patch)
treee86db742b7c327bfd208510e659c6087f8984793
parentc84dbc16bbf683661e8323c68326ee04c8daf2fc (diff)
downloadcoalpit-ecc1d48c01ef5633d6229dc9009a899141b2eec7.zip
coalpit-ecc1d48c01ef5633d6229dc9009a899141b2eec7.tar.gz
coalpit-ecc1d48c01ef5633d6229dc9009a899141b2eec7.tar.bz2
Add special handling for named Maybe values
Allow to omit named options.
-rw-r--r--Coalpit.hs19
-rw-r--r--Example.hs6
2 files changed, 22 insertions, 3 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index c1d6380..ab7edff 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -11,6 +11,7 @@ import Data.List
import GHC.Generics
import Text.Megaparsec
import Text.Megaparsec.Char
+import Data.Maybe
type Parser = Parsec String String
@@ -53,6 +54,15 @@ instance (GToArgs a, GToArgs b) => GToArgs (a :+: b) where
gToArgs c@(L1 x) = gToArgs x
gToArgs c@(R1 x) = gToArgs x
+instance {-#OVERLAPPING#-}
+ (ArgParser a, Selector c) => GArgParser (S1 c (Rec0 (Maybe a))) where
+ gArgParser = do
+ case selName (undefined :: S1 c (Rec0 (Maybe a)) f) of
+ "" -> M1 <$> gArgParser
+ name -> do
+ x <- optional $ string ("--" ++ name) *> space *> argParser
+ pure $ M1 $ K1 x
+
instance (GArgParser a, Selector c) => GArgParser (S1 c a) where
gArgParser = M1 <$> do
let sname = case selName (undefined :: S1 c a f) of
@@ -61,6 +71,13 @@ instance (GArgParser a, Selector c) => GArgParser (S1 c a) where
sname *> gArgParser
-- record selectors
+instance {-#OVERLAPPING#-}
+ (ToArgs a, Selector c) => GToArgs (S1 c (Rec0 (Maybe a))) where
+ gToArgs s@(M1 (K1 x)) = case (selName s, x) of
+ ("", _) -> toArgs x
+ (_, Nothing) -> []
+ (name, Just x') -> ("--" ++ selName s) : toArgs x'
+
instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
gToArgs s@(M1 x) = case selName s of
"" -> gToArgs x
@@ -104,3 +121,5 @@ instance ArgParser Double where
instance ToArgs Double where
toArgs i = [show i]
+instance ArgParser a => ArgParser (Maybe a)
+instance ToArgs a => ToArgs (Maybe a)
diff --git a/Example.hs b/Example.hs
index 725f8cc..a9f50aa 100644
--- a/Example.hs
+++ b/Example.hs
@@ -6,7 +6,7 @@ import GHC.Generics
import Text.Megaparsec
import Coalpit
-data RecTest = RecTest { a :: Int, b :: Double }
+data RecTest = RecTest { a :: Maybe Int, b :: Maybe Double, c :: Maybe Int }
deriving (Generic, Show)
instance ArgParser RecTest
@@ -14,7 +14,7 @@ instance ToArgs RecTest
data Foo = Bar Int
| Baz Int
- | Qux RecTest
+ | Qux (Maybe Int) (Maybe Int) RecTest (Maybe Double)
deriving (Generic, Show)
instance ToArgs Foo
@@ -22,7 +22,7 @@ instance ArgParser Foo
main :: IO ()
main = do
- let val = Qux (RecTest 1 2.3)
+ let val = Qux Nothing (Just 1) (RecTest Nothing (Just 2.3) Nothing) Nothing
a = args val
print val
putStrLn a