summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-03 09:00:55 +0300
committerdefanor <defanor@uberspace.net>2017-12-03 09:06:53 +0300
commitd7239b31954abe0ea67358fe4932f4db8bde5153 (patch)
tree4f3d4563e8c764eabc821c604027147692bfe5e9
parentc9b0d21826c1479ae3c977713b21ccd704b2b95a (diff)
downloadcoalpit-d7239b31954abe0ea67358fe4932f4db8bde5153.zip
coalpit-d7239b31954abe0ea67358fe4932f4db8bde5153.tar.gz
coalpit-d7239b31954abe0ea67358fe4932f4db8bde5153.tar.bz2
Add argument name modifiers
-rw-r--r--Coalpit.hs159
-rw-r--r--Example.hs8
2 files changed, 103 insertions, 64 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index 4d3bdd0..c89c6e5 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -12,143 +12,180 @@ import GHC.Generics
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Maybe
+import Data.Char
type Parser = Parsec String String
-args :: ToArgs a => a -> String
-args = intercalate " " . toArgs
+args :: ToArgs a => Modifiers -> a -> String
+args m = intercalate " " . toArgs m
+
+
+data Modifiers = Modifiers { conNameMod :: String -> String
+ , selNameMod :: String -> String }
+
+defMod :: Modifiers
+defMod = Modifiers (map toLower) (("--" ++) . map toLower)
+
+-- Core classes
class ArgParser a where
- argParser :: Parser a
- default argParser :: (Generic a, GArgParser (Rep a)) => Parser a
- argParser = to <$> gArgParser
+ argParser :: Modifiers -> Parser a
+ default argParser :: (Generic a, GArgParser (Rep a)) => Modifiers -> Parser a
+ argParser m = to <$> gArgParser m
class GArgParser f where
- gArgParser :: Parser (f a)
+ gArgParser :: Modifiers -> Parser (f a)
class ToArgs a where
- toArgs :: a -> [String]
- default toArgs :: (Generic a, GToArgs (Rep a)) => a -> [String]
- toArgs a = gToArgs (from a)
+ toArgs :: Modifiers -> a -> [String]
+ default toArgs :: (Generic a, GToArgs (Rep a)) => Modifiers -> a -> [String]
+ toArgs m a = gToArgs m (from a)
class GToArgs f where
- gToArgs :: f a -> [String]
+ gToArgs :: Modifiers -> f a -> [String]
+-- Units
+
instance GArgParser U1 where
- gArgParser = pure U1
+ gArgParser _ = pure U1
instance GToArgs U1 where
- gToArgs U1 = []
+ gToArgs _ U1 = []
+
+
+-- Products
instance (GArgParser a, GArgParser b) => GArgParser (a :*: b) where
- gArgParser = (:*:) <$> gArgParser <* space <*> gArgParser
+ gArgParser m = (:*:) <$> gArgParser m <* space <*> gArgParser m
instance (GToArgs a, GToArgs b) => GToArgs (a :*: b) where
- gToArgs (a :*: b) = gToArgs a ++ gToArgs b
+ gToArgs m (a :*: b) = gToArgs m a ++ gToArgs m b
+
+
+-- Sums
instance (Constructor c1, GArgParser f1, GArgParser (f :+: g)) =>
GArgParser ((f :+: g) :+: C1 c1 f1) where
- gArgParser =
- L1 <$> gArgParser
+ gArgParser m =
+ L1 <$> gArgParser m
<|>
- R1 <$> (string (conName (undefined :: C1 c1 f a)) *> space *> gArgParser)
+ R1 <$> (string (conNameMod m $ conName (undefined :: C1 c1 f a))
+ *> space *> gArgParser m)
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)
+ gArgParser m =
+ L1 <$> (string (conNameMod m $ conName (undefined :: C1 c1 f a))
+ *> space *> gArgParser m)
<|>
- R1 <$> gArgParser
+ R1 <$> gArgParser m
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)
+ gArgParser m =
+ L1 <$> (string (conNameMod m $ conName (undefined :: C1 c1 f a))
+ *> space *> gArgParser m)
<|>
- R1 <$> (string (conName (undefined :: C1 c2 f a)) *> space *> gArgParser)
+ R1 <$> (string (conNameMod m $ conName (undefined :: C1 c2 f a))
+ *> space *> gArgParser m)
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
+ gToArgs m (L1 x) = gToArgs m x
+ gToArgs m (R1 x) = conNameMod m (conName x) : gToArgs m 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
+ gToArgs m (L1 x) = conNameMod m (conName x) : gToArgs m x
+ gToArgs m (R1 x) = gToArgs m 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
+ gToArgs m (L1 x) = conNameMod m (conName x) : gToArgs m x
+ gToArgs m (R1 x) = conNameMod m (conName x) : gToArgs m 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
+
+-- Record Selectors
instance (GArgParser a, Selector c) => GArgParser (S1 c a) where
- gArgParser = M1 <$> do
+ gArgParser m = M1 <$> do
let sname = case selName (undefined :: S1 c a f) of
"" -> pure ()
- name -> string ("--" ++ name) *> space
- sname *> gArgParser
+ name -> string (selNameMod m name) *> space
+ sname *> gArgParser m
+
+instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
+ gToArgs m s@(M1 x) = case selName s of
+ "" -> gToArgs m x
+ name -> selNameMod m name : gToArgs m x
+
+
+-- Optional arguments
+
+instance {-#OVERLAPPING#-}
+ (ArgParser a, Selector c) => GArgParser (S1 c (Rec0 (Maybe a))) where
+ gArgParser m = do
+ case selName (undefined :: S1 c (Rec0 (Maybe a)) f) of
+ "" -> M1 <$> gArgParser m
+ name -> do
+ x <- optional $ string (selNameMod m name) *> space *> argParser m
+ pure $ M1 $ K1 x
--- 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'
+ gToArgs m s@(M1 (K1 x)) = case (selName s, x) of
+ ("", _) -> toArgs m x
+ (_, Nothing) -> []
+ (name, Just x') -> selNameMod m name : toArgs m x'
-instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
- gToArgs s@(M1 x) = case selName s of
- "" -> gToArgs x
- name -> ("--" ++ name) : gToArgs x
+
+-- Constructors
instance (GArgParser a, Constructor c) => GArgParser (C1 c a) where
- gArgParser = M1 <$> gArgParser
+ gArgParser m = M1 <$> gArgParser m
instance (GToArgs a, Constructor c) => GToArgs (C1 c a) where
- gToArgs c@(M1 x) = gToArgs x
+ gToArgs m c@(M1 x) = gToArgs m x
+
+-- Data types
instance (GArgParser a, Datatype c) => GArgParser (D1 c a) where
- gArgParser = M1 <$> gArgParser
+ gArgParser m = M1 <$> gArgParser m
instance (GToArgs a, Datatype c) => GToArgs (D1 c a) where
- gToArgs d@(M1 x) = gToArgs x
+ gToArgs m d@(M1 x) = gToArgs m x
+
+
+-- Constraints and such
instance (ArgParser a) => GArgParser (K1 i a) where
- gArgParser = K1 <$> argParser
+ gArgParser m = K1 <$> argParser m
instance (ToArgs a) => GToArgs (K1 i a) where
- gToArgs (K1 x) = toArgs x
+ gToArgs m (K1 x) = toArgs m x
+
+-- Basic types
instance ArgParser Int where
- argParser = read <$> some digitChar
+ argParser _ = read <$> some digitChar
instance ToArgs Int where
- toArgs i = [show i]
+ toArgs _ i = [show i]
instance ArgParser String where
- argParser = char '"' *> manyTill anyChar (char '"')
+ argParser _ = char '"' *> manyTill anyChar (char '"')
instance ToArgs String where
- toArgs i = [show i]
+ toArgs _ i = [show i]
instance ArgParser Double where
- argParser = read <$> some (digitChar <|> char '.')
+ argParser _ = read <$> some (digitChar <|> char '.')
instance ToArgs Double where
- toArgs i = [show i]
+ 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 0319bcd..6454fc7 100644
--- a/Example.hs
+++ b/Example.hs
@@ -6,7 +6,9 @@ import GHC.Generics
import Text.Megaparsec
import Coalpit
-data RecTest = RecTest { a :: Maybe Int, b :: Maybe Double, c :: Maybe Int }
+data RecTest = RecTest { a :: Maybe Int
+ , b :: Maybe Double
+ , c :: Maybe Int }
deriving (Generic, Show)
instance ArgParser RecTest
@@ -29,7 +31,7 @@ instance ToArgs Wrap
main :: IO ()
main = do
let val = Wrap (Just $ Qux Nothing (Just 1) (RecTest Nothing (Just 2.3) Nothing) Nothing) (Just 1)
- a = args val
+ a = args defMod val
print val
putStrLn a
- print $ parse (argParser :: Parser Wrap) "test" a
+ print $ parse (argParser defMod :: Parser Wrap) "test" a