Parse lists of strings, not just strings

Because arguments are lists of strings.

2 files changed, 54 insertions, 24 deletions

diff --git a/Coalpit.hs b/Coalpit.hs
index c89c6e5..bc5436a 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -13,11 +14,39 @@ import Text.Megaparsec
 import Text.Megaparsec.Char
 import Data.Maybe
 import Data.Char
-
-type Parser = Parsec String String
-
-args :: ToArgs a => Modifiers -> a -> String
-args m = intercalate " " . toArgs m
+import Data.Proxy
+import Data.Semigroup
+
+
+advance :: Pos -> SourcePos -> t -> SourcePos
+advance width (SourcePos n l c) t = SourcePos n l (c <> pos1)
+
+instance Stream [String] where
+  type Token [String] = String
+  type Tokens [String] = [String]
+  tokenToChunk Proxy = pure
+  tokensToChunk Proxy = id
+  chunkToTokens Proxy = id
+  chunkLength Proxy = length
+  chunkEmpty Proxy = null
+  advance1 Proxy = advance
+  advanceN Proxy w = foldl' (advance w)
+  take1_ [] = Nothing
+  take1_ (t:ts) = Just (t, ts)
+  takeN_ n s
+    | n <= 0    = Just ([], s)
+    | null s    = Nothing
+    | otherwise = Just (splitAt n s)
+  takeWhile_ = span
+
+type Parser = Parsec String [String]
+
+pS :: Parsec String String a -> Parsec String [String] a
+pS p = try $ do
+  x <- token Right Nothing
+  case parse p "argument" x of
+    Left e -> fail $ show e
+    Right x -> pure x
 
 
 data Modifiers = Modifiers { conNameMod :: String -> String
@@ -57,7 +86,7 @@ instance GToArgs U1 where
 -- Products
 
 instance (GArgParser a, GArgParser b) => GArgParser (a :*: b) where
-  gArgParser m = (:*:) <$> gArgParser m <* space <*> gArgParser m
+  gArgParser m = (:*:) <$> gArgParser m <*> gArgParser m
 
 instance (GToArgs a, GToArgs b) => GToArgs (a :*: b) where
   gToArgs m (a :*: b) = gToArgs m a ++ gToArgs m b
@@ -70,25 +99,25 @@ instance (Constructor c1, GArgParser f1, GArgParser (f :+: g)) =>
   gArgParser m =
     L1 <$> gArgParser m
     <|>
-    R1 <$> (string (conNameMod m $ conName (undefined :: C1 c1 f a))
-            *> space *> gArgParser m)
+    R1 <$> (pS (string (conNameMod m $ conName (undefined :: C1 c1 f a)))
+            *> gArgParser m)
 
 instance (Constructor c1, GArgParser f1, GArgParser (f :+: g)) =>
   GArgParser (C1 c1 f1 :+: (f :+: g)) where
   gArgParser m =
-    L1 <$> (string (conNameMod m $ conName (undefined :: C1 c1 f a))
-            *> space *> gArgParser m)
+    L1 <$> (pS (string (conNameMod m $ conName (undefined :: C1 c1 f a)))
+            *> gArgParser m)
     <|>
     R1 <$> gArgParser m
 
 instance (Constructor c1, Constructor c2, GArgParser f1, GArgParser f2) =>
   GArgParser (C1 c1 f1 :+: C1 c2 f2) where
   gArgParser m =
-    L1 <$> (string (conNameMod m $ conName (undefined :: C1 c1 f a))
-            *> space *> gArgParser m)
+    L1 <$> (pS (string (conNameMod m $ conName (undefined :: C1 c1 f a)))
+            *> gArgParser m)
     <|>
-    R1 <$> (string (conNameMod m $ conName (undefined :: C1 c2 f a))
-            *> space *> gArgParser m)
+    R1 <$> (pS (string (conNameMod m $ conName (undefined :: C1 c2 f a)))
+            *> gArgParser m)
 
 instance (Constructor c1, GToArgs f1, GToArgs (f :+: g)) =>
   GToArgs ((f :+: g) :+: C1 c1 f1) where
@@ -112,7 +141,7 @@ instance (GArgParser a, Selector c) => GArgParser (S1 c a) where
   gArgParser m = M1 <$> do
     let sname = case selName (undefined :: S1 c a f) of
           "" -> pure ()
-          name -> string (selNameMod m name) *> space
+          name -> pS (string (selNameMod m name) >> pure ())
     sname *> gArgParser m
 
 instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
@@ -129,7 +158,7 @@ instance {-#OVERLAPPING#-}
     case selName (undefined :: S1 c (Rec0 (Maybe a)) f) of
       "" -> M1 <$> gArgParser m
       name -> do
-        x <- optional $ string (selNameMod m name) *> space *> argParser m
+        x <- optional $ (pS (string (selNameMod m name))) *> argParser m
         pure $ M1 $ K1 x
 
 instance {-#OVERLAPPING#-}
@@ -170,19 +199,19 @@ instance (ToArgs a) => GToArgs (K1 i a) where
 -- Basic types
 
 instance ArgParser Int where
-  argParser _ = read <$> some digitChar
+  argParser _ = pS $ read <$> some digitChar
 
 instance ToArgs Int where
   toArgs _ i = [show i]
 
 instance ArgParser String where
-  argParser _ = char '"' *> manyTill anyChar (char '"')
+  argParser _ = pS $ many anyChar
 
 instance ToArgs String where
-  toArgs _ i = [show i]
+  toArgs _ i = [i]
 
 instance ArgParser Double where
-  argParser _ = read <$> some (digitChar <|> char '.')
+  argParser _ = pS $ read <$> some (digitChar <|> char '.')
 
 instance ToArgs Double where
   toArgs _ i = [show i]
diff --git a/Example.hs b/Example.hs
index 6454fc7..fca8165 100644
--- a/Example.hs
+++ b/Example.hs
@@ -16,7 +16,7 @@ instance ToArgs RecTest
 
 data Foo = Bar Int
          | Baz Int
-         | Qux (Maybe Int) (Maybe Int) RecTest (Maybe Double)
+         | Qux (Maybe Int) (Maybe String) RecTest (Maybe Double)
   deriving (Generic, Show)
 
 instance ArgParser Foo
@@ -30,8 +30,9 @@ 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 defMod val
+  let val = Wrap (Just $ Qux Nothing (Just "foo bar")
+                  (RecTest Nothing (Just 2.3) Nothing) Nothing) (Just 1)
+      a = toArgs defMod val
   print val
-  putStrLn a
+  print a
   print $ parse (argParser defMod :: Parser Wrap) "test" a