summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Coalpit.hs178
-rw-r--r--Example.hs34
-rw-r--r--README.md40
-rw-r--r--coalpit.cabal4
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