diff --git a/src/Web/Cloud.hs b/src/Web/Cloud.hs
index 3ef2499..4a4fde3 100644
--- a/src/Web/Cloud.hs
+++ b/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 -> "
" ++ x ++ "") `fmap` getProgName
+ name <- getProgName
+ let title = "" ++ name ++ ""
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 =
""
++ "--"
@@ -73,6 +89,7 @@ fmt metavar halp names isFlag =
++ maybe "" show (unChunk halp)
++ "
"
+getName :: [OptName] -> String
getName = head . sortBy (\x y -> length y `compare` length x) . map n
where
n (OptShort c) = return c