From c84dbc16bbf683661e8323c68326ee04c8daf2fc Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Sat, 2 Dec 2017 06:49:58 +0300
Subject: Use GHC.Generics instead of TH

It's considerably cleaner and simpler with GHC.Generics.

Megaparsec is also used now.
---
 Coalpit.hs    | 178 ++++++++++++++++++++++++++++++++--------------------------
 Example.hs    |  34 +++++------
 README.md     |  40 ++-----------
 coalpit.cabal |   4 +-
 4 files changed, 124 insertions(+), 132 deletions(-)

diff --git a/Coalpit.hs b/Coalpit.hs
index f36f581..c1d6380 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -1,88 +1,106 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Coalpit where
 
-import Language.Haskell.TH
-import Data.Char
 import Data.List
+import GHC.Generics
+import Text.Megaparsec
+import Text.Megaparsec.Char
 
+type Parser = Parsec String String
 
-class Args a where
+args :: ToArgs a => a -> String
+args = intercalate " " . toArgs
+
+class ArgParser a where
+  argParser :: Parser a
+  default argParser :: (Generic a, GArgParser (Rep a)) => Parser a
+  argParser = to <$> gArgParser
+
+class GArgParser f where
+  gArgParser :: Parser (f a)
+
+class ToArgs a where
   toArgs :: a -> [String]
-  fromArgs :: [String] -> (a, [String])
-
-instance {-#OVERLAPPING#-} Args String where
-  toArgs = pure . show
-  fromArgs (x:xs) = (read x, xs)
-
-instance Args Int where
-  toArgs = pure . show
-  fromArgs (x:xs) = (read x, xs)
-
-instance Args Bool where
-  toArgs True = ["t"]
-  toArgs False = ["f"]
-  fromArgs ("t":xs) = (True, xs)
-  fromArgs ("f":xs) = (False, xs)
-
-instance Args a => Args (Maybe a) where
-  toArgs Nothing = ["n"]
-  toArgs (Just x) = "j" : toArgs x
-  fromArgs ("n":xs) = (Nothing, xs)
-  fromArgs ("j":xs) = let (y, ys) = fromArgs xs in (Just y, ys)
-
-instance Args a => Args [a] where
-  toArgs = pure . intercalate "," . concatMap toArgs
-  fromArgs (arg:args) = (map (fst . fromArgs . pure) $ splitOn ',' arg, args)
-
-splitOn :: Eq a => a -> [a] -> [[a]]
-splitOn sep l = case break (== sep) l of
-  (x, []) -> [x]
-  (x, _:xs) -> x : splitOn sep xs
-
-printCon :: Name -> String
-printCon = map toLower . reverse . takeWhile (/= '.') . reverse . show
-
-printClause :: Con -> Q Clause
-printClause (NormalC cn bts) = do
-  let ts = map snd bts
-      vars = (map (mkName . ("x_" ++) . show) [1..length ts])
-      args = map (\v -> AppE (VarE 'toArgs) (VarE v)) vars
-  pure $ Clause [ConP cn (map VarP vars)]
-    (NormalB (AppE (VarE 'concat) $ ListE
-               (ListE [LitE (StringL $ printCon cn)] : args)))
-    []
-
-parseClause :: Con -> Q Clause
-parseClause (NormalC cn bts) = do
-  let ts = map snd bts
-      vars = map (mkName . ("x_" ++) . show) [1..length ts]
-      vals = map (\x -> mkName (show x ++ "_val")) vars
-      fin = (TupE [foldl AppE (ConE cn) (map VarE vals)
-                   , VarE (mkName $ (if length vars > 0
-                                     then show (last vars)
-                                     else "xs") ++ "_rest")
-                   ])
-  pure $ Clause [InfixP (LitP (StringL $ printCon cn))
-                 (mkName ":")
-                 (VarP (mkName "xs_rest"))]
-    (NormalB $ foldr parseArg fin (zip (mkName "xs" : vars) vars))
-    []
-  where
-    parseArg :: (Name, Name) -> Exp -> Exp
-    parseArg (np, nc) e = LetE
-      [ValD (TupP [VarP (mkName (show nc ++ "_val")),
-                    VarP (mkName (show nc ++ "_rest"))])
-        (NormalB $ AppE (VarE 'fromArgs) (VarE (mkName (show np ++ "_rest"))))
-        []]
-      e
-
-deriveArgs :: Name -> Q [Dec]
-deriveArgs ty = do
-  let var = mkName "x"
-  (TyConI d@(DataD _ nm tyVars mk cs _)) <- reify ty
-  to <- mapM printClause cs
-  from <- mapM parseClause cs
-  pure [InstanceD Nothing [] (AppT (ConT ''Args) (ConT ty))
-        [FunD 'toArgs to, FunD 'fromArgs from]]
+  default toArgs :: (Generic a, GToArgs (Rep a)) => a -> [String]
+  toArgs a = gToArgs (from a)
+
+class GToArgs f where
+  gToArgs :: f a -> [String]
+
+
+instance GArgParser U1 where
+  gArgParser = pure U1
+
+instance GToArgs U1 where
+  gToArgs U1 = []
+
+instance (GArgParser a, GArgParser b) => GArgParser (a :*: b) where
+  gArgParser = (:*:) <$> gArgParser <* space <*> gArgParser
+
+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 (GArgParser a, Selector c) => GArgParser (S1 c a) where
+  gArgParser = M1 <$> do
+    let sname = case selName (undefined :: S1 c a f) of
+          "" -> pure ()
+          name -> string ("--" ++ name) *> space
+    sname *> gArgParser
+
+-- record selectors
+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
+
+instance (GArgParser a, Constructor c) => GArgParser (C1 c a) where
+  gArgParser = string (conName (undefined :: C1 c a f)) *> space *> (M1 <$> gArgParser)
+
+instance (GToArgs a, Constructor c) => GToArgs (C1 c a) where
+  gToArgs c@(M1 x) = conName c : gToArgs x
+
+
+instance (GArgParser a, Datatype c) => GArgParser (D1 c a) where
+  gArgParser = M1 <$> gArgParser
+
+instance (GToArgs a, Datatype c) => GToArgs (D1 c a) where
+  gToArgs d@(M1 x) = gToArgs x
+
+instance (ArgParser a) => GArgParser (K1 i a) where
+  gArgParser = K1 <$> argParser
+
+instance (ToArgs a) => GToArgs (K1 i a) where
+  gToArgs (K1 x) = toArgs x
+
+
+instance ArgParser Int where
+  argParser = read <$> some digitChar
+
+instance ToArgs Int where
+  toArgs i = [show i]
+
+instance ArgParser String where
+  argParser = char '"' *> manyTill anyChar (char '"')
+
+instance ToArgs String where
+  toArgs i = [show i]
+
+instance ArgParser Double where
+  argParser = read <$> some (digitChar <|> char '.')
+
+instance ToArgs Double where
+  toArgs i = [show i]
+
diff --git a/Example.hs b/Example.hs
index 20cae00..725f8cc 100644
--- a/Example.hs
+++ b/Example.hs
@@ -1,27 +1,29 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Main where
 
+import GHC.Generics
+import Text.Megaparsec
 import Coalpit
-import Language.Haskell.TH
-import Data.List
 
-data Y = Foo Bool Int
-       | Bar Int
-       | Baz
-  deriving (Show)
+data RecTest = RecTest { a :: Int, b :: Double }
+             deriving (Generic, Show)
 
-data X = X String (Maybe Int) (Maybe [Int]) Y Y String
-  deriving (Show)
+instance ArgParser RecTest
+instance ToArgs RecTest
 
-$(deriveArgs ''Y)
-$(deriveArgs ''X)
+data Foo = Bar Int
+         | Baz Int
+         | Qux RecTest
+  deriving (Generic, Show)
+
+instance ToArgs Foo
+instance ArgParser Foo
 
 main :: IO ()
 main = do
-  let val = X "test" Nothing (Just [1,2,3]) (Foo True 1) Baz "end"
-      args = toArgs val
+  let val = Qux (RecTest 1 2.3)
+      a = args val
   print val
-  putStrLn $ intercalate " " args
-  print (fromArgs args :: (X, [String]))
-  print (fromArgs (args ++ ["additional", "args"]) :: (X, [String]))
+  putStrLn a
+  print $ parse (argParser :: Parser Foo) "test" a
diff --git a/README.md b/README.md
index 63db06d..f31d8c5 100644
--- a/README.md
+++ b/README.md
@@ -5,7 +5,11 @@ interfaces. They are like command-line user interfaces, but for
 programs.
 
 Given a type, it derives instances to print and parse it as
-command-line arguments.
+command-line arguments. The resulting serialization wouldn't be as
+nice as that of
+e.g.
+[optparse-generic](https://hackage.haskell.org/package/optparse-generic),
+but the aim here is to handle arbitrary types.
 
 The goal is to
 faciliate
@@ -16,36 +20,4 @@ architectures. Described in more detail in
 the
 [command-line program interface](https://defanor.uberspace.net/notes/command-line-program-interface.html) note.
 
-Not production-ready yet, merely a prototype.
-
-
-## Example
-
-There is an example in `Example.hs`, but here are some bits:
-
-```haskell
-data Y = Foo Bool Int
-       | Bar Int
-       | Baz
-data X = X String (Maybe Int) (Maybe [Int]) Y Y String
-$(deriveArgs ''Y)
-$(deriveArgs ''X)
-```
-
-`toArgs` serializes data into arguments, and `fromArgs` deserializes
-it: `X "test" Nothing (Just [1,2,3]) (Foo True 1) Baz "end"` ↔ `x
-"test" n j 1,2,3 foo t 1 baz "end"`.
-
-
-## TODO
-
-What it currently lacks, but what should be done, roughly in that
-order:
-
-* Proper parsing: use optparse-applicative, Parsec, or a custom
-  parser, but something with error handling and more flexible.
-* Named arguments (via records), not just positional ones.
-* Optional arguments: once the named ones will be there, `Maybe a`
-  could be handled nicer.
-* Help messages.
-* Documentation.
+Far from production-ready yet, merely a prototype.
diff --git a/coalpit.cabal b/coalpit.cabal
index 4625ecf..31e2831 100644
--- a/coalpit.cabal
+++ b/coalpit.cabal
@@ -20,12 +20,12 @@ executable coalpit-example
   -- other-modules:       
   other-extensions:    TemplateHaskell
   build-depends:       base >=4.9 && <4.10
-                     , template-haskell >=2.11 && <2.12
+                     , megaparsec >= 6.2.0
   default-language:    Haskell2010
 
 library
   exposed-modules:     Coalpit
   other-extensions:    TemplateHaskell, FlexibleInstances
   build-depends:       base >=4.9 && <4.10
-                     , template-haskell >=2.11 && <2.12
+                     , megaparsec >= 6.2.0
   default-language:    Haskell2010
-- 
cgit v1.2.3