diff --git a/src/Error.hs b/src/Error.hs index a08f949..a758fd4 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -1,3 +1,5 @@ +-- these errors have a big problem, they don't work with Lucid, it's raw Bytestring +-- so no page header .etc doesn't look good at all module Error where import qualified Data.Text as T import Servant.Server.Internal.ServerError diff --git a/src/InstantRunoff.hs b/src/InstantRunoff.hs index 19f01ed..c606b6a 100644 --- a/src/InstantRunoff.hs +++ b/src/InstantRunoff.hs @@ -6,6 +6,8 @@ import qualified Data.Set as S import qualified Data.Maybe as M import qualified Data.Ord as O + +-- find winner, remove winner from ballots, repeat for next place solve :: forall a. Ord a => [a] -> LN.NonEmpty (LN.NonEmpty a) -> [S.Set a] solve candidates votes' = if S.null notVotedForCandidates then solved @@ -33,6 +35,8 @@ winner votes = maybe (M.keysSet $ voteCounts) winner . filterVotes (`S.notMember firstChoiceLosers :: S.Set a firstChoiceLosers = M.keysSet . M.filter ((==) . L.minimum . M.elems $ voteCounts) $ voteCounts + -- in the event of multiple first choice losers, + -- count how many ballots prefer one choice over another losers :: S.Set a losers = S.fromList . smallestSubset preferred . S.toList $ firstChoiceLosers @@ -42,14 +46,15 @@ winner votes = maybe (M.keysSet $ voteCounts) winner . filterVotes (`S.notMember numMatch x = L.length . L.filter (== Just x) $ preferences preferences :: [Maybe a] - preferences = map (ballotFavors . LN.toList) . LN.toList $ votes + preferences = map (ballotPreference . LN.toList) . LN.toList $ votes - ballotFavors :: [a] -> Maybe a - ballotFavors = L.find (`S.member` [x0, x1]) + ballotPreference :: [a] -> Maybe a + ballotPreference = L.find (`S.member` [x0, x1]) voteCounts :: M.Map a Word voteCounts = M.unionsWith (+) + -- If there's a candidate with no first-place votes we need to include that . (candidatesMinimumVoteCounts :) . map (`M.singleton` 1) . LN.toList . diff --git a/src/LucidUtils.hs b/src/LucidUtils.hs index 6f4aebd..5ec0db3 100644 --- a/src/LucidUtils.hs +++ b/src/LucidUtils.hs @@ -19,6 +19,7 @@ pageHead = do pageBody :: L.Html () -> L.Html () pageBody = with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"] +-- TODO: add a footer here fullPage :: L.Html () -> AppM (L.Html ()) fullPage rest = do customHead <- pageHead diff --git a/src/Main.hs b/src/Main.hs index e0e06b3..f4bd0cd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -48,12 +48,6 @@ getFromPollId pollId query = do pollResult <- query pollId throwOrLift (Er.noPollFound pollId) pollResult -notVotedFor :: P.Poll -> S.Set T.Text -notVotedFor (P.Poll {..}) = S.difference allOptions votedFor - where - votedFor = S.unions $ map (S.fromList . B.options) votes - allOptions = S.fromList . LN.toList . P.options $ createInfo - results :: P.PollId -> AppM (L.Html ()) results pollId = do db <- Rd.asks db @@ -61,11 +55,11 @@ results pollId = do case toNonEmptyList . P.votes $ poll of Nothing -> fullPage "poll doesn't have any votes" Just votesList -> do - let results' = (IR.solve (LN.toList . P.options . P.createInfo $ poll) votesList) + let results' = IR.solve (LN.toList . P.options . P.createInfo $ poll) votesList fullPage $ do h2_ "results" toHtml $ T.append (T.pack . show . length . P.votes $ poll) " ballots submitted" - maybe "" (h3_ . toHtml) . P.title . P.createInfo $ poll + maybe (pure ()) (h3_ . toHtml) . P.title . P.createInfo $ poll h3_ . toHtml . P.question . P.createInfo $ poll with div_ [id_ "results"] . mconcat $ zipWith nthPlaceFor results' nthPlaces where @@ -92,6 +86,7 @@ makePoll pollReq = do checkTextLengths db <- Rd.asks db gen <- Rd.asks gen + -- TODO: handle rare case of poll id collision pollId <- P.PollId <$> R.uniformWord64 gen liftIO $ Ac.update db (DB.CreatePoll pollReq pollId) let fillOutLink = toPollIdLink pollId @@ -104,6 +99,7 @@ makePoll pollReq = do checkLength . P.question $ pollReq maybe (pure ()) checkLength . P.title $ pollReq +-- TODO: lift current domain into ENV toPollIdLink :: P.PollId -> T.Text toPollIdLink (P.PollId pollId) = T.append "https://rankedchoice.net/poll/" (T.pack . show $ pollId) @@ -121,12 +117,13 @@ vote pollId ballot = do server :: ServerT A.RCVAPI AppM server = createPage :<|> makePoll - :<|> pure optionWithRemoveButton - :<|> (pure . pure $ ()) + :<|> pure optionWithRemoveButton -- for that add option button on create page + :<|> (pure . pure $ ()) -- for remove option button on create page :<|> getPollForBallot :<|> vote :<|> results :<|> indexPage + -- TODO: always reload static stuff in dev, never reload in prod :<|> serveDirectoryWith (defaultWebAppSettings "public") emptyHiddenInput :: L.Html () @@ -140,9 +137,10 @@ getPollForBallot pollId = do My.maybe (pure ()) (h3_ . toHtml) (P.title createInfo) h3_ . toHtml . P.question $ createInfo with div_ [id_ "drag-boxes-container"] $ do - div_ $ do + div_ $ do -- TODO: check accessibility on this "drag from here" - with div_ [classes_ ["draggable-options","sortable-from", "options", "child-borders", "border-primary", "background-primary"]] . mconcat . map toFormInput . LN.toList . P.options $ createInfo + with div_ [classes_ ["draggable-options","sortable-from", "options", "child-borders", "border-primary", "background-primary"]] + . mconcat . map toFormInput . LN.toList . P.options $ createInfo with form_ [hxPost_ "", id_ "drag-into-vote", hxTarget_ "closest body"] $ do div_$ do "to here in order of preference" @@ -159,7 +157,9 @@ optionInput :: L.Html () optionInput = input_ [required_ "true", name_ "options", maxlength_ "100"] removeButton :: L.Html () -removeButton = with button_ [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest .options > *"] "remove" +removeButton = with button_ + [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest .options > *"] + "remove" optionWithRemoveButton :: L.Html () optionWithRemoveButton = div_ (optionInput <> removeButton) @@ -178,6 +178,9 @@ createPage = do legend_ "options" optionWithoutRemoveButton optionWithoutRemoveButton + -- TODO: + -- when the user adds optionWithRemoveButton on the webpage, the buttons size causes stuff to move + -- ideally there's a visible but disabled button with like a tooltip with button_ [hxGet_ "create/newInput", hxTarget_ "this", hxSwap_ "beforebegin"] "add option" input_ [type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit"] @@ -190,6 +193,8 @@ api = Proxy getEnv :: IO Env getEnv = do db <- DB.openLocalDB + -- this needs to be in a