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