initial commit

.gitignore

@@ -0,0 +1,3 @@
+dist-newstyle/**
+result/**
+dist/**

cabal.config

@@ -0,0 +1 @@
+compiler: ghcjs

cabal.project

@@ -0,0 +1,3 @@
+ignore-project: False
+package zlib
+  flags: -pkg-config +bundled-c-zlib

client/Main.hs

@@ -0,0 +1,48 @@
+-- | Haskell language pragma
+
+-- | Haskell module declaration
+module Main where
+
+-- | Miso framework import
+import Miso
+import Miso.String
+
+-- | Type synonym for an application model
+type Model = Int
+
+-- | Sum type for application events
+data Action
+  = AddOne
+  | SubtractOne
+  | NoOp
+  | SayHelloWorld
+  deriving (Show, Eq)
+
+-- | Entry point for a miso application
+main :: IO ()
+main = startApp App {..}
+  where
+    initialAction = SayHelloWorld -- initial action to be executed on application load
+    model  = 0                    -- initial model
+    update = updateModel          -- update function
+    view   = viewModel            -- view function
+    events = defaultEvents        -- default delegated events
+    subs   = []                   -- empty subscription list
+    mountPoint = Nothing          -- mount point for application (Nothing defaults to 'body')
+    logLevel = Off                -- used during prerendering to see if the VDOM and DOM are in sync (only used with `miso` function)
+
+-- | Updates model, optionally introduces side effects
+updateModel :: Action -> Model -> Effect Action Model
+updateModel AddOne m = noEff (m + 1)
+updateModel SubtractOne m = noEff (m - 1)
+updateModel NoOp m = noEff m
+updateModel SayHelloWorld m = m <# do
+  putStrLn "Hello World" >> pure NoOp
+
+-- | Constructs a virtual DOM from a model
+viewModel :: Model -> View Action
+viewModel x = div_ [] [
+   button_ [ onClick AddOne ] [ text "+" ]
+ , text (ms x)
+ , button_ [ onClick SubtractOne ] [ text "-" ]
+ ]

default.nix

@@ -0,0 +1,10 @@
+with (import
+(
+builtins.fetchGit {
+        url = "https://github.com/dmjio/miso";
+        ref = "master";
+    }
+)
+{});
+
+pkgs.haskell.packages.ghcjs.callCabal2nix "rcv-site" ./. {}

rcv-site.cabal

@@ -0,0 +1,83 @@
+name:                rcv-site
+version:             0.1.0.0
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable server
+  main-is:
+    Main.hs
+  if impl(ghcjs)
+    buildable: False
+  else
+    default-language:
+      Haskell2010
+    default-extensions:
+      ScopedTypeVariables,
+      OverloadedStrings,
+      OverloadedLists,
+      TemplateHaskell,
+      DataKinds,
+      FlexibleContexts,
+      FlexibleInstances,
+      MultiParamTypeClasses,
+      OverloadedLabels
+      TypeFamilies,
+      UndecidableInstances,
+      RecursiveDo,
+      RecordWildCards,
+      RankNTypes,
+      DuplicateRecordFields,
+      TupleSections,
+      TypeOperators,
+      DeriveGeneric
+    hs-source-dirs:
+      server,
+      shared
+    build-depends:
+      base < 5,
+      aeson,
+      containers,
+      http-types,
+      lucid,
+      miso,
+      mtl,
+      network-uri,
+      servant,
+      servant-lucid,
+      servant-server,
+      text,
+      wai,
+      wai-app-static,
+      wai-extra,
+      warp
+    default-language:
+      Haskell2010
+
+
+executable client
+  main-is:
+    Main.hs
+  if !impl(ghcjs)
+    buildable: False
+  else
+    default-extensions:
+      ScopedTypeVariables,
+      OverloadedStrings,
+      OverloadedLists,
+      RecordWildCards,
+      DuplicateRecordFields,
+      DeriveGeneric
+    ghcjs-options:
+      -dedupe -DGHCJS_GC_INTERVAL=5000
+    hs-source-dirs:
+      client,
+      shared
+    build-depends:
+      aeson,
+      base < 5,
+      containers,
+      miso,
+      servant
+    default-language:
+      Haskell2010

server/InstantRunoff.hs

@@ -0,0 +1,39 @@
+module InstantRunoff where
+import qualified Data.List as L
+import qualified Data.List.NonEmpty as LN
+import qualified Data.Map.Strict as M
+import qualified Data.Maybe as My
+import qualified Data.Set as S
+import Data.Ord
+import Data.Maybe
+import Data.Ratio
+
+
+solve :: Ord a => LN.NonEmpty (LN.NonEmpty a) -> LN.NonEmpty a
+solve votes =
+  case (L.find (\(_, share) -> share > (1 % 2)) . assocs) of
+    Just (winner, share) -> return winner -- singleton not introduced until base 4.15
+    Nothing -> solve . remove $ S.insert noFirstChoice firstChoiceLoser
+  where
+
+    -- fromList is partial, but inputs that would cause a faliure are caught by the case statement
+    remove :: S.Set a -> LN.NonEmpty (LN.NonEmpty a)
+    remove toRemove = LN.fromList . LN.filter null . LN.map (`elem` toRemove) $ votes
+
+    firstChoiceLoser :: a
+    firstChoiceLoser = L.minimumBy (\(_, a0) (_, a1) -> compare a0 a1) . LN.map LN.head $ voteShares'
+
+    firstChoices :: LN.NonEmpty a
+    firstChoices = LN.map LN.head $ votes
+
+    voteShares' :: LN.NonEmpty a -> M.Map a (Ratio Int)
+    voteShares' = voteShares firstChoices
+
+    noFirstChoice :: S.Set a
+    noFirstChoice = (S.fromList LN.toList . mconcat $ votes) S.\\ (S.fromList . LN.toList $ firstChoices)
+
+allSame :: Eq a => [a] -> Bool
+allSame = (== 1) . LN.length . LN.nub
+
+voteShares :: Ord a => LN.NonEmpty a -> M.Map a (Ratio Int)
+voteShares l = M.map (% (LN.length l)) . M.fromListWith (+) . map (, 1) . LN.toList $ l

server/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+import qualified InstantRunoff as IR
+import qualified API as A
+
+main :: IO ()
+main = putStrLn "todo"

shared/API.hs

@@ -0,0 +1,24 @@
+module API where
+
+import Servant.API
+import Data.Text (Text)
+import Data.Aeson
+import qualified Data.List.NonEmpty as LN
+
+type Ballot = LN.NonEmpty Text
+
+data Poll = Poll {
+  question :: Text,
+  options :: Ballot
+} deriving (Generic, Ord, Eq)
+
+instance FromJSON Poll
+instance ToJSON Poll
+
+instance FromJSON Ballot
+instance ToJSON Ballot
+
+type RCVAPI =
+  "poll" :> Capture "pollId" :> "vote" :> ReqBody '[JSON] Ballot :> Post '[JSON] ()
+  <|> "poll" :> "create" :> ReqBody '[JSON] Poll :> Post '[JSON] Int
+  <|> "poll" :> Capture "pollId" :> Get '[JSON] Poll