From e5f55fe6700b7ba4aa5b5bb9d1fffc51487519ce Mon Sep 17 00:00:00 2001 From: Konrad Merz Date: Mon, 30 Mar 2015 17:01:48 +0200 Subject: [PATCH] Fix hlinter warnings --- src/Noodle/Views/Edit.hs | 19 ++--- src/Noodle/Views/EditName.hs | 20 ++--- src/Noodle/Views/Index.hs | 13 ++- src/Noodle/Views/New.hs | 14 ++-- src/Noodle/Views/Show.hs | 56 ++++++------- src/main.hs | 157 +++++++++++++++-------------------- 6 files changed, 117 insertions(+), 162 deletions(-) diff --git a/src/Noodle/Views/Edit.hs b/src/Noodle/Views/Edit.hs index 84032c3..f8b1bed 100644 --- a/src/Noodle/Views/Edit.hs +++ b/src/Noodle/Views/Edit.hs @@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text import Data.Monoid ((<>)) -render (pollId, pollName, pollDesc) options errors = do +render (pollId, pollName, pollDesc) options errors = H.html $ do H.head $ do H.title "Noodle - The doodle" @@ -22,23 +22,20 @@ render (pollId, pollName, pollDesc) options errors = do A.name "id" H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Add" H.form ! A.method "post" ! - A.action (H.stringValue ("/options/delete")) $ do - H.table $ do - mapM_ (renderLn) options + A.action (H.stringValue "/options/delete") $ do + H.table $ mapM_ renderLn options H.input ! A.type_ "hidden" ! A.value (H.stringValue (show pollId)) ! A.name "id" H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Delete" - H.a ! A.class_ "btn" ! A.href (H.stringValue ("/polls/" ++ (show pollId))) $ + H.a ! A.class_ "btn" ! A.href (H.stringValue ("/polls/" ++ show pollId)) $ "To poll" where renderErrors error = do H.p ! A.class_ "error" $ error H.br - renderLn (id, name, desc) = do + renderLn (id, name, desc) = H.tr $ do - H.td $ do + H.td $ H.input ! A.name "option_id" ! A.value (H.stringValue (show id)) ! A.type_ "checkbox" - H.td $ do - H.b $ H.toHtml $ name - H.td $ do - H.toHtml desc + H.td $ H.b $ H.toHtml name + H.td $ H.toHtml desc diff --git a/src/Noodle/Views/EditName.hs b/src/Noodle/Views/EditName.hs index be87868..774a326 100644 --- a/src/Noodle/Views/EditName.hs +++ b/src/Noodle/Views/EditName.hs @@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text import Data.Monoid ((<>)) -render (pollId, pollName, pollDesc) errors = do +render (pollId, pollName, pollDesc) errors = H.html $ do H.head $ do H.title "Noodle - The doodle" @@ -16,22 +16,18 @@ render (pollId, pollName, pollDesc) errors = do H.h2 "Edit the poll" mapM_ renderErrors errors H.form ! A.class_ "form" ! A.method "post" ! - A.action (H.stringValue ("/polls/" ++ (show pollId) ++ "/update")) $ do + A.action (H.stringValue ("/polls/" ++ show pollId ++ "/update")) $ do H.table $ do H.tr $ do - H.td $ do - H.label "Name: " - H.td $ do - H.input ! A.name "name" ! A.value (H.stringValue pollName) + H.td $ H.label "Name: " + H.td $ H.input ! A.name "name" ! A.value (H.stringValue pollName) H.tr $ do - H.td $ do - H.label "Description: " - H.td $ do - H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ - H.toHtml pollDesc + H.td $ H.label "Description: " + H.td $ H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ + H.toHtml pollDesc H.div ! A.class_ "btns" $ do H.a ! A.class_ "btn" ! A.href ( - H.stringValue ("/polls/" ++ (show pollId))) $ "To poll" + H.stringValue ("/polls/" ++ show pollId)) $ "To poll" H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Update Poll" where renderErrors error = do H.p ! A.class_ "error" $ error diff --git a/src/Noodle/Views/Index.hs b/src/Noodle/Views/Index.hs index a6e6fd6..4243976 100644 --- a/src/Noodle/Views/Index.hs +++ b/src/Noodle/Views/Index.hs @@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text import Data.Monoid ((<>)) -render items = do +render items = H.html $ do H.head $ do H.title "Noodle - The doodle" @@ -15,10 +15,7 @@ render items = do H.body $ do H.h2 "Noodle - The doodle" H.a ! A.class_ "btn" ! A.href "/polls/new" $ "New Poll" - H.table ! A.class_ "table" $ do - mapM_ renderLn items - where renderLn i = do - H.tr $ do - H.td $ do - H.a ! A.href ("/polls/" <> (H.stringValue (show $ fst i))) $ - H.toHtml (snd i) + H.table ! A.class_ "table" $ mapM_ renderLn items + where renderLn i = H.tr $ H.td $ + H.a ! A.href ("/polls/" <> H.stringValue (show $ fst i)) $ + H.toHtml (snd i) diff --git a/src/Noodle/Views/New.hs b/src/Noodle/Views/New.hs index d15580c..d24e427 100644 --- a/src/Noodle/Views/New.hs +++ b/src/Noodle/Views/New.hs @@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text import Data.Monoid ((<>)) -render errors = do +render errors = H.html $ do H.head $ do H.title "Noodle - The doodle" @@ -18,15 +18,11 @@ render errors = do H.form ! A.class_ "form" ! A.method "post" ! A.action "/polls/" $ do H.table $ do H.tr $ do - H.td $ do - H.label "Name: " - H.td $ do - H.input ! A.name "name" + H.td $ H.label "Name: " + H.td $ H.input ! A.name "name" H.tr $ do - H.td $ do - H.label "Description: " - H.td $ do - H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ "" + H.td $ H.label "Description: " + H.td $ H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ "" H.div ! A.class_ "btns" $ do H.a ! A.class_ "btn" ! A.href "/polls" $ "Back" H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Add Poll" diff --git a/src/Noodle/Views/Show.hs b/src/Noodle/Views/Show.hs index 40b1466..1dd8458 100644 --- a/src/Noodle/Views/Show.hs +++ b/src/Noodle/Views/Show.hs @@ -8,7 +8,7 @@ import Text.Blaze.Html.Renderer.Text import Data.List (intercalate) import Data.Map as M hiding ((!)) -render (pollId, pollName, pollDesc) options voters cants errors editVoter = do +render (pollId, pollName, pollDesc) options voters cants errors editVoter = H.html $ do H.head $ do H.title "Noodle - The doodle" @@ -18,7 +18,7 @@ render (pollId, pollName, pollDesc) options voters cants errors editVoter = do mapM_ (\x-> do H.toHtml x; H.br) (lines pollDesc) H.br H.a ! A.class_ "btn" ! A.href ( - H.stringValue ("/polls/" ++ (show pollId) ++ "/edit_name")) $ "Edit" + H.stringValue ("/polls/" ++ show pollId ++ "/edit_name")) $ "Edit" mapM_ renderErrors errors H.table $ do H.tr $ do @@ -27,31 +27,29 @@ render (pollId, pollName, pollDesc) options voters cants errors editVoter = do mapM_ renderVoter $ M.keys voters mapM_ renderCants cants H.tr $ do - H.td $ "" + H.td "" mapM_ renderVoteCount options - H.tr $ do + H.tr $ H.form ! A.method "post" ! - A.action (H.stringValue ("/polls/" ++ (show pollId) ++ "/vote")) $ do - H.td $ do + A.action (H.stringValue ("/polls/" ++ show pollId ++ "/vote")) $ do + H.td $ H.input ! A.class_ "input" ! A.placeholder "Vote as" ! A.name "name" mapM_ renderCheckbox options H.td $ H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Vote" H.br H.a ! A.class_ "btn" ! A.href "/polls" $ "To overview" H.a ! A.class_ "btn" ! - A.href (H.stringValue ("/polls/" ++ (show pollId) ++ "/edit")) $ - "Edit Options" - where renderOption (id, name, desc) = do + A.href (H.stringValue ("/polls/" ++ show pollId ++ "/edit")) $ "Edit Options" + where renderOption (id, name, desc) = H.td $ do - H.b $ H.toHtml $ name + H.b $ H.toHtml name H.br H.toHtml desc - renderCheckbox (id, _, _) = do - H.td ! A.class_ "checker" $ do - H.input ! A.name "option_id" ! - A.value (H.stringValue (show id)) ! + renderCheckbox (id, _, _) = + H.td ! A.class_ "checker" $ + H.input ! A.name "option_id" ! A.value (H.stringValue (show id)) ! A.type_ "checkbox" - renderCants cant = do + renderCants cant = if cant == editVoter then renderEditVote cant else @@ -61,46 +59,44 @@ render (pollId, pollName, pollDesc) options voters cants errors editVoter = do H.td ! A.class_ "false" $ "") options H.td $ H.a ! A.class_ "btn" ! A.href (H.stringValue ( - "/polls/" ++ (show pollId) ++ "/vote/" ++ cant ++ "/edit")) $ + "/polls/" ++ show pollId ++ "/vote/" ++ cant ++ "/edit")) $ "Edit" H.td $ H.a ! A.class_ "btn" ! A.href (H.stringValue ( - "/polls/" ++ (show pollId) ++ "/vote/" ++ cant ++ "/delete")) $ + "/polls/" ++ show pollId ++ "/vote/" ++ cant ++ "/delete")) $ "Delete" - renderVoter voter = do - if (voter == editVoter) - then - renderEditVote voter + renderVoter voter = + if voter == editVoter then renderEditVote voter else H.tr $ do H.td $ H.toHtml voter mapM_ (\ (id, _, _) -> case M.lookup voter voters of - Just ids -> do if (id `elem` ids) - then H.td ! A.class_ "true" $ "✓" - else H.td ! A.class_ "false" $ "" + Just ids -> if id `elem` ids + then H.td ! A.class_ "true" $ "✓" + else H.td ! A.class_ "false" $ "" Nothing -> H.td "" ) options H.td $ H.a ! A.class_ "btn" ! A.href (H.stringValue ( - "/polls/" ++ (show pollId) ++ "/vote/" ++ voter ++ "/edit")) $ + "/polls/" ++ show pollId ++ "/vote/" ++ voter ++ "/edit")) $ "Edit" H.td $ H.a ! A.class_ "btn" ! A.href (H.stringValue ( - "/polls/" ++ (show pollId) ++ "/vote/" ++ voter ++ "/delete")) $ + "/polls/" ++ show pollId ++ "/vote/" ++ voter ++ "/delete")) $ "Delete" - renderVoteCount (id, _, _) = do + renderVoteCount (id, _, _) = H.td ! A.class_ "count" $ H.toHtml (show count) where count = M.fold(\ids acc -> if id `elem` ids then acc + 1 else acc) 0 voters renderErrors error = do H.p ! A.class_ "error" $ error H.br - renderEditVote voter = do - H.tr $ do + renderEditVote voter = + H.tr $ H.form ! A.method "post" ! A.action (H.stringValue ( - "/polls/" ++ (show pollId) ++ "/vote")) $ do + "/polls/" ++ show pollId ++ "/vote")) $ do H.td $ do H.input ! A.class_ "input" ! A.disabled "disabled" ! A.name "name-disabled" ! A.value (H.stringValue voter) diff --git a/src/main.hs b/src/main.hs index d31df1d..9aa1401 100644 --- a/src/main.hs +++ b/src/main.hs @@ -57,32 +57,26 @@ main = do initDb scottySite -scottySite = do - S.scotty 3000 $ do - S.get "/noodle.css" $ do - S.file "noodle.css" +scottySite = S.scotty 3000 $ do + S.get "/noodle.css" $ S.file "noodle.css" S.get "/polls" $ do - polls <- liftIO $ allPolls - blaze $ Noodle.Views.Index.render $ pollNames $ polls - S.get "/" $ do - S.redirect "/polls" - S.get "/polls/new" $ do - blaze $ Noodle.Views.New.render [] + polls <- liftIO allPolls + blaze $ Noodle.Views.Index.render $ pollNames polls + S.get "/" $ S.redirect "/polls" + S.get "/polls/new" $ blaze $ Noodle.Views.New.render [] S.post "/options/delete" $ do id <- S.param "id" :: S.ActionM String all_params <- S.params let choosen_opt_ids = foldl (\ acc (key, value) -> if key == "option_id" - then (T.unpack value):acc + then T.unpack value:acc else acc) [] all_params deleteOptions choosen_opt_ids S.redirect $ T.pack $ "/polls/" ++ id ++ "/edit" S.post "/polls/:id/vote" $ do - id <- S.param "id" :: S.ActionM String - name <- S.param "name" :: S.ActionM String - options <- liftIO $ getOptionsByPollId id + (id, name, options) <- getPollFromParam all_params <- S.params let choosen_opt_ids = foldl (\ acc (key, value) -> if key == "option_id" - then (T.unpack value):acc + then T.unpack value:acc else acc) [] all_params case name of "" -> showAction id ["Vote needs the name who votes."] "" @@ -107,9 +101,7 @@ scottySite = do name <- S.param "name" :: S.ActionM String showAction id [] name S.get "/polls/:id/vote/:name/delete" $ do - id <- S.param "id" :: S.ActionM String - name <- S.param "name" :: S.ActionM String - options <- liftIO $ getOptionsByPollId id + (id, name, options) <- getPollFromParam deleteVote id name (optionIds options) S.redirect $ T.pack $ "/polls/" ++ id S.post "/polls/:id/update" $ do @@ -130,7 +122,7 @@ scottySite = do "" -> blaze $ Noodle.Views.New.render [ "A Poll needs a name" ] otherwise -> do newId <- liftIO $ createPoll name desc - S.redirect $ T.pack $ "/polls/" ++ (show (getNewPollId newId)) ++ "/edit" + S.redirect $ T.pack $ "/polls/" ++ show (getNewPollId newId) ++ "/edit" S.post "/options/" $ do name <- S.param "name" :: S.ActionM String desc <- S.param "desc" :: S.ActionM String @@ -138,12 +130,19 @@ scottySite = do poll <- liftIO $ getPollById pId options <- liftIO $ getOptionsByPollId pId case name of - "" -> do blaze $ Noodle.Views.Edit.render (pollValues $ head poll) + "" -> blaze $ Noodle.Views.Edit.render (pollValues $ head poll) (optionsValues options) [ "Option needs a name" ] otherwise -> do createOption pId name desc S.redirect $ T.pack $ "/polls/" ++ pId ++ "/edit" +getPollFromParam = do + id <- S.param "id" :: S.ActionM String + name <- S.param "name" :: S.ActionM String + options <- liftIO $ getOptionsByPollId id + return (id, name, options) + + showAction id errors editVoter = do poll <- liftIO $ getPollById id options <- liftIO $ getOptionsByPollId id @@ -152,123 +151,97 @@ showAction id errors editVoter = do blaze $ Noodle.Views.Show.render (pollValues $ head poll) (optionsValues options) (getVoteNames voters) (cantNames cants) [] editVoter -initDb = do - runSqlite "noodle.db" $ do - runMigration migrateAll +initDb = runSqlite "noodle.db" $ runMigration migrateAll -createPoll name desc = do - runSqlite "noodle.db" $ do - id <- insert $ Poll name desc - return id +createPoll name desc = runSqlite "noodle.db" $ insert $ Poll name desc createCant id name opt_ids = do - mapM_ (\i -> do - runSqlite "noodle.db" $ do - deleteWhere [VoteOptionId ==. (toSqlKey i), VoteVoter ==. name] - ) opt_ids + mapM_ (\i -> runSqlite "noodle.db" $ + deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opt_ids runSqlite "noodle.db" $ do deleteWhere [CantPollId ==. pollId, CantName ==. name] insert $ Cant pollId name return () - where pollId = (toSqlKey (read id)) + where pollId = toSqlKey (read id) -updatePoll id name desc = do - runSqlite "noodle.db" $ do - replace pollId $ Poll name desc - where pollId = (toSqlKey (read id)) +updatePoll id name desc = runSqlite "noodle.db" $ replace pollId $ Poll name desc + where pollId = toSqlKey (read id) getNewPollId id = unSqlBackendKey $ unPollKey id -allPolls = do - runSqlite "noodle.db" $ do - polls <- selectList ([] :: [Filter Poll]) [LimitTo 30, Desc PollId] - return $ polls +allPolls = runSqlite "noodle.db" $ + selectList ([] :: [Filter Poll]) [LimitTo 30, Desc PollId] -getPollById id = do - runSqlite "noodle.db" $ do - selectList [PollId ==. (toSqlKey (read id))] [LimitTo 1] +getPollById id = runSqlite "noodle.db" $ + selectList [PollId ==. toSqlKey (read id)] [LimitTo 1] -pollNames = map (\i -> ((getPollId i), (pollName (entityVal i)))) +pollNames = map (\i -> (getPollId i, pollName $ entityVal i)) -cantNames c = map (\i -> (cantName (entityVal i))) c +cantNames = map $ cantName . entityVal getPollId x = unSqlBackendKey $ unPollKey $ entityKey x -pollValues i = ((getPollId i), (pollName (entityVal i)), (pollDesc (entityVal i))) +pollValues i = (getPollId i, pollName $ entityVal i, pollDesc $ entityVal i) -optionsValues = map (\o -> ((getOptionId o), - (optionName (entityVal o)), (optionDesc (entityVal o)))) +optionsValues = map (\o -> (getOptionId o, optionName $ entityVal o, + optionDesc $ entityVal o)) -optionIds opts = map (\o -> getOptionId o) opts +optionIds = map getOptionId getOptionId x = unSqlBackendKey $ unOptionKey $ entityKey x -getOptionsByPollId id = do - runSqlite "noodle.db" $ do - selectList [OptionPollId ==. (toSqlKey (read id))] [] +getOptionsByPollId id = runSqlite "noodle.db" $ + selectList [OptionPollId ==. toSqlKey (read id)] [] -getCantsByPollId id = do - runSqlite "noodle.db" $ do - selectList [CantPollId ==. (toSqlKey (read id))] [] +getCantsByPollId id = runSqlite "noodle.db" $ + selectList [CantPollId ==. toSqlKey (read id)] [] -createOption pId name desc = do - runSqlite "noodle.db" $ do - insert $ Option (toSqlKey (read pId)) name desc +createOption pId name desc = runSqlite "noodle.db" $ insert $ + Option (toSqlKey (read pId)) name desc getVotesByOptionIds ids = do - votes <- mapM (\ oId -> do - voters <- getVotersByOptionId oId - return (voters)) ids - let flat_votes = foldl (\acc x -> foldl (\a y -> y:a) acc x) [] votes - return flat_votes + votes <- mapM getVotersByOptionId ids + return $ foldl (foldl (flip (:))) [] votes -getVoteNames votes = foldl voteNameMap M.empty votes +getVoteNames = foldl voteNameMap M.empty voteNameMap acc vote = case M.lookup vName acc of Just ids -> M.insert vName (vOptId:ids) acc - Nothing -> M.insert vName (vOptId:[]) acc + Nothing -> M.insert vName [vOptId] acc where vName = voterName vote vOptId = unSqlBackendKey $ unOptionKey $ voterOptId vote -voterValues = map (\(oId, voters) -> (oId, (map voterName voters))) +voterValues = map (\(oId, voters) -> (oId, map voterName voters)) -voterName vote = (voteVoter (entityVal vote)) -voterOptId vote = (voteOptionId (entityVal vote)) +voterName vote = voteVoter (entityVal vote) +voterOptId vote = voteOptionId (entityVal vote) -getVotersByOptionId oId = - runSqlite "noodle.db" $ do - selectList [VoteOptionId ==. (toSqlKey oId)] [Asc VoteId] +getVotersByOptionId oId = runSqlite "noodle.db" $ + selectList [VoteOptionId ==. toSqlKey oId] [Asc VoteId] -deleteOptions ids = do - runSqlite "noodle.db" $ do +deleteOptions ids = runSqlite "noodle.db" $ mapM_ (\id -> runSqlite "noodle.db" $ do deleteWhere [VoteOptionId ==. id] deleteWhere [OptionId ==. id] ) choosen_ids - where choosen_ids = map (\x -> (toSqlKey (read x))) ids + where choosen_ids = map (toSqlKey . read ) ids voteForOptions name opts c_opt_ids id = do - mapM_ (\i -> runSqlite "noodle.db" $ do - deleteWhere [VoteOptionId ==. (toSqlKey i), VoteVoter ==. name] - ) opts - runSqlite "noodle.db" $ do - deleteWhere [CantPollId ==. pollId, CantName ==. name] - mapM_ (\i -> runSqlite "noodle.db" $ do - insert $ Vote i name - ) choosen_ids - where choosen_ids = map (\x -> (toSqlKey (read x))) c_opt_ids - pollId = (toSqlKey (read id)) + mapM_ (\i -> runSqlite "noodle.db" $ + deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opts + runSqlite "noodle.db" $ deleteWhere [CantPollId ==. pollId, CantName ==. name] + mapM_ (\i -> runSqlite "noodle.db" $ insert $ Vote i name) choosen_ids + where choosen_ids = map (toSqlKey . read) c_opt_ids + pollId = toSqlKey (read id) -doVoting name opt_ids choosen_opt_ids id = do - case (length choosen_opt_ids) of +doVoting name opt_ids choosen_opt_ids id = + case length choosen_opt_ids of 0 -> createCant id name opt_ids otherwise -> voteForOptions name opt_ids choosen_opt_ids id deleteVote id name opts = do - mapM_ (\i -> runSqlite "noodle.db" $ do - deleteWhere [VoteOptionId ==. (toSqlKey i), VoteVoter ==. name] - ) opts - runSqlite "noodle.db" $ do - deleteWhere [CantPollId ==. pollId, CantName ==. name] - where pollId = (toSqlKey (read id)) + mapM_ (\i -> runSqlite "noodle.db" $ + deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opts + runSqlite "noodle.db" $ deleteWhere [CantPollId ==. pollId, CantName ==. name] + where pollId = toSqlKey (read id)