From d7239b31954abe0ea67358fe4932f4db8bde5153 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Sun, 3 Dec 2017 09:00:55 +0300
Subject: Add argument name modifiers

---
 Coalpit.hs | 159 +++++++++++++++++++++++++++++++++++++------------------------
 Example.hs |   8 ++--
 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
-- 
cgit v1.2.3