fix string input

src/Web/Cloud.hs

@@ -2,7 +2,7 @@ module Web.Cloud where
 
 import Data.List
 import Data.IORef
-import Data.ByteString.Lazy.Char8 (pack, unpack)
+import Data.ByteString.Lazy.Char8 (unpack)
 import System.Environment
 import Options.Applicative
 import Options.Applicative.Types
@@ -15,11 +15,12 @@ import System.Exit
 execParserWebCloud :: ParserInfo a -> IO a
 execParserWebCloud pinfo = do
   ref <- newIORef Nothing
-  title <- (\x -> "<title>" ++ x ++ "</title>") `fmap` getProgName
+  name <- getProgName
+  let title = "<title>" ++ name ++ "</title>"
   runCGI . handleErrors $ do
     setHeader "Content-Type" "text/html; charset=utf-8" 
-    clouds <- cgiGet (execParserPure (prefs idm) pinfo . getCloud . cgiInputs)
-    val <- mkWebCloud clouds
+    clouds <- cgiGet (execParserPure (prefs idm) pinfo . getCloud (infoParser pinfo) . cgiInputs)
+    val <- mkWebCloud name clouds
     case val of
       Left e -> do
         output $ title
@@ -35,19 +36,33 @@ execParserWebCloud pinfo = do
     Just v -> return v
     Nothing -> exitWith ExitSuccess -- it's ok to error! :)
 
--- getCloud :: [(String, Input)]
-getCloud =
-  flip (>>=) $ \(k, v) ->
-    if unpack (inputValue v) == ""
-      then []
-      else if unpack (inputValue v) == "on"
-        then ["--" ++ k]
-        else ["--" ++ k, show (inputValue v)]
+getCloud :: Parser a -> [(String, Input)] -> [String]
+getCloud p =
+  let o = opts p
+  in (=<<) $ \(k, v) ->
+    case unpack (inputValue v) of
+      ""   -> []
+      v' -> case (lookup k o, v') of
+        (Just Flag, "on") -> ["--" ++ k]
+        _ -> ["--" ++ k, v']
 
-mkWebCloud :: Monad m => ParserResult a -> m (Either String a)
-mkWebCloud (Success a) = return (Right a)
-mkWebCloud (Failure failure) = return (Left (fst (renderFailure failure "cloud")))
-mkWebCloud (CompletionInvoked _) = return (Left "not web")
+data OptType = Opt | Flag
+
+opts :: Parser a -> [(String, OptType)]
+opts (NilP _) = []
+opts (OptP opt) =
+  case optMain opt of
+    (OptReader names _ _) -> [(getName names, Opt)]
+    (FlagReader names _) -> [(getName names, Flag)]
+    _ -> [] -- TODO
+opts (MultP pf pa) = opts pf ++ opts pa
+opts (AltP pa pb) = opts pa ++ opts pb
+opts (BindP px pf) = opts px -- TODO: bind... ++ opts pf
+
+mkWebCloud :: Monad m => String -> ParserResult a -> m (Either String a)
+mkWebCloud _ (Success a) = return (Right a)
+mkWebCloud name (Failure failure) = return (Left (fst (renderFailure failure name)))
+mkWebCloud _ (CompletionInvoked _) = return (Left "not web")
 
 form :: Parser a -> String
 form (NilP _) = ""
@@ -65,6 +80,7 @@ formatOpt (OptProperties vis halp metavar def) (ArgReader _) =
 formatOpt (OptProperties vis halp metavar def) (CmdReader cmd _) =
   "TODO"
 
+fmt :: Show a => String -> Chunk a -> [OptName] -> Bool -> String
 fmt metavar halp names isFlag =
      "<p>"
   ++ "<strong>--"
@@ -73,6 +89,7 @@ fmt metavar halp names isFlag =
   ++ maybe "" show (unChunk halp)
   ++ "<br/><input type=\"" ++ (if isFlag then "checkbox" else "text") ++ "\" name=\"" ++ getName names ++ "\" placeholder=\"" ++ metavar ++ "\"></input><br/></p>"
 
+getName :: [OptName] -> String
 getName = head . sortBy (\x y -> length y `compare` length x) . map n
    where
      n (OptShort c) = return c