From 50ae4201a52cc966597aff081a9ba567ad29f62d Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Sun, 23 Nov 2014 12:53:18 +1100 Subject: [PATCH 1/4] cleanup --- src/Web/Cloud.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Web/Cloud.hs b/src/Web/Cloud.hs index 3ef2499..b8c9bd4 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 @@ -35,14 +35,13 @@ execParserWebCloud pinfo = do Just v -> return v Nothing -> exitWith ExitSuccess -- it's ok to error! :) --- getCloud :: [(String, Input)] +getCloud :: [(String, Input)] -> [String] getCloud = - flip (>>=) $ \(k, v) -> - if unpack (inputValue v) == "" - then [] - else if unpack (inputValue v) == "on" - then ["--" ++ k] - else ["--" ++ k, show (inputValue v)] + (=<<) $ \(k, v) -> + case unpack (inputValue v) of + "" -> [] + "on" -> ["--" ++ k] + _ -> ["--" ++ k, show (inputValue v)] mkWebCloud :: Monad m => ParserResult a -> m (Either String a) mkWebCloud (Success a) = return (Right a) @@ -65,6 +64,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 +73,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 From 276d8430011186729f6a1ba3e5b5f1324626d9e0 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Sun, 23 Nov 2014 12:53:55 +1100 Subject: [PATCH 2/4] fix string input --- src/Web/Cloud.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Web/Cloud.hs b/src/Web/Cloud.hs index b8c9bd4..a0a973f 100644 --- a/src/Web/Cloud.hs +++ b/src/Web/Cloud.hs @@ -41,7 +41,7 @@ getCloud = case unpack (inputValue v) of "" -> [] "on" -> ["--" ++ k] - _ -> ["--" ++ k, show (inputValue v)] + v' -> ["--" ++ k, v'] mkWebCloud :: Monad m => ParserResult a -> m (Either String a) mkWebCloud (Success a) = return (Right a) From c98841f666ab9c01a877308752a96021e607456f Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Sun, 23 Nov 2014 14:57:56 +1100 Subject: [PATCH 3/4] fix flag --- src/Web/Cloud.hs | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/src/Web/Cloud.hs b/src/Web/Cloud.hs index a0a973f..31c14db 100644 --- a/src/Web/Cloud.hs +++ b/src/Web/Cloud.hs @@ -18,7 +18,7 @@ execParserWebCloud pinfo = do title <- (\x -> "" ++ x ++ "") `fmap` getProgName runCGI . handleErrors $ do setHeader "Content-Type" "text/html; charset=utf-8" - clouds <- cgiGet (execParserPure (prefs idm) pinfo . getCloud . cgiInputs) + clouds <- cgiGet (execParserPure (prefs idm) pinfo . getCloud (infoParser pinfo) . cgiInputs) val <- mkWebCloud clouds case val of Left e -> do @@ -35,13 +35,28 @@ execParserWebCloud pinfo = do Just v -> return v Nothing -> exitWith ExitSuccess -- it's ok to error! :) -getCloud :: [(String, Input)] -> [String] -getCloud = - (=<<) $ \(k, v) -> +getCloud :: Parser a -> [(String, Input)] -> [String] +getCloud p = + let o = opts p + in (=<<) $ \(k, v) -> case unpack (inputValue v) of "" -> [] - "on" -> ["--" ++ k] - v' -> ["--" ++ k, v'] + v' -> case (lookup k o, v') of + (Just Flag, "on") -> ["--" ++ k] + _ -> ["--" ++ k, v'] + +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 => ParserResult a -> m (Either String a) mkWebCloud (Success a) = return (Right a) From 4490708edfe04e5a70f7238ee6cbd436c5717d1d Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 25 Nov 2014 10:57:30 +1100 Subject: [PATCH 4/4] display right progName --- src/Web/Cloud.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Web/Cloud.hs b/src/Web/Cloud.hs index 31c14db..4a4fde3 100644 --- a/src/Web/Cloud.hs +++ b/src/Web/Cloud.hs @@ -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 (infoParser pinfo) . cgiInputs) - val <- mkWebCloud clouds + val <- mkWebCloud name clouds case val of Left e -> do output $ title @@ -58,10 +59,10 @@ 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 => 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") +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 _) = ""